packages feed

dnsbase (empty) → 1.0.0.0

raw patch · 98 files changed

+18803/−0 lines, 98 filesdep +basedep +base16dep +base32

Dependencies added: base, base16, base32, base64, bytestring, containers, crypton, deepseq, dnsbase, hashtables, hourglass, iproute, monad-ste, mtl, network, primitive, tasty, tasty-bench, tasty-hunit, tasty-quickcheck, template-haskell, text, time, transformers, unordered-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Changelog++## 1.0.0.0++First public release on Hackage.  See [`README.md`](README.md) for+an overview of the library and its differentiators.
+ LICENSE view
@@ -0,0 +1,34 @@+BSD 3-Clause License++Copyright (c) 2023, dnsbase++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++This package includes code derived from the "dns" Haskell library+(<https://hackage.haskell.org/package/dns>) by Kazu Yamamoto, originally+Copyright (c) 2009 IIJ Innovation Institute Inc.  That code is licensed+under the same BSD-3-Clause terms; the original notice and disclaimer+are preserved in LICENSE.dns.
+ LICENSE.dns view
@@ -0,0 +1,29 @@+Copyright (c) 2009, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++  * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.+  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in+    the documentation and/or other materials provided with the+    distribution.+  * Neither the name of the copyright holders nor the names of its+    contributors may be used to endorse or promote products derived+    from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,96 @@+# Base DNS library with extensible core types++A DNS stub-resolver library with a typed `RData` model and a runtime+extension API.  The IO layer is derived from Kazu Yamamoto's+[`dns`](https://hackage.haskell.org/package/dns) package; what+`dnsbase` layers on top sits in the RR-data model and the+configuration story.++Every RR type's payload is modeled via a dedicated Haskell type —+these include, for example, the recent SVCB / HTTPS service-binding+records, with up-to-date extensible SvcParam coverage.  EDNS option+support includes Extended DNS Errors (EDE) with a user-extensible+info-code name table.  Coverage of both widely used and historical+DNS RR types is comprehensive — only the most marginal obsolete or+experimental types remain unimplemented.++Applications can extend the library with any *missing* RRtypes,+EDNS(0) options, or SVCB / HTTPS SvcParam values.+Application-specified data types take precedence over any existing+or later-added built-in implementations.++Extensions are registered by constructing a pure resolver+configuration value, rather than via IO actions on mutable global+state.  Adding custom data types to the library does not require a+source-code fork.  See+[Adding a custom RR type](https://hackage.haskell.org/package/dnsbase/docs/Net-DNSBase-Extensible.html#customRRtype)+and+[Adding a custom EDNS option](https://hackage.haskell.org/package/dnsbase/docs/Net-DNSBase-Extensible.html#customEDNS)+for detailed examples.++The basic lookup interface (`lookupA`, `lookupMX`, `lookupTXT`, …)+is deliberately similar to `dns`; the differences are concentrated+in the typed-data layer and the configuration surface.++## Basic MX lookup example++The example below prints the MX records of `ietf.org`, if any, or an error+message if the answer can't be obtained.++The compile-time literal splice used here is `dnLit8`, the octet-level form+that accepts any RFC 1035 master-file string (the input is treated as raw+bytes, with `\DDD` and `\C` escapes).  For IDN-aware literals — strict+IDNA2008 validation, U-label encoding to A-labels, optional cross-label Bidi+checks — use `dnLit` from `Net.DNSBase.Domain` with a parser from the+companion `idna2008` package; see the `dnLit` haddock for the composition+idiom.++```haskell+{-# LANGUAGE+    BlockArguments+  , LambdaCase+  , RecordWildCards+  , TemplateHaskell+  #-}+import Control.Exception (throwIO)+import Net.DNSBase+import System.IO (stdout)++main :: IO ()+main = makeResolvSeed defaultResolvConf >>= \ case+    Right seed -> withResolver seed \ r ->+        lookupMX r $$(dnLit8 "ietf.org") >>= \ case+            Right mxs -> hPutBuilder stdout $ foldr presentLn mempty mxs+            Left errs -> throwIO errs+    Left errs -> throwIO errs+```++## Custom extensions++The [`demos/`](https://github.com/dnsbase/dnsbase/tree/main/demos)+directory contains worked examples for each of the three extension+targets:++- [`demoextrr.hs`](https://github.com/dnsbase/dnsbase/blob/main/demos/demoextrr.hs)+  — adding a custom RR type, by shadowing the standard `A` record+  with a raw-`Word32` representation that presents each address as+  eight hex nibbles under a made-up name `HEXA`.  Shows the+  `KnownRData` instance shape and registration via+  `registerRRtype`.+- [`demoextopt.hs`](https://github.com/dnsbase/dnsbase/blob/main/demos/demoextopt.hs)+  — adding an EDNS(0) option (the EDNS cookie, RFC 7873), queried+  directly against `ns1.isc.org` to elicit a server cookie.  Shows+  the `KnownEdnsOption` instance shape, registration via+  `registerEdnsOption`, and per-call option injection via+  `optCtlAdd`.+- [`demoextspv.hs`](https://github.com/dnsbase/dnsbase/blob/main/demos/demoextspv.hs)+  — adding (here, shadowing) an HTTPS / SVCB service parameter, by+  re-implementing the `ipv4hint` key (codepoint 4) with a+  raw-`Word32`-list representation and a hex presentation form+  under a made-up name `IPV4HEX`.  Shows the `KnownSVCParamValue`+  instance shape and the registration via `extendRRwithType`+  applied to both `T_svcb` and `T_https` (SVCB-shaped RRs share+  the SvcParam codec map).++Each demo is a self-contained program; copy one into a project+and adjust the queries to taste.
+ bench/bench.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE+    OverloadedLists+  , OverloadedStrings+  , RecordWildCards+  , TemplateHaskell+  #-}+module Main (main) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Short as SB+import Data.ByteString.Short (ShortByteString)+import Data.Coerce (coerce)+import Data.Either (fromRight)+import Data.Word (Word8)++import Net.DNSBase++import Test.Tasty.Bench++main :: IO ()+main = defaultMain+    [ bench "towire"       $ whnf makeDomain8 pdom+    , bench "fromwire"     $ whnf presentStrict ldom+    , bench "enc question" $ whnf encodeQuestion question+    , bench "enc answer"   $ whnf encodeAnswer answer+    , bench "compress"     $ whnf encodeDomains dlist+    ]+  where+    bs = B.pack $ map i2w [17..36]+    i2w :: Int -> Word8+    i2w i = fromIntegral $ i*i++    pdom = "12345.example.com"+    ldom = $$(dnLit8 "12345.example.com")++    question = DnsTriple $$(dnLit8 "example.com") MX IN+    encodeQuestion = fromRight B.empty . enc+      where+        enc :: DnsTriple -> Either (EncodeErr (Maybe RData)) B.ByteString+        enc q = encodeVerbatim $ putRequest 0xbeef (RDflag <> ADflag) (Just defaultEDNS) q++    zone = $$(dnLit8 "example.com")++    hash :: ShortByteString+    hash = coerce @Bytes16 "01ba4719c80b6fe911b091a7c05124b64eeece964e09c058ef8f9805daca546b"+    pkey, psig :: ShortByteString+    pkey = coerce @Bytes64 "4xQugTVSY2+Xu6J390EnCLmGKAtoR+7h5J9kJa0H/N5W4p8P43aSX4y67OqH4wiW/QD4tKrv0YbdeO6ynhKoTQ=="+    psig = coerce @Bytes64 "EIJK5j86gvtYU90Cb3jbIa+xH8lntJoG8bgG6dkgCu/VY2XenqCi8VHUfq0tjW2hlQmfbYj3c6V9T0g0RQlFH1hHeH/J4gxqzyJZU+EsxxD9fzOYjuHmEmJBE15QD/YQ8mU5K64SVOYs7F+BcFcduwyKWIPkwwOSKK0Y04/mhTvHn9HAjD0J0vfPTDfZs748IKOOvH7RAp5ryAImSn8S4g6wQaFdxgHhzNUT0TNbDFrTBYDheFHbJcNS+8Yy+9pBqwshb3aDjWzQ9i1JoSfXXWNu4n1j6jGOOcflhYBU10NcZn+VDz6tsKqrt3JlTtIjHUVgp3pQhLpJGA5RbJ+IrA=="++    fakesha12 :: ShortByteString+    fakesha12 = SB.pack [1..20]++    mkRD :: KnownRData a => Domain -> a -> RR+    mkRD d a = RR d IN 300 $ RData a++    txt1, txt2, txt3, txt4, txt5, txt6 :: RR;+    txt1 = mkRD $$(dnLit8 "example.nl") $ T_TXT+                $ "offset" :| [" 0"]+    txt2 = mkRD $$(dnLit8 "example.nl") $ T_TXT+                $ "pointer to offset 0" :| []+    txt3 = mkRD $$(dnLit8 "www.example.nl") $ T_TXT+                $ "www -> offset 0" :| []+    txt4 = mkRD $$(dnLit8 "example.dk") $ T_TXT+                $ "new ccTLD" :| []+    txt5 = mkRD $$(dnLit8 "example.dk") $ T_TXT+                $ "pointer to dk ccTLD" :| []+    txt6 = mkRD $$(dnLit8 "www.example.dk") $ T_TXT+                $ "www -> dk ccTLD" :| []++    addr1, addr2 :: RR+    addr1 = mkRD $$(dnLit8 "addr1.example.se") $ T_A "192.0.2.1"+    addr2 = mkRD $$(dnLit8 "www.example.se")   $ T_AAAA "2001:db8::dead:beef"++    cname, dname, ptr :: RR+    cname = mkRD $$(dnLit8 "cname.example.se")+        $ T_CNAME $$(dnLit8 "cname.example")+    dname = mkRD $$(dnLit8 "_tcp.a.example.se")+        $ T_DNAME $$(dnLit8 "_tlsa.name")+    ptr   = mkRD $$(dnLit8 "10.in-addr.arpa")+        $ T_PTR $$(dnLit8 "ptr")++    ds, cds, key, cky, sig :: RR+    ds  = mkRD $$(dnLit8 "ds.example.dk")+        $ T_DS  12345 13 2 hash+    cds = mkRD $$(dnLit8 "cds.example.dk")+        $ T_CDS 12345 13 2 hash+    key = mkRD $$(dnLit8 "dnskey.example.se")+        $ T_DNSKEY  256 3 13 pkey+    cky = mkRD $$(dnLit8 "cdnskey.example.se")+        $ T_CDNSKEY 256 3 13 pkey+    sig = mkRD $$(dnLit8 "rrsig.example.nl")+        $ T_RRSIG SOA 8 1 172800 1582491183 1581333041 40264 $$(dnLit8 "example.nl") psig++    nsec, nsec3, nsec3p :: RR+    nsec = mkRD $$(dnLit8 "nsec.example.dk")+        $ T_NSEC $$(dnLit8 "example.dk")+          [SOA, DNSKEY, NS, RRSIG, MX, NSEC, TXT]+    nsec3 = mkRD $$(dnLit8 "nsec3.example.dk")+        $ T_NSEC3 N3_SHA1 0 0 "" fakesha12+          [SOA, DNSKEY, NS, RRSIG, MX, NSEC, TXT]+    nsec3p = mkRD $$(dnLit8 "nsec3param.example.dk")+        $ T_NSEC3PARAM N3_SHA1 1 0 ""++    ns, soa :: RR+    ns  = mkRD $$(dnLit8 "example.nl")+        $ T_NS $$(dnLit8 "ns1.example.nl")+    soa = mkRD $$(dnLit8 "example.nl") $ T_SOA+               $$(dnLit8 "ns1.example.nl")+               $$(mbLit8 "hostmaster@example.nl") 1 3600 300 (7 * 86400) 300++    opaque :: RR+    opaque = RR $$(dnLit8 "whatami.example") IN 300+        $ opaqueRData 1 "c0000201"++    mx, srv, afs :: RR+    mx  = mkRD $$(dnLit8 "ietf.org")+        $ T_MX 10 $$(dnLit8 "mail.ietf.org")+    srv = mkRD $$(dnLit8 "ietf.org")+        $ T_SRV 100 0 389 $$(dnLit8 "ldap.ietf.org")+    afs = mkRD $$(dnLit8 "athena.mit.edu")+        $ T_AFSDB 1 $$(dnLit8 "afsdb.athena.mit.edu")++    tlsa :: RR+    tlsa = mkRD $$(dnLit8 "_25._tcp.mail.ietf.org")+        $ T_TLSA 3 1 1 hash++    answer = mkAnswer zone MX NOERROR (RDflag <> RAflag <> ADflag) (Just defaultEDNS)+        [ txt1, txt2, txt3, txt4, txt5, txt6+        , addr1, addr2, cname, ptr, ns, dname+        , ds, cds, key, cky, sig, nsec, nsec3, nsec3p+        , soa, opaque, mx, srv, afs, tlsa ]++    mkAnswer qname qtype rc fl edns an = DNSMessage{..}+      where+        dnsMsgId = 0xbeef+        dnsMsgOp = Query+        dnsMsgRC = rc+        dnsMsgFl = fl+        dnsMsgEx = edns+        dnsMsgQu = [DnsTriple qname qtype IN]+        dnsMsgAn = an+        dnsMsgNs = []+        dnsMsgAr = []++    encodeAnswer :: DNSMessage -> B.ByteString+    encodeAnswer   = fromRight B.empty . enc+      where+        enc :: DNSMessage -> Either (EncodeErr (Maybe RData)) B.ByteString+        enc msg = encodeCompressed $ putMessage msg++    dlist = [zone, zone, mx1, zone, mx2, mx1, mx2]+      where+        mx1 = $$(dnLit8 "mx1.example.com")+        mx2 = $$(dnLit8 "mx2.example.com")++    encodeDomains :: [Domain] -> B.ByteString+    encodeDomains = fromRight B.empty . enc+      where+        enc :: [Domain] -> Either (EncodeErr (Maybe ())) B.ByteString+        enc doms = encodeCompressed $ mapM_ putDomain doms
+ dnsbase.cabal view
@@ -0,0 +1,338 @@+cabal-version:  3.12+name:           dnsbase+version:        1.0.0.0+build-type:     Simple+synopsis:       Stub DNS resolver with a typed RData model and value-based extension API++description:    A DNS stub resolver library for Haskell.  The IO layer is+                derived from Kazu Yamamoto's @dns@ package; what @dnsbase@+                adds is a rich set of RRtypes and a runtime-extensible+                RRtype data model with a simple configuration interface.+                .+                Every RR type's payload is modeled as a dedicated Haskell+                type — these include, for example, the recent SVCB and HTTPS+                service-binding records, with extensible up-to-date SvcParam+                coverage.  EDNS option support includes Extended DNS Errors+                (EDE) whose info-code name table is user-extensible.  Coverage+                of both widely used and historical DNS RR types is comprehensive+                — only the most marginal obsolete or experimental types remain+                unimplemented.+                .+                Applications can extend the library with any /missing/+                RRTYPEs, EDNS(0) options, SVCB and HTTPS SvcParam values.+                Application-specified data types take precedence over any+                existing or later added built-in implementations.+                .+                Extensions are registered by constructing a pure resolver+                configuration value, rather than via IO actions on mutable+                global state.  Adding custom data types to the library does not+                require a source-code fork.  See the+                <https://hackage-content.haskell.org/package/dnsbase-1.0.0.0/candidate/docs/Net-DNSBase-Extensible.html Net.DNSBase.Extensible>+                module for+                <https://hackage-content.haskell.org/package/dnsbase-1.0.0.0/candidate/docs/Net-DNSBase-Extensible.html#customRRtype detailed examples>+                .+                The library has been deployed as part of a DANE/DNSSEC survey+                for many years, and performs ~108 million queries each day,+                over approximately 3.5 hours (while also saving results to a+                database and performing some SMTP STARTTLS probes).  Domain-name+                parsing supports 8-bit RFC 1035 names directly and also+                supports pluggable @Text@-based parsers via external+                libraries, for example from the companion+                <https://hackage.haskell.org/package/idna2008 idna2008>+                package.+                .++license:        BSD-3-Clause+license-files:  LICENSE+                LICENSE.dns+author:         Viktor Dukhovni+maintainer:     ietf-dane@dukhovni.org+homepage:       https://github.com/dnsbase/dnsbase+bug-reports:    https://github.com/dnsbase/dnsbase/issues+copyright:      2018-2026 Viktor Dukhovni+category:       Network+tested-with: GHC == 9.10.3+           , GHC == 9.12.3+extra-source-files:+    CHANGELOG.md+    README.md++common all+  ghc-options: -O2 -Wall+  default-language: GHC2024+  default-extensions:+    BlockArguments+    DerivingVia+    MultiWayIf+    PatternSynonyms+    RequiredTypeArguments+    StrictData+    TypeFamilies+    ViewPatterns++common deps+  build-depends:+      base                  >=4.20      && <5+    , base16               ^>=1.0+    , base32                >=0.3       && <0.5+    , base64               ^>=1.0+    , bytestring            >=0.10.8    && <0.13+    , crypton               >=0.30      && <1.2+    , containers            >=0.6       && <0.9+    , deepseq              ^>=1.5+    , hashtables            >=1.2       && <1.6+    , hourglass            ^>=0.2.12+    , iproute              ^>=1.7.9+    , monad-ste            ^>=0.1+    , mtl                   >=2.2       && <2.4+    , network               >=3.1       && <3.3+    , primitive             >=0.8       && <0.10+    , template-haskell      >=2.22      && <2.25+    , text                  >=2.0       && <2.2+    , time                  >=1.11      && <1.16+    , transformers          >=0.5       && <2.7+    , unordered-containers ^>=0.2++-- Shared source layout for both the main library and the+-- test-only internal library.  Both compile the same .hs files+-- under @src@ and @internal@; the two library stanzas differ+-- only in which modules they expose.+common library-source+  hs-source-dirs: src internal++-- Test-only sub-library that exposes every module of the package.+-- Tests @build-depends: dnsbase:internal@ instead of @dnsbase@ so+-- they can reach internal modules without going through a hidden+-- import.  Built only when the package's test components are built.+library internal+  import: all, deps, library-source+  visibility: private+  exposed-modules:+    Net.DNSBase+    Net.DNSBase.Bytes+    Net.DNSBase.Decode.Domain+    Net.DNSBase.Decode.State+    Net.DNSBase.Domain+    Net.DNSBase.EDNS+    Net.DNSBase.EDNS.OptNum+    Net.DNSBase.EDNS.Option+    Net.DNSBase.EDNS.Option.ECS+    Net.DNSBase.EDNS.Option.EDE+    Net.DNSBase.EDNS.Option.NSID+    Net.DNSBase.EDNS.Option.Opaque+    Net.DNSBase.EDNS.Option.Secalgs+    Net.DNSBase.Encode.Metric+    Net.DNSBase.Encode.State+    Net.DNSBase.Error+    Net.DNSBase.Extensible+    Net.DNSBase.Flags+    Net.DNSBase.Lookup+    Net.DNSBase.Message+    Net.DNSBase.Nat16+    Net.DNSBase.NonEmpty+    Net.DNSBase.NsecTypes+    Net.DNSBase.Opcode+    Net.DNSBase.Present+    Net.DNSBase.RCODE+    Net.DNSBase.RData+    Net.DNSBase.RData.A+    Net.DNSBase.RData.CAA+    Net.DNSBase.RData.CSYNC+    Net.DNSBase.RData.Dnssec+    Net.DNSBase.RData.NSEC+    Net.DNSBase.RData.Obsolete+    Net.DNSBase.RData.SOA+    Net.DNSBase.RData.SRV+    Net.DNSBase.RData.SVCB+    Net.DNSBase.RData.SVCB.SPV+    Net.DNSBase.RData.SVCB.SPVList+    Net.DNSBase.RData.SVCB.SPVSet+    Net.DNSBase.RData.SVCB.SVCParamKey+    Net.DNSBase.RData.SVCB.SVCParamValue+    Net.DNSBase.RData.TLSA+    Net.DNSBase.RData.TXT+    Net.DNSBase.RData.WKS+    Net.DNSBase.RData.XNAME+    Net.DNSBase.RR+    Net.DNSBase.RRCLASS+    Net.DNSBase.RRTYPE+    Net.DNSBase.RRSet+    Net.DNSBase.Resolver+    Net.DNSBase.Secalgs+    Net.DNSBase.Text+    Net.DNSBase.Decode.Internal.Domain+    Net.DNSBase.Decode.Internal.Message+    Net.DNSBase.Decode.Internal.Option+    Net.DNSBase.Decode.Internal.RData+    Net.DNSBase.Decode.Internal.State+    Net.DNSBase.EDNS.Internal.OptNum+    Net.DNSBase.EDNS.Internal.Option+    Net.DNSBase.EDNS.Internal.Option.Opaque+    Net.DNSBase.Encode.Internal.Metric+    Net.DNSBase.Encode.Internal.State+    Net.DNSBase.Internal.Bytes+    Net.DNSBase.Internal.Domain+    Net.DNSBase.Internal.EDNS+    Net.DNSBase.Internal.Error+    Net.DNSBase.Internal.Flags+    Net.DNSBase.Internal.Message+    Net.DNSBase.Internal.NameComp+    Net.DNSBase.Internal.Nat16+    Net.DNSBase.Internal.Opcode+    Net.DNSBase.Internal.Peer+    Net.DNSBase.Internal.Present+    Net.DNSBase.Internal.RCODE+    Net.DNSBase.Internal.RData+    Net.DNSBase.Internal.RR+    Net.DNSBase.Internal.RRCLASS+    Net.DNSBase.Internal.RRTYPE+    Net.DNSBase.Internal.SockIO+    Net.DNSBase.Internal.Text+    Net.DNSBase.Internal.Transport+    Net.DNSBase.Internal.Util+    Net.DNSBase.RData.Internal.XNAME+    Net.DNSBase.Resolver.Internal.Encoding+    Net.DNSBase.Resolver.Internal.Parser+    Net.DNSBase.Resolver.Internal.Types++-- The main library.  This is what downstream packages (and Hackage)+-- see; @other-modules@ keeps the implementation hidden but compiled+-- into the same library, so haddocks on internal symbols propagate+-- to their public re-exports.+library+  import: all, deps, library-source+  exposed-modules:+    Net.DNSBase+    Net.DNSBase.Bytes+    Net.DNSBase.Decode.Domain+    Net.DNSBase.Decode.State+    Net.DNSBase.Domain+    Net.DNSBase.EDNS+    Net.DNSBase.EDNS.OptNum+    Net.DNSBase.EDNS.Option+    Net.DNSBase.EDNS.Option.ECS+    Net.DNSBase.EDNS.Option.EDE+    Net.DNSBase.EDNS.Option.NSID+    Net.DNSBase.EDNS.Option.Opaque+    Net.DNSBase.EDNS.Option.Secalgs+    Net.DNSBase.Encode.Metric+    Net.DNSBase.Encode.State+    Net.DNSBase.Error+    Net.DNSBase.Extensible+    Net.DNSBase.Flags+    Net.DNSBase.Lookup+    Net.DNSBase.Message+    Net.DNSBase.Nat16+    Net.DNSBase.NonEmpty+    Net.DNSBase.Opcode+    Net.DNSBase.Present+    Net.DNSBase.RCODE+    Net.DNSBase.RData+    Net.DNSBase.RData.A+    Net.DNSBase.RData.CAA+    Net.DNSBase.RData.CSYNC+    Net.DNSBase.RData.Dnssec+    Net.DNSBase.RData.NSEC+    Net.DNSBase.RData.Obsolete+    Net.DNSBase.RData.SOA+    Net.DNSBase.RData.SRV+    Net.DNSBase.RData.SVCB+    Net.DNSBase.RData.TLSA+    Net.DNSBase.RData.TXT+    Net.DNSBase.RData.WKS+    Net.DNSBase.RData.XNAME+    Net.DNSBase.RR+    Net.DNSBase.RRCLASS+    Net.DNSBase.RRTYPE+    Net.DNSBase.RRSet+    Net.DNSBase.Resolver+    Net.DNSBase.Secalgs+    Net.DNSBase.Text+  other-modules:+    Net.DNSBase.NsecTypes+    Net.DNSBase.RData.SVCB.SPV+    Net.DNSBase.RData.SVCB.SPVList+    Net.DNSBase.RData.SVCB.SPVSet+    Net.DNSBase.RData.SVCB.SVCParamKey+    Net.DNSBase.RData.SVCB.SVCParamValue+    Net.DNSBase.Decode.Internal.Domain+    Net.DNSBase.Decode.Internal.Message+    Net.DNSBase.Decode.Internal.Option+    Net.DNSBase.Decode.Internal.RData+    Net.DNSBase.Decode.Internal.State+    Net.DNSBase.EDNS.Internal.OptNum+    Net.DNSBase.EDNS.Internal.Option+    Net.DNSBase.EDNS.Internal.Option.Opaque+    Net.DNSBase.Encode.Internal.Metric+    Net.DNSBase.Encode.Internal.State+    Net.DNSBase.Internal.Bytes+    Net.DNSBase.Internal.Domain+    Net.DNSBase.Internal.EDNS+    Net.DNSBase.Internal.Error+    Net.DNSBase.Internal.Flags+    Net.DNSBase.Internal.Message+    Net.DNSBase.Internal.NameComp+    Net.DNSBase.Internal.Nat16+    Net.DNSBase.Internal.Opcode+    Net.DNSBase.Internal.Peer+    Net.DNSBase.Internal.Present+    Net.DNSBase.Internal.RCODE+    Net.DNSBase.Internal.RData+    Net.DNSBase.Internal.RR+    Net.DNSBase.Internal.RRCLASS+    Net.DNSBase.Internal.RRTYPE+    Net.DNSBase.Internal.SockIO+    Net.DNSBase.Internal.Text+    Net.DNSBase.Internal.Transport+    Net.DNSBase.Internal.Util+    Net.DNSBase.RData.Internal.XNAME+    Net.DNSBase.Resolver.Internal.Encoding+    Net.DNSBase.Resolver.Internal.Parser+    Net.DNSBase.Resolver.Internal.Types++-- Test framework dependencies, split out so individual stanzas+-- can opt in.+common test-deps+  build-depends:+      tasty+    , tasty-hunit+    , tasty-quickcheck++common test+  import: all, deps+  hs-source-dirs: tests+  build-depends: dnsbase:internal++test-suite domain+  import: test+  type: exitcode-stdio-1.0+  main-is: domain.hs++test-suite literals+  import: test+  type: exitcode-stdio-1.0+  main-is: literals.hs+  other-modules: LiteralsParser++test-suite message+  import: test+  type: exitcode-stdio-1.0+  main-is: message.hs++test-suite extensibility+  import: test, test-deps+  type: exitcode-stdio-1.0+  main-is: extensibility.hs++test-suite test+  import: test, test-deps+  type: exitcode-stdio-1.0+  main-is: test.hs++benchmark bench+  import: test+  hs-source-dirs: bench+  type: exitcode-stdio-1.0+  main-is: bench.hs+  build-depends:+      tasty-bench
+ internal/Net/DNSBase/Decode/Internal/Domain.hs view
@@ -0,0 +1,98 @@+-- |+-- Module      : Net.DNSBase.Decode.Internal.Domain+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Decode.Internal.Domain+    ( getDomain+    , getDomainNC+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B++import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.Util++-- | Wire form length limit, sans final empty root label.+maxWireLen :: Int+maxWireLen = 255++-- | Parse a wire-form domain with \"No Compression\" (i.e. treat pointer labels+--   as invalid)+--+-- When defining the decoders for newly standardized RData types, it is+-- generally required to use this function to decode transparent domain fields,+-- as name compression is explicitly forbidden for domain fields of future RData+-- types (see 'getDomain' for reference)+getDomainNC :: SGet Domain+getDomainNC = do+    (_, bldr) <- getDomain' False =<< getPosition+    case buildDomain (Just bldr) of+        Just dom -> pure dom+        Nothing  -> failSGet "Internal error"++-- | Parse a wire-form domain with name compression (pointer labels) allowed+--+-- This function should only be used when decoding the owner name of resource+-- records, as well as for fields of the initial set of RData types defined in+-- [RFC 1035](https://tools.ietf.org/html/rfc1035) and several others listed in+-- section 4 of [RFC 3597](https://tools.ietf.org/html/rfc3597#section-4),+-- which also states that future RData types MUST NOT use name compression+getDomain :: SGet Domain+getDomain = do+    -- No name (de)compression if the input is only a message fragment.+    nc <- getNameComp+    (_, bldr) <- getDomain' nc =<< getPosition+    case buildDomain (Just bldr) of+        Just dom -> pure dom+        Nothing  -> failSGet "Internal error"++-- | First octet of a label determines the interpretation of the rest of the label;+--   11XX_XXXX indicates a 14-bit compression pointer composed of the low 6 bits of+--   that octet and the entirety of the next octet, while 00XX_XXXX is used for a+--   standard label to encode its length (<=63). 01XX_XXXX was proposed for extended+--   labels but remains experimental, and 10XX_XXXX is presently undefined. Latest+--   status can be found in+--   [IANA registry](https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-10)+getDomain' :: Bool -> Int -> SGet (Int, B.Builder)+getDomain' allowPtr start = do+    vl <- get8+    if | vl == 0 -> do+            end <- getPosition+            -- Including the terminal empty label length byte+            getSlice start (end+1)+       | vl <= 63 -> do+            let len = fromIntegral vl+            skipNBytes len+            getDomain' allowPtr start+       | vl >= 0b1100_0000 -> do+            unless allowPtr $ failSGet "domain name compression not allowed in current context"+            end <- getPosition+            (plen, prefix) <- getSlice start end+            vl' <- get8+            let offset :: Word16+                offset = (fromIntegral (vl .&. 0x3f) `shiftL` 8) .|. (fromIntegral vl')+            when (fromIntegral offset >= start) $ failSGet "invalid compression pointer"+            (slen, suffix) <- getPtr offset+            let len = plen + slen+            when (len > maxWireLen) do+                failSGet "domain name too long"+            return $ (len, prefix <> suffix)+       | otherwise -> failSGet "unsupported label type"+  where+    getPtr :: Word16 -> SGet (Int, B.Builder)+    getPtr off = seekSGet off $ getPosition >>= getDomain' allowPtr++    -- get a bytestring slice from position i to position j-1+    getSlice :: Int -> Int -> SGet (Int, B.Builder)+    getSlice off ((subtract (off + 1)) -> len)+       | len < 0          = failSGet "negative-length domain name slice"+       | len > maxWireLen = failSGet "domain name too long"+       | otherwise = do+          buf <- getPacket+          let slice = B.take len $ B.drop off buf+          return $ (len, B.byteString slice)
+ internal/Net/DNSBase/Decode/Internal/Message.hs view
@@ -0,0 +1,168 @@+-- |+-- Module      : Net.DNSBase.Decode.Internal.Message+-- Description : Decoder for the DNS message envelope (header, sections)+-- Copyright   : (c) IIJ Innovation Institute Inc., 2009+--               (c) Viktor Dukhovni, 2020-2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Decode.Internal.Message+      ( getMessage+      ) where++import Data.List (partition)++import Net.DNSBase.Decode.Internal.Domain+import Net.DNSBase.Decode.Internal.Option+import Net.DNSBase.Decode.Internal.RData+import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.EDNS+import Net.DNSBase.Internal.Error+import Net.DNSBase.Internal.Flags+import Net.DNSBase.Internal.Message+import Net.DNSBase.Internal.Opcode+import Net.DNSBase.Internal.RCODE+import Net.DNSBase.Internal.RData+import Net.DNSBase.Internal.RR+import Net.DNSBase.Internal.RRCLASS+import Net.DNSBase.Internal.RRTYPE+import Net.DNSBase.Internal.Util++-- | Decoder for a complete DNSMessage, including EDNS pseudo-header information when present+getMessage :: RDataMap -> OptionMap -> SGet DNSMessage+getMessage dm om = local (setDecodeSection DnsHeaderSection) do+    phd <- getPartialHeader+    qdCount <- getInt16+    anCount <- getInt16+    nsCount <- getInt16+    arCount <- getInt16+    queries <- local (setDecodeSection DnsQuestionSection) $ getQueries qdCount+    if | hasAnyFlags TCflag $ p_dnsMsgFl phd+            -- Don't bother parsing RRs of truncated messages, we won't use+            -- them, and they can be truncated in a way that raises parser+            -- errors.+         -> pure $ mkMsg phd No queries [] [] []+       | otherwise -> do+            if | q:_ <- queries -> () <$ setLastOwner (dnsTripleName q)+               | otherwise      -> pure ()+            answers <- local (setDecodeSection DnsAnswerSection) $ getRRs dm Nothing anCount+            authrrs <- local (setDecodeSection DnsAuthoritySection) $ getRRs dm Nothing nsCount+            addnrrs <- local (setDecodeSection DnsAdditionalSection) $ getRRs dm (Just om) arCount+            case partition isOpt addnrrs of+                ([], rrs) -> pure $ mkMsg phd No queries answers authrrs rrs+                ([optrr], rrs)+                    | RootDomain <- rrOwner optrr+                    , edns <- getEDNS optrr+                      -> pure $ mkMsg phd edns queries answers authrrs rrs+                _ -> local (setDecodeSection DnsEDNSSection) $+                         failSGet "Multiple or bad additional section OPT records"+  where+    isOpt :: RR -> Bool+    isOpt = (== OPT) . rdataType . rrData++    getEDNS :: RR -> EDNSData+    getEDNS rr+      | Just (edns, ext_rc, ext_fl) <- optEDNS rr = Yes{..}+        -- Should not happen, the OPT record should always be a T_OPT!+      | otherwise                                 = No++    optEDNS :: RR -> Maybe (EDNS, Word8, Word16)+    optEDNS (RR _ vcl vttl rd)+        | Just (T_OPT opts) <- fromRData rd+        , ext_rc <- fromIntegral $ (vttl `shiftR` 24) .&. 0xff+        , vers   <- fromIntegral $ (vttl `shiftR` 16) .&. 0xff+        , ext_fl <- fromIntegral $ vttl .&. 0xffff+            = Just (EDNS vers (coerce vcl) opts, ext_rc, ext_fl)+        | otherwise+            = Nothing++-- | Decoder for a list of question (query) fields appearing within a DNS+-- message.  The integer parameter corresponds to the reported QDCOUNT of the+-- message, which should never be more than 1; this decoder neither tests nor+-- enforces this constraint and will attempt to decode exactly as many+-- questions as are reported to exist.+getQueries :: Int -> SGet [DnsTriple]+getQueries n = replicateM n getQuery+  where+    getQuery :: SGet DnsTriple+    getQuery = DnsTriple <$> getDomain <*> getType <*> getClass+      where+        getType = RRTYPE <$> get16+        getClass = RRCLASS <$> get16++-- | Decoder for a known-length list of resource records+getRRs :: RDataMap -> Maybe OptionMap -> Int -> SGet [RR]+getRRs dm om n = replicateM n (getRR dm om)++-- | Decoder for a 'PartialHeader' contained in the header of a DNS message+getPartialHeader :: SGet PartialHeader+getPartialHeader =+    makeHeader <$> decodeMsgId <*> getOpRFlags+  where+    makeHeader mid (oc,rc,fl) = PartialHeader mid oc rc fl+    decodeMsgId = get16++    getOpRFlags :: SGet (Opcode, PartialRCODE, PartialDNSFlags)+    getOpRFlags = do+        raw <- get16+        return $ ( extractOpcode raw+                 , extractRCODE  raw+                 , makeDNSFlags  raw+                 )+++type PartialRCODE = RCODE+type PartialDNSFlags = DNSFlags+++-- | Data type representing the absence or presence of+-- an OPT record, which individually represents the extended bits of+-- the DNS flags and RCODE contained in the EDNS pseudo-header+-- and the remaining EDNS data+data EDNSData = No+              | Yes { ext_fl :: Word16+                    , ext_rc :: Word8+                    , edns   :: EDNS+                    } deriving (Eq)++-- | Component of DNS message header that is extracted directly from+-- leading bytes of the DNS message (i.e. without parsing EDNS pseudo-header)+data PartialHeader = PartialHeader {+      p_dnsMsgId :: QueryID+    , p_dnsMsgOp :: Opcode+    , p_dnsMsgRC :: PartialRCODE+    , p_dnsMsgFl :: PartialDNSFlags+    } deriving (Eq, Show)++-- | Assemble a 'DNSMessage' from a 'PartialHeader' (the basic DNS+-- header bits decoded earlier in the parse) and a possibly-vacuous+-- 'EDNSData'.  The EDNS OPT pseudo-RR sits at the wire trailer+-- (in the additional section) but is logically header material,+-- contributing the upper bits of the extended 'RCODE' and the+-- extended flags.  The questions and the three RR sections+-- complete the message.+mkMsg :: PartialHeader+      -> EDNSData+      -> [DnsTriple]+      -> [RR] -> [RR] -> [RR]+      -> DNSMessage+mkMsg PartialHeader{..} No dnsMsgQu dnsMsgAn dnsMsgNs dnsMsgAr =+    DNSMessage {..}+  where+    dnsMsgId = p_dnsMsgId+    dnsMsgOp = p_dnsMsgOp+    dnsMsgRC = p_dnsMsgRC+    dnsMsgFl = p_dnsMsgFl+    dnsMsgEx = Nothing++mkMsg PartialHeader{..} Yes{..} dnsMsgQu dnsMsgAn dnsMsgNs dnsMsgAr =+    DNSMessage {..}+  where+    dnsMsgId = p_dnsMsgId+    dnsMsgOp = p_dnsMsgOp+    dnsMsgRC = extendRCODE p_dnsMsgRC ext_rc+    dnsMsgFl = extendFlags p_dnsMsgFl ext_fl+    dnsMsgEx = Just edns
+ internal/Net/DNSBase/Decode/Internal/Option.hs view
@@ -0,0 +1,86 @@+-- |+-- Module      : Net.DNSBase.Decode.Internal.Option+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Decode.Internal.Option+    ( OptionMap+    , T_opt(..)+    , emptyOptionMap+    , getOPTWith+    ) where++import qualified Data.IntMap.Strict as IM++import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.EDNS.Internal.Option+import Net.DNSBase.EDNS.Internal.Option.Opaque+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.RData+import Net.DNSBase.Internal.RRTYPE+import Net.DNSBase.Internal.Util++-- | [OPT RDATA](https://tools.ietf.org/html/rfc6891#section-6.1.2).+-- More precisely, just the EDNS option list of @OPT@ pseudo-RR.+-- The fixed fields are part of the 'Net.DNSBase.Message.DNSMessage' metadata.+--+-- Used only internally while decoding messages, not user-visible.+--+-- The variable part of an OPT RR may contain zero or more options in+-- the RDATA.  Each option MUST be treated as a bit field.  Each option+-- is encoded as:+--+-- > +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++-- > |                          OPTION-CODE                          |+-- > +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++-- > |                         OPTION-LENGTH                         |+-- > +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++-- > |                                                               |+-- > /                          OPTION-DATA                          /+-- > /                                                               /+-- > +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++--+-- Neither name compression nor canonical ordering are applicable here.+-- This datatype has no 'Ord' instance.+--+newtype T_opt = T_OPT [EdnsOption]+instance Eq  T_opt         where (==) = unreachable+instance Ord T_opt         where compare = unreachable+instance Presentable T_opt where present = unreachable+instance Show T_opt        where showsPrec = unreachable+instance KnownRData T_opt  where+    rdType _ = OPT+    rdEncode = unreachable+    rdDecode _ = unreachable++unreachable :: a+unreachable = errorWithoutStackTrace "Unreachable method of internal data type"++-- | Table of known EDNS option type codecs, paralleling+-- 'RDataMap' on the RR-type side.+type OptionMap = IM.IntMap OptionCodec++-- | Empty EDNS option codec map+emptyOptionMap :: OptionMap+emptyOptionMap = IM.empty++-- | Decoder for the @OPT@ pseudo-RR using a custom set of EDNS option+-- codecs.+--+getOPTWith :: OptionMap -- ^ OPTCODE->codec map+           -> Int       -- ^ OPT RData length+           -> SGet RData+getOPTWith optmap = RData . T_OPT <.> getOptions+  where+    getOptions :: Int -> SGet [EdnsOption]+    getOptions 0 = pure []+    getOptions rdlen = do+        code <- get16+        len  <- getInt16+        opt  <- case IM.lookup (fromIntegral code) optmap of+            Nothing -> opaqueEdnsOption code . coerce <$> getShortNByteString len+            Just (OptionCodec (_ :: Proxy a) opts) ->+                fitSGet len $ optDecode a opts len+        (opt :) <$> getOptions (rdlen - (len + 4))
+ internal/Net/DNSBase/Decode/Internal/RData.hs view
@@ -0,0 +1,104 @@+-- |+-- Module      : Net.DNSBase.Decode.Internal.RData+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Decode.Internal.RData+    ( getRData+    , getRR+    , fromOpaqueRData+    ) where++import qualified Data.IntMap as IM+import qualified Data.ByteString as B+import qualified Data.ByteString.Short as SB++import Net.DNSBase.Decode.Internal.Domain+import Net.DNSBase.Decode.Internal.Option+import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.Error+import Net.DNSBase.Internal.Nat16+import Net.DNSBase.Internal.RData+import Net.DNSBase.Internal.RR+import Net.DNSBase.Internal.RRCLASS+import Net.DNSBase.Internal.RRTYPE+import Net.DNSBase.Internal.Util+import Net.DNSBase.RData.Internal.XNAME+import Net.DNSBase.Resolver.Internal.Types++-- | Performs a lookup operation for the decoder associated with a given RRTYPE+-- (as 'Word16') against the provided 'RDataMap', and runs the appropriate+-- RData decoder (defaulting to 'OpaqueRData' on lookup miss) using the+-- provided length argument.+getRData :: RDataMap        -- ^ Known decoders+         -> Maybe OptionMap -- ^ Known EDNS option decoders+         -> Word16          -- ^ 'Net.DNSBase.RRTYPE.RRTYPE' to decode, as 'Word16'+         -> Int             -- ^ Length of RData in bytes (RDLENGTH)+         -> SGet RData+getRData _ (Just om) (RRTYPE -> OPT)   = getOPTWith om+getRData _ Nothing   t@(RRTYPE -> OPT) = opaqueDecoder t+getRData dm _ (dmLookup dm -> Just dc) = decodeWith dc+getRData _  _ t                        = opaqueDecoder t++decodeWith :: RDataCodec -> Int -> SGet RData+decodeWith (RDataCodec (_ :: proxy a) (opts :: RDataExtensionVal a)) =+    rdDecode a opts++-- | Decode unknown RRs as opaque data.  This includes unexpected OPT records+-- in the answer or authority sections.+opaqueDecoder :: Word16 -> Int -> SGet RData+opaqueDecoder rrtype = opaqueRData rrtype . coerce <.> getShortNByteString++-- | Convert 'RData' to its Known equivalent of the same RRtype+-- using the types known in the provided 'ResolvSeed'.  If the input+-- value is already non-opaque, or if there's no entry for the+-- 'Net.DNSBase.RRTYPE.RRTYPE' in the provided 'ResolvSeed', the+-- input will be returned as-is.+--+-- Otherwise, this will attempt to decode the opaque record without name+-- compression, the decode may fail, and an error reason returned instead.+--+fromOpaqueRData :: ResolvSeed -> RData -> Either DNSError RData+fromOpaqueRData ResolvSeed{..} rd@(rdataType -> t) = withNat16 (coerce t) go+  where+    go :: forall (n :: Nat) -> Nat16 n => Either DNSError RData+    go n | Just dc <- dmLookup seedRDataMap $ fromIntegral t+         , Just (OpaqueRData d :: OpaqueRData n) <- fromRData rd+         , bs <- SB.fromShort (coerce d)+         , len <- B.length bs+           = decodeAtWith 0 False (decodeWith dc len) bs+         | otherwise+           = Right rd++-- | Look up type-specific decoder.+dmLookup :: RDataMap -> Word16 -> Maybe RDataCodec+dmLookup dm typ = IM.lookup (fromIntegral typ) dm++-- | Decoder for a resource record, shares owner names of consecutive+-- RRs or names of CNAME targets with adjacent RRs for the target+-- (intervening RRSIGs for the CNAME don't reset the target).+getRR :: RDataMap -> Maybe OptionMap -> SGet RR+getRR dm om = do+    owner   <- getLastOwner+    cname   <- getLastCname+    rrOwner <- setLastOwner =<< dedup owner cname <$> getDomain+    typ     <- get16+    rrClass <- getRRCLASS+    local (setDecodeTriple (DnsTriple rrOwner (coerce typ) rrClass)) do+        rrTTL   <- get32+        len     <- getInt16+        rrData  <- fitSGet len $+                       if | typ == coerce CNAME ->+                            RData . T_CNAME <$> (setLastCname =<< getDomain)+                          | otherwise -> getRData dm om typ len+        return RR{..}+  where+    getRRCLASS = RRCLASS <$> get16+    dedup n1 n2 name | name == n1 = n1+                     | name == n2 = n2+                     | otherwise = name
+ internal/Net/DNSBase/Decode/Internal/State.hs view
@@ -0,0 +1,481 @@+-- |+-- Module      : Net.DNSBase.Decode.Internal.State+-- Description : Decoder state monad and wire-format primitives+-- Copyright   : (c) IIJ Innovation Institute Inc., 2009+--               (c) Viktor Dukhovni, 2020-2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Decode.Internal.State+    (+    -- * DNS message element parser+      SGet+    -- * Internal state accessors+    , getPosition+    , getPacket+    , getChrono+    , getNameComp+    -- ** Deduplication support+    , getLastOwner+    , getLastCname+    , setLastOwner+    , setLastCname+    -- ** Setting a non-default error context+    , setDecodeSection+    , setDecodeTriple+    , setDecodeSource+    , local+    -- * Generic low-level decoders+    , get8+    , get16+    , get32+    , get64+    , getInt8+    , getInt16+    -- * DNS-specific low-level decoders+    , getIPv4+    , getIPv4Net+    , getIPv6+    , getIPv6Net+    , getDnsTime+    -- * Octet-string decoders+    , skipNBytes+    , getNBytes+    , getShortByteString+    , getShortNByteString+    , getShortByteStringLen8+    , getShortByteStringLen16+    , getUtf8Text+    , getUtf8TextLen8+    , getUtf8TextLen16+    -- * Sequence decoders+    , getVarWidthSequence+    , getFixedWidthSequence+    -- * Decoder sandboxing+    , seekSGet+    , fitSGet+    -- * Decoder failure+    , failSGet+    -- * Decoder driver+    , decodeAtWith+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Short as SB+import qualified Data.ByteString.Unsafe as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.ByteString.Internal (ByteString(..))++import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.Error+import Net.DNSBase.Internal.Util++-----------++-- | The 'SGet' monad internal reader environment+data SGetEnv = SGetEnv+    { psPacket   :: ByteString+    , psChrono   :: Int64+    , psNameComp :: Bool+    , psSection  :: DnsSection+    , psTriple   :: Maybe DnsTriple+    , psSource   :: Maybe MessageSource+    }++-- | The 'SGet' monad internal state+data SGetState = SGetState+    { psOffset    :: Int+    , psLength    :: Int+    , psLastOwner :: Domain+    , psLastCname :: Domain+    }++-- | Abort the decoder with a 'DecodeError' carrying the given+-- diagnostic message and the current 'DecodeContext' (message+-- section, RR triple, and source address) drawn from the reader+-- environment.  Used by RR-data parsers when the wire bytes+-- don't conform to the expected shape.+failSGet :: String -> SGet a+failSGet msg = do+    SGetEnv { psSection = decodeSection+            , psTriple  = decodeTriple+            , psSource  = decodeSource } <- ask+    throw $ DecodeError DecodeContext {..} msg++-------------++-- | Consumes and returns a 'B.ByteString' of length @n@ from the buffer+--+-- Fails if this would back-track or over-run.+getNByteString :: Int -> SGet ByteString+getNByteString n | n == 0 = pure B.empty+getNByteString n | n > 0  = do+    s <- get+    when (psLength s < n) do failSGet "requested bytecount exceeds available"+    modify' \t -> t { psOffset = psOffset s + n+                    , psLength = psLength s - n}+    (BS fp _) <- asks psPacket+    pure $! BS (fp `plusForeignPtr` psOffset s) n+getNByteString _ = failSGet "negative bytecount requested"+{-# INLINE getNByteString #-}++-- | Consumes and discards @n@ bytes of input from the buffer+skipNBytes :: Int -> SGet ()+skipNBytes n | n >= 0 = do+    s <- get+    when (psLength s < n) do+        failSGet "requested skip bytecount exceeds available"+    when (n > 0) do+        modify' $ \t -> t { psOffset = psOffset s + n+                          , psLength = psLength s - n }+skipNBytes _ = failSGet "negative skip bytecount requested"+{-# INLINE skipNBytes #-}++-- | Returns the current position relative to the start of the internal buffer+getPosition :: SGet Int+getPosition = gets psOffset+{-# INLINE getPosition #-}++-- | Returns the entire contents of the internal buffer+getPacket :: SGet ByteString+getPacket = asks psPacket+{-# INLINE getPacket #-}++-- | Returns the epoch-relative time passed to 'decodeAtWith'+getChrono :: SGet Int64+getChrono = asks psChrono+{-# INLINE getChrono #-}++-- | Returns whether name (de)compression is applicable to the input buffer.+--+-- Generally true for full DNS messages, and false for data blobs encoded in+-- isolation.+getNameComp :: SGet Bool+getNameComp = asks psNameComp+{-# INLINE getNameComp #-}++getLastOwner, getLastCname :: SGet Domain+setLastOwner, setLastCname :: Domain -> SGet Domain+getLastOwner = gets psLastOwner+getLastCname = gets psLastCname+setLastOwner d = d <$ modify' \ s -> s { psLastOwner = d }+setLastCname d = d <$ modify' \ s -> s { psLastCname = d }+{-# INLINE getLastOwner #-}+{-# INLINE getLastCname #-}+{-# INLINE setLastOwner #-}+{-# INLINE setLastCname #-}++-- | Set message section for error reporting.+setDecodeSection :: DnsSection -> SGetEnv -> SGetEnv+setDecodeSection s env = env {psSection = s}++-- | Set current RRSet name, type, class for error reporting.+setDecodeTriple :: DnsTriple -> SGetEnv -> SGetEnv+setDecodeTriple t env = env {psTriple = Just t}++-- | Set message source for error reporting.+setDecodeSource :: MessageSource -> SGetEnv -> SGetEnv+setDecodeSource s env = env {psSource = Just s}++--------------------------------++-- | Consumes one octet and returns it as a 'Word8'+get8 :: SGet Word8+get8 = B.unsafeIndex <$> asks psPacket <*> (gets psOffset <* skipNBytes 1)+{-# INLINE get8 #-}++-- | Load a 16-bit big-endian word.+get16 :: SGet Word16+get16 = word16be <$> getNByteString 2+{-# INLINE get16 #-}++-- | Load a 32-bit big-endian word.+get32 :: SGet Word32+get32 = word32be <$> getNByteString 4+{-# INLINE get32 #-}++-- | Load a 64-bit big-endian word.+get64 :: SGet Word64+get64 = word64be <$> getNByteString 8+{-# INLINE get64 #-}++-- | Consumes one octet and returns it as an 'Int'+getInt8 :: SGet Int+getInt8 = fromIntegral <$> get8+{-# INLINE getInt8 #-}++-- | Consumes two octets and returns them as an 'Int'+-- computed using network byte order+getInt16 :: SGet Int+getInt16 = fromIntegral <$> get16+{-# INLINE getInt16 #-}++--  Not implemented, risks sign overflow on 32-bit systems.+--+--  -- | Consumes four octets and returns them as an 'Int'+--  -- computed using network byte order+--  getInt32 :: SGet Int+--  getInt32 = fromIntegral <$> get32+--  {-# INLINE getInt32 #-}++----++-- | Reads 4 octets and returns them as an 'IPv4' address+getIPv4 :: SGet IPv4+getIPv4 = toIPv4w <$> get32+{-# INLINE getIPv4 #-}++-- | Reads 16 octets and returns them as an 'IPv6' address+getIPv6 :: SGet IPv6+getIPv6 = toIPv6w <$> ((,,,) <$> get32 <*> get32 <*> get32 <*> get32)+{-# INLINE getIPv6 #-}++-- | Reads up to four octets and returns them as an 'IPv4'+-- address padded as needed with trailing 0x0 bytes.+getIPv4Net :: Int -> SGet IPv4+getIPv4Net n | n >= 0 && n <= 4 =+    getNByteString n >>= \ (BS fp _) -> pure $! unsafePerformFPIO fp \ptr -> do+        allocaBytesAligned 4 4 $ \buf -> do+            fillBytes buf 0 4+            copyBytes buf ptr n+            w <- toBE byteSwap32 <$> peek (castPtr buf)+            pure $ toIPv4w w+getIPv4Net _ = failSGet "invalid IPv4 prefix length"++-- | Reads up to 16 octets and returns them as an 'IPv6' address+-- padded as needed with trailing 0x0 bytes.+getIPv6Net :: Int -> SGet IPv6+getIPv6Net n | n >= 0 && n <= 16 =+    getNByteString n >>= \ (BS fp _) -> pure $! unsafePerformFPIO fp \ptr -> do+        allocaBytesAligned 16 4 $ \buf -> do+            fillBytes buf 0 16+            copyBytes buf ptr n+            w0 <- toBE byteSwap32 <$> peekElemOff (castPtr buf) 0+            w1 <- toBE byteSwap32 <$> peekElemOff (castPtr buf) 1+            w2 <- toBE byteSwap32 <$> peekElemOff (castPtr buf) 2+            w3 <- toBE byteSwap32 <$> peekElemOff (castPtr buf) 3+            pure $ toIPv6w (w0,w1,w2,w3)+getIPv6Net _ = failSGet "invalid IPv6 prefix length"++-- | Converts a 32-bit circle-arithmetic DNS time to an absolute 64-bit DNS+-- timestamp that lies within a 31-bit band of the parser state's reference+-- timestamp.+getDnsTime :: SGet Int64+getDnsTime = dnsTime <$> get32 <*> getChrono+  where+    dnsTime :: Word32 -- ^ DNS circle-arithmetic timestamp+            -> Int64  -- ^ reference epoch time+            -> Int64  -- ^ absolute DNS timestamp+    dnsTime tdns tnow =+        let delta = tdns - fromIntegral tnow+         in if delta > 0x7FFF_FFFF -- tdns is in the past?+               then tnow - (0x1_0000_0000 - fromIntegral delta)+               else tnow + fromIntegral delta+{-# INLINE getDnsTime #-}++----------------------------------------++-- | Consumes and returns @n@ bytes of input from the buffer.+getNBytes :: Int -> SGet [Word8]+getNBytes n = B.unpack <$> getNByteString n+{-# INLINE getNBytes #-}++-- | Decodes a sequence of values with a fixed wire-form byte-width.+getFixedWidthSequence :: Int    -- ^ Number of octets to encode one value+                      -> SGet a -- ^ Decoder for a single value+                      -> Int    -- ^ Total number of octets in the sequence+                      -> SGet [a]+getFixedWidthSequence wdth getOne len@((`quotRem` wdth) -> (cnt, 0)) =+  fitSGet len $ replicateM cnt getOne+getFixedWidthSequence _ _ _ =+  failSGet "sequence length not multiple of element size"+{-# INLINE getFixedWidthSequence #-}++-- | Decodes a sequence of values with a variable wire-form byte-width.+getVarWidthSequence :: SGet a   -- ^ Decoder for a single value+                    -> Int      -- ^ Total number of octets in the sequence+                    -> SGet [a]+getVarWidthSequence getOne = fitSGet <$> id <*> go+  where+    go n | n > 0 = do+      pos0 <- getPosition+      x    <- getOne+      used <- (subtract pos0) <$> getPosition+      (x : ) <$> go (n - used)+    go 0 = pure []+    go _ = failSGet "last sequence element read past limit"+{-# INLINE getVarWidthSequence #-}++-- | Consumes the rest of the buffer as 'SB.ShortByteString'.+getShortByteString :: SGet ShortByteString+getShortByteString = SB.toShort <$> (getNByteString =<< gets psLength)+{-# INLINE getShortByteString #-}++-- | Consumes and returns a 'SB.ShortByteString' of length @n@ from the buffer.+getShortNByteString :: Int -> SGet ShortByteString+getShortNByteString n = SB.toShort <$> getNByteString n+{-# INLINE getShortNByteString #-}++-- | Read a ShortByteString whose length is determined by an 8-bit prefix.+getShortByteStringLen8 :: SGet ShortByteString+getShortByteStringLen8 = getInt8 >>= getShortNByteString+{-# INLINE getShortByteStringLen8 #-}++-- | Read a ShortByteString whose length is determined by a 16-bit prefix.+getShortByteStringLen16 :: SGet ShortByteString+getShortByteStringLen16 = getInt16 >>= getShortNByteString+{-# INLINE getShortByteStringLen16 #-}++-- | Read a UTF8-encoded text string of the given length.+getUtf8Text :: Int -> SGet T.Text+getUtf8Text len = T.decodeUtf8' <$> getNByteString len >>= \ case+    Right txt -> pure txt+    Left  err -> failSGet $ show err+{-# INLINE getUtf8Text #-}++-- | Read a UTF8-encoded text string preceded by an explicit 8-bit length.+getUtf8TextLen8 :: SGet T.Text+getUtf8TextLen8 = getInt8 >>= T.decodeUtf8' <.> getNByteString >>= \ case+    Right txt -> pure txt+    Left  err -> failSGet $ show err+{-# INLINE getUtf8TextLen8 #-}++-- | Read a UTF8-encoded text string preceded by an explicit 16-bit length.+getUtf8TextLen16 :: SGet T.Text+getUtf8TextLen16 = getInt16 >>= T.decodeUtf8' <.> getNByteString >>= \ case+    Right txt -> pure txt+    Left  err -> failSGet $ show err+{-# INLINE getUtf8TextLen16 #-}++-- | Seek to a given offset and run a parser that can consume at+-- most the given number of bytes.  The caller's state remains+-- unchanged.  Used exclusively for decoding DNS message name+-- compression.+seekSGet :: Word16 -> SGet a -> SGet a+seekSGet pos parser = do+    let off = fromIntegral pos+    len <- B.length <$> getPacket+    when (off > len) do+        failSGet "seek attempt beyond end of buffer"+    env   <- ask+    state <- gets \ s -> s { psOffset = off+                           , psLength = len - off }+    case runSGet parser env state of+        Right (ret, _) -> pure ret+        Left err       -> throw err++-- | Runs a parser on an initial segment of the unread input.+-- Consumes exactly the specified number of bytes or fails.+fitSGet :: Int -> SGet a -> SGet a+fitSGet len parser | len >= 0 = do+    s <- get+    when (psLength s < len) do+        failSGet "requested skip bytecount exceeds available"+    when (len > 0) do+        modify' $ \t -> t { psOffset = psOffset s + len+                          , psLength = psLength s - len }+    env <- ask+    case runSGet parser env s { psLength = len } of+        Right (ret, t)+            | psLength t == 0 -> pure $! ret+            | otherwise       -> failSGet "element shorter than indicated size"+        Left err -> throw err+fitSGet _ _ = failSGet "negative sanbox buffer size"+{-# INLINE fitSGet #-}++--------------------------++-- | Run a decoder with a given epoch offset over specified input+decodeAtWith :: Int64       -- ^ Current absolute offset from epoch+             -> Bool        -- ^ Support name compression?+             -> SGet a      -- ^ Decoder to run+             -> ByteString  -- ^ Buffer to run decoder over+             -> Either DNSError a+decodeAtWith t nc parser inp =+    evalSGet parser SGetEnv{..} SGetState{..}+  where+    psPacket     = inp+    psChrono     = t+    psNameComp   = nc+    psSection    = DnsNonSection+    psTriple     = Nothing+    psSource     = Nothing+    psOffset     = 0+    psLength     = B.length inp+    psLastOwner  = RootDomain+    psLastCname  = RootDomain++--------------------------++-- | Minimal Reader + State + Except Monad.+newtype SGet a = SGet { runSGet :: SGetEnv -> SGetState -> Either DNSError (a, SGetState) }++evalSGet :: SGet a -> SGetEnv -> SGetState -> Either DNSError a+evalSGet m = \r s -> fst <$> runSGet m r s+{-# INLINE evalSGet #-}++instance Functor SGet where+    fmap f m = SGet $ \r s -> do+        (a, t) <- runSGet m r s+        pure (f a, t)+    {-# INLINE fmap #-}++instance Applicative SGet where+    pure a = SGet $ \_ s -> pure (a, s)+    {-# INLINE pure #-}+    mf <*> ma = SGet $ \r s -> do+        (f, t) <- runSGet mf r s+        (a, u) <- runSGet ma r t+        pure (f a, u)+    {-# INLINE (<*>) #-}+    liftA2 f ma mb = SGet $ \r s -> do+        (a, t) <- runSGet ma r s+        (b, u) <- runSGet mb r t+        pure (f a b, u)+    {-# INLINE liftA2 #-}+    ma *> mb = SGet $ \r s -> do+        (_, t) <- runSGet ma r s+        runSGet mb r t+    {-# INLINE (*>) #-}+    ma <* mb = SGet $ \r s -> do+        (a, t) <- runSGet ma r s+        (_, u) <- runSGet mb r t+        pure (a, u)+    {-# INLINE (<*) #-}++instance Monad SGet where+    ma >>= f = SGet $ \r s -> do+        (a, t) <- runSGet ma r s+        runSGet (f a) r t+    {-# INLINE (>>=) #-}++ask :: SGet SGetEnv+ask  = SGet $ \r s -> pure (r, s)+{-# INLINE ask #-}++asks :: (SGetEnv -> a) -> SGet a+asks f = SGet $ \r s -> pure (f r, s)+{-# INLINE asks #-}++get :: SGet SGetState+get = SGet $ \_ s -> pure (s, s)+{-# INLINE get #-}++gets :: (SGetState -> a) -> SGet a+gets f = SGet $ \_ s -> pure (f s, s)+{-# INLINE gets #-}++local :: (SGetEnv -> SGetEnv) -> SGet a -> SGet a+local f m = SGet $ \ r s -> runSGet m (f r) s+{-# INLINE local #-}++modify' :: (SGetState -> SGetState) -> SGet ()+modify' f = SGet $ \_ s -> let !t = f s in pure ((), t)+{-# INLINE modify' #-}++throw :: DNSError -> SGet a+throw e = SGet $ \_ _ -> Left e+{-# INLINE throw #-}
+ internal/Net/DNSBase/EDNS/Internal/OptNum.hs view
@@ -0,0 +1,118 @@+-- |+-- Module      : Net.DNSBase.EDNS.Internal.OptNum+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.EDNS.Internal.OptNum+    ( OptNum( ..+            , LLQ+            , UL+            , NSID+            , DAU+            , DHU+            , N3U+            , ECS+            , EXPIRE+            , COOKIE+            , TCPKEEPALIVE+            , PADDING+            , CHAIN+            , KEYTAG+            , EDE+            , CLIENTTAG+            , SERVERTAG+            )+    ) where++import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util++-- | EDNS Option Code (RFC 6891).+newtype OptNum = OptNum Word16+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++-- | [Long-lived queries](https://www.rfc-editor.org/rfc/rfc8764.html)+pattern LLQ             :: OptNum+pattern LLQ              = OptNum 1+-- | [Dynamic DNS Update Leases](https://datatracker.ietf.org/doc/html/draft-ietf-dnssd-update-lease-08#section-9)+pattern UL              :: OptNum+pattern UL               = OptNum 2+-- | [NSID](https://www.rfc-editor.org/rfc/rfc5001.html#section-4)+pattern NSID            :: OptNum+pattern NSID             = OptNum 3+-- | [DNSSEC Algorithm Understood](https://www.rfc-editor.org/rfc/rfc6975.html#section-8)+pattern DAU             :: OptNum+pattern DAU              = OptNum 5+-- | [DS Hash Understood](https://www.rfc-editor.org/rfc/rfc6975.html#section-8)+pattern DHU             :: OptNum+pattern DHU              = OptNum 6+-- | [NSEC3 Hash Understood](https://www.rfc-editor.org/rfc/rfc6975.html#section-8)+pattern N3U             :: OptNum+pattern N3U              = OptNum 7+-- | [Client Subnet](https://www.rfc-editor.org/rfc/rfc7871.html#section-8)+pattern ECS             :: OptNum+pattern ECS              = OptNum 8+-- | [Expire](https://www.rfc-editor.org/rfc/rfc7314.html#section-5)+pattern EXPIRE          :: OptNum+pattern EXPIRE           = OptNum 9+-- | [Cookie](https://www.rfc-editor.org/rfc/rfc7873.html#section-8)+pattern COOKIE          :: OptNum+pattern COOKIE           = OptNum 10+-- | [TCP Keepalive](https://www.rfc-editor.org/rfc/rfc7828.html#section-6)+pattern TCPKEEPALIVE    :: OptNum+pattern TCPKEEPALIVE     = OptNum 11+-- | [Padding](https://www.rfc-editor.org/rfc/rfc7830.html#section-5)+pattern PADDING         :: OptNum+pattern PADDING          = OptNum 12+-- | [DNSSEC Chain](https://www.rfc-editor.org/rfc/rfc7901.html#section-9)+pattern CHAIN           :: OptNum+pattern CHAIN            = OptNum 13+-- | [Key Tag](https://www.rfc-editor.org/rfc/rfc8145.html#section-6)+pattern KEYTAG          :: OptNum+pattern KEYTAG           = OptNum 14+-- | [EDNS Error](https://www.rfc-editor.org/rfc/rfc8914.html#section-5.1)+pattern EDE             :: OptNum+pattern EDE              = OptNum 15+-- | [Client Tag](https://datatracker.ietf.org/doc/html/draft-bellis-dnsop-edns-tags-01#section-7)+pattern CLIENTTAG       :: OptNum+pattern CLIENTTAG        = OptNum 16+-- | [Server Tag](https://datatracker.ietf.org/doc/html/draft-bellis-dnsop-edns-tags-01#section-7)+pattern SERVERTAG       :: OptNum+pattern SERVERTAG        = OptNum 17+-- | [Report Channel](https://datatracker.ietf.org/doc/html/rfc9567#section-7)+pattern REPORTCHAN      :: OptNum+pattern REPORTCHAN       = OptNum 18+-- | [Zone Version](https://datatracker.ietf.org/doc/html/rfc9660#section-6.1)+pattern ZONEVERSION     :: OptNum+pattern ZONEVERSION      = OptNum 19+-- | [MQTYPE Query](https://datatracker.ietf.org/doc/html/draft-ietf-dnssd-multi-qtypes-12#section-5)+pattern MQTQUERY        :: OptNum+pattern MQTQUERY         = OptNum 20+-- | [MQTYPE Response](https://datatracker.ietf.org/doc/html/draft-ietf-dnssd-multi-qtypes-12#section-5)+pattern MQTRESPONSE     :: OptNum+pattern MQTRESPONSE      = OptNum 21++instance Presentable OptNum where+    present LLQ          = present "LLQ"+    present UL           = present "UL"+    present NSID         = present "NSID"+    present DAU          = present "DAU"+    present DHU          = present "DHU"+    present N3U          = present "N3U"+    present ECS          = present "ECS"+    present EXPIRE       = present "EXPIRE"+    present COOKIE       = present "COOKIE"+    present TCPKEEPALIVE = present "TCPKEEPALIVE"+    present PADDING      = present "PADDING"+    present CHAIN        = present "CHAIN"+    present KEYTAG       = present "CHAIN"+    present EDE          = present "EDE"+    present CLIENTTAG    = present "CLIENTTAG"+    present SERVERTAG    = present "SERVERTAG"+    present REPORTCHAN   = present "REPORTCHAN"+    present ZONEVERSION  = present "ZONEVERSION"+    present MQTQUERY     = present "MQTQUERY"+    present MQTRESPONSE  = present "MQTRESPONSE"+    present oc           = present "OPTION" . present (coerce @_ @Word16 oc)
+ internal/Net/DNSBase/EDNS/Internal/Option.hs view
@@ -0,0 +1,186 @@+-- |+-- Module      : Net.DNSBase.EDNS.Internal.Option+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+module Net.DNSBase.EDNS.Internal.Option+    ( -- * EDNS option class+      KnownEdnsOption(..)+    , EdnsOption(..)+    , fromOption+    , monoOption+    , optionCode+    , putOption+    -- * EDNS option Controls+    , OptionCtl+    , optCtlSet+    , optCtlAdd+    , emptyOptionCtl+    , applyOptionCtl+    -- * Extensibility+    , OptionCodec(..)+    ) where++import Data.List (sortOn)++import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.EDNS.Internal.OptNum+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util++-- | EDNS option class with conversion to/from opaque 'EdnsOption' form.+class (Typeable a, Eq a, Show a, Presentable a) => KnownEdnsOption a where+    -- | The codec-consumed extension value for option type @a@.+    -- Defaults to @()@.  Options with a non-trivial extension+    -- (currently only 'Net.DNSBase.EDNS.Option.EDE.O_ede', whose extension carries the+    -- info-code name registry) supply their own associated-type+    -- definition.+    type OptionExtensionVal a :: Type+    type OptionExtensionVal a = ()++    -- | The library's built-in starting 'OptionExtensionVal' for option+    -- type @a@.  Used as the baseline when the library installs+    -- its built-in registration for @a@, and as the starting+    -- point when the user extends the codec for @a@.  For+    -- @'OptionExtensionVal' a ~ ()@ options the class default applies.+    optionExtensionVal :: forall b -> b ~ a => OptionExtensionVal a+    default optionExtensionVal :: (OptionExtensionVal a ~ ())+                               => forall b -> b ~ a+                               => OptionExtensionVal a+    optionExtensionVal _ = ()++    -- | The EDNS option number+    optNum     :: forall b -> b ~ a => OptNum++    -- | CPS option number presentation form builder.+    -- Most useful for new option values not yet known to the library.+    optPres    :: forall b -> b ~ a => Builder -> Builder++    -- | Encoder of option data to wire form+    optEncode  :: forall s r. (Typeable r, Eq r, Show r)+               => a -- ^ The value to encode+               -> SPut s r++    -- | Decoder from wire form+    optDecode  :: forall b+               -> b ~ a+               -- ^ The type to decode+               => OptionExtensionVal b+               -- ^ Its extension value+               -> Int+               -- ^ The encoded data length+               -> SGet EdnsOption++    optPres t = present $ optNum t+    {-# INLINE optPres #-}+++-- | Known EDNS option Proxy + 'OptionExtensionVal' pair, paralleling+-- 'Net.DNSBase.Internal.RData.RDataCodec' on the RR-type side.+data OptionCodec where+    OptionCodec :: KnownEdnsOption a+                => Proxy a+                -> OptionExtensionVal a+                -> OptionCodec++-- | Existentially quantified type-opaque 'KnownEdnsOption', with heterogeneous+-- equality.+data EdnsOption = forall a. KnownEdnsOption a => EdnsOption a++-- | Extract specific 'KnownEdnsOption' from existential wrapping+fromOption :: forall a. KnownEdnsOption a => EdnsOption -> Maybe a+fromOption (EdnsOption a) = cast a+{-# INLINE fromOption #-}++instance Show EdnsOption where+    showsPrec p (EdnsOption a)  = showsP p $+        showString "EdnsOption " . shows' a++instance Presentable EdnsOption where+    present (EdnsOption a)  = present a+    {-# INLINE present #-}++instance Eq EdnsOption where+    (EdnsOption (_a :: a)) == (EdnsOption (_b :: b)) =+        case teq a b of+            Just Refl -> _a == _b+            _         -> False++-- | The 16-bit 'Net.DNSBase.EDNS.OptNum.OptNum' codepoint of the option wrapped inside a+-- 'EdnsOption'.  Useful for filtering or grouping a heterogeneous+-- option list without unpacking each value.+optionCode :: EdnsOption -> OptNum+optionCode (EdnsOption (_ :: a)) = optNum a+{-# INLINE optionCode #-}++-- | Filter a 'Foldable' of 'EdnsOption' down to the values of a+-- single type @a@, dropping any entries whose option-code does+-- not match (or whose value is held under an 'Net.DNSBase.EDNS.Option.Opaque.OpaqueOption' even+-- though @a@ is registered for that code).  Use a type+-- application to select the target type, e.g. @'monoOption' \@'Net.DNSBase.EDNS.Option.EDE.O_ede'+-- ednsOptions@.+monoOption :: forall a t. (KnownEdnsOption a, Foldable t) => t EdnsOption -> [a]+monoOption = foldr (maybe id (:) . fromOption) []+{-# INLINE monoOption #-}++-- | Wire-form encoder for a 'EdnsOption': writes the 16-bit+-- option code followed by the length-prefixed value bytes+-- produced by the underlying 'optEncode' method.  Used by the+-- OPT pseudo-RR encoder to serialise each option in turn.+putOption :: forall s r. (Typeable r, Eq r, Show r)+          => EdnsOption -> SPut s r+putOption (EdnsOption (o :: a)) = do+    put16 $ coerce (optNum a)+    passLen (optEncode o)+{-# INLINE putOption #-}++--------++-- | The list of EDNS options carried in the OPT pseudo-RR of an+-- outgoing query.  Callers do not build an 'OptionCtl' directly;+-- they build an endomorphism @'OptionCtl' -> 'OptionCtl'@ out of+-- 'optCtlAdd' and 'optCtlSet' and pass it to the 'Net.DNSBase.Resolver.EdnsOptionCtl'+-- pattern of 'Net.DNSBase.Resolver.QueryControls'.  The endomorphism is applied to the+-- resolver's ambient option list at send time, so callers see the+-- final list as a delta on top of whatever the resolver already+-- had configured.+newtype OptionCtl = OptionCtl { fromOptionCtl :: [EdnsOption] }+    deriving (Eq, Show)++-- | Replace the option list outright with the supplied options.+-- Use this when the per-call configuration should override+-- anything the resolver had set; combine with 'optCtlAdd' for+-- partial overrides.+optCtlSet :: [EdnsOption] -> OptionCtl -> OptionCtl+optCtlSet opts _ = OptionCtl (sortOn optionCode opts)++-- | Add the supplied options to the existing list.  When the new+-- and old options share an @OPTCODE@, the new entries replace the+-- old ones with that code.+optCtlAdd :: [EdnsOption] -> OptionCtl -> OptionCtl+optCtlAdd opts (OptionCtl opts') = OptionCtl $ lbMerge (sortOn optionCode opts) opts'+  where+    -- left-biased merge that omits duplicate opcodes in the second argument only+    lbMerge [] ys = ys+    lbMerge xs [] = xs+    lbMerge xs@(x:xt) ys@(y:yt) =+        case compare (optionCode x) (optionCode y) of+            LT -> x : lbMerge xt ys+            GT -> y : lbMerge xs yt+            EQ -> lbMerge xs yt++-- | The empty option list.  Useful as the seed when running an+-- 'OptionCtl' endomorphism to inspect what it would produce.+emptyOptionCtl :: OptionCtl+emptyOptionCtl = OptionCtl []++-- | Apply an 'OptionCtl' endomorphism to a plain list of options.+-- Used by the resolver to fold per-call EDNS-option tweaks into+-- the option list it is about to put on the wire.+applyOptionCtl :: (OptionCtl -> OptionCtl) -> [EdnsOption] -> [EdnsOption]+applyOptionCtl f opts = fromOptionCtl $ f (OptionCtl opts)
+ internal/Net/DNSBase/EDNS/Internal/Option/Opaque.hs view
@@ -0,0 +1,51 @@+-- |+-- Module      : Net.DNSBase.EDNS.Internal.Option.Opaque+-- Description : Internal: fallback wrapper for unrecognised EDNS options+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.EDNS.Internal.Option.Opaque+    ( OpaqueOption(..)+    , opaqueEdnsOption+    )+    where++import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.EDNS.Internal.OptNum+import Net.DNSBase.EDNS.Internal.Option+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Internal.Bytes+import Net.DNSBase.Internal.Nat16+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util++-- | Unrecognized EDNS Option whose contents are treated as an opaque octet-string+-- and are left unparsed. The OPTION-CODE is encoded as a type-level natural, so+-- opaque options with different option code values are of different types.+type OpaqueOption :: Nat -> Type+data OpaqueOption n = OpaqueOption ShortByteString++deriving instance Eq (OpaqueOption n)++instance Nat16 n => Show (OpaqueOption n) where+    showsPrec p (OpaqueOption bs) = showsP p $+        showString "OpaqueOption @" . shows (natToWord16 n) . showChar ' '+        . shows @Bytes16 (coerce bs)++instance Presentable (OpaqueOption n) where+    present = \ (OpaqueOption bs) -> present @Bytes16 (coerce bs)++instance Nat16 n => KnownEdnsOption (OpaqueOption n) where+    optNum _ = OptNum $ natToWord16 n+    {-# INLINE optNum #-}+    optPres _ = present "OPT" . present (natToWord16 n)+    optEncode (OpaqueOption bs) = putShortByteString $ coerce bs+    optDecode _ _ = EdnsOption . OpaqueOption @n <.> getShortNByteString++-- | Create opaque option from its opcode and Bytes16 value+opaqueEdnsOption :: Word16 -> ShortByteString -> EdnsOption+opaqueEdnsOption w bs = withNat16 w go+  where+    go :: forall (n :: Nat) -> Nat16 n => EdnsOption+    go n = EdnsOption $ OpaqueOption @n bs
+ internal/Net/DNSBase/Encode/Internal/Metric.hs view
@@ -0,0 +1,178 @@+-- |+-- Module      : Net.DNSBase.Encode.Internal.Metric+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Encode.Internal.Metric+    ( SizedBuilder+    -- exported pattern+    , pattern SizedBuilder+    -- exported converters+    , mbErr+    , mbWord8+    , mbWord16+    , mbWord32+    , mbWord64+    , mbByteString+    , mbByteStringLen8+    , mbByteStringLen16+    , mbShortByteString+    , mbShortByteStringLen8+    , mbShortByteStringLen16+    , mbIPv4+    , mbIPv6+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Short as SB++import Net.DNSBase.Internal.Util++-- Auto-instantiated monoid that is coercible to and from SizedBuilder+-- and naturally specifies the proper semantics of each tuple element+type MonoMetricBuilder = (Sum Int, All, Builder)++-- | Monoidal wrapper over Builder monoid that internally records+-- the total length of the Builder output and maintains a flag+-- for post-hoc error checking+newtype SizedBuilder = SizedBuilder_ (Int, Bool, Builder)++instance Monoid SizedBuilder where+    mempty = coerce (mempty :: MonoMetricBuilder)++-- | The semigroup operation is strict in all the elements of the tuple.+instance Semigroup SizedBuilder where+    {-# INLINE (<>) #-}+    x<>y = _force $ _mono x <> _mono y++{-# INLINE _mono #-}+_mono :: SizedBuilder -> MonoMetricBuilder+_mono = coerce++{-# INLINE _force #-}+_force :: MonoMetricBuilder -> SizedBuilder+_force m = case coerce m of+    a@(StrictMB _ _ _) -> a++------------------ Pattern synonyms++pattern StrictMB :: Int -> Bool -> Builder -> SizedBuilder+pattern StrictMB n t b <- SizedBuilder_ (!n, !t, !b) where+  StrictMB !n !t !b = SizedBuilder_ (n, t, b)+{-# COMPLETE StrictMB #-}++-- Set sticky tag that the builder state is broken+pattern Invalid :: SizedBuilder+pattern Invalid <- SizedBuilder_ ( _, False, _) where+  Invalid = SizedBuilder_ (0, False, mempty)++pattern Valid :: Int -> Builder -> SizedBuilder+pattern Valid n b <- SizedBuilder_ (!n, True, b) where+  Valid !n b = SizedBuilder_ (n, True, b)+{-# COMPLETE Valid, Invalid #-}++-- | Extract length and builder when valid.+pattern SizedBuilder :: Int -> Builder -> SizedBuilder+pattern SizedBuilder n b <- SizedBuilder_ (!n, True, b)+{-# COMPLETE SizedBuilder, Invalid #-}++-- | SizedBuilder representing an unspecified error, probably+-- one of the inputs was too long.+mbErr :: SizedBuilder+mbErr = Invalid++-- internal constructors for fixed and variable -length values+_constlen ::       Int  -> (a -> Builder) -> a -> SizedBuilder+_varlen   :: (a -> Int) -> (a -> Builder) -> a -> SizedBuilder+_constlen !i !f = \x -> Valid i (f x)+_varlen   !l !f = \x -> Valid (l x) (f x)+{-# INLINE _constlen #-}+{-# INLINE _varlen #-}++-- | Encode an unsigned 8-bit number.+mbWord8 :: Word8 -> SizedBuilder+mbWord8 = _constlen 1 B.word8+{-# INLINE mbWord8 #-}++-- | Encode an unsigned 16-bit number in network byte order.+mbWord16 :: Word16 -> SizedBuilder+mbWord16 = _constlen 2 B.word16BE+{-# INLINE mbWord16 #-}++-- | Encode an unsigned 32-bit number in network byte order.+mbWord32 :: Word32 -> SizedBuilder+mbWord32 = _constlen 4 B.word32BE+{-# INLINE mbWord32 #-}++-- | Encode an unsigned 64-bit number in network byte order.+mbWord64 :: Word64 -> SizedBuilder+mbWord64 = _constlen 8 B.word64BE+{-# INLINE mbWord64 #-}++{-# INLINE mbInt8 #-}+{-# INLINE mbInt16 #-}+mbInt8, mbInt16 :: Int -> SizedBuilder+mbInt8  = _constlen 1 (B.int8    . fromIntegral)+mbInt16 = _constlen 2 (B.int16BE . fromIntegral)++-- | Encode a "ByteString" of up to approximately 65535 bytes.  In practice the+-- limit is smaller since the entire DNS packet has a 16-bit length limit.+mbByteString :: ByteString -> SizedBuilder+mbByteString b+    | !len <- B.length b+    , len <= 0xffff = Valid len (B.byteString b)+    | otherwise     = mbErr++-- | Encode a length-tagged "ByteString" of up to 255 bytes.+mbByteStringLen8 :: ByteString -> SizedBuilder+mbByteStringLen8 b+    | !len <- B.length b+    , len <= 0xff = mbInt8 len <> Valid len (B.byteString b)+    | otherwise   = mbErr++-- | Encode a length-tagged ByteString of up to approximately 65535 bytes.  In+-- practice the limit is smaller since the entire DNS packet has a 16-bit+-- length limit.+mbByteStringLen16 :: ByteString -> SizedBuilder+mbByteStringLen16 b+    | !len <- B.length b+    , len <= 0xffff = mbInt16 len <> Valid len (B.byteString b)+    | otherwise     = mbErr++-- | Encode a "ShortByteString" of up to approximately 65535 bytes.  In+-- practice the limit is smaller since the entire DNS packet has a 16-bit+-- length limit.+mbShortByteString :: ShortByteString -> SizedBuilder+mbShortByteString b+    | !len <- SB.length b+    , len <= 0xffff = Valid len (B.shortByteString b)+    | otherwise     = mbErr++-- | Encode a "ShortByteString" of up to 255 bytes, preceded by its length.+mbShortByteStringLen8 :: ShortByteString -> SizedBuilder+mbShortByteStringLen8 b+    | len <- SB.length b+    , l8 <- fromIntegral len+    , len <= 0xff = Valid (len + 1) (B.word8 l8 <> B.shortByteString b)+    | otherwise   = mbErr++-- | Encode a length-tagged ByteString of up to approximately 65535 bytes.  In+-- practice the limit is smaller since the entire DNS packet has a 16-bit+-- length limit.+mbShortByteStringLen16 :: ShortByteString -> SizedBuilder+mbShortByteStringLen16 b+    | len <- SB.length b+    , len <= 0xffff = mbInt16 len <> Valid len (B.shortByteString b)+    | otherwise     = mbErr++-- | Encode an IPv4 address+mbIPv4 :: IPv4 -> SizedBuilder+mbIPv4 = _constlen 4 (B.word32BE . fromIPv4w)++-- | Encode an IPv4 address+mbIPv6 :: IPv6 -> SizedBuilder+mbIPv6 = _constlen 16 \ (fromIPv6w -> (w1, w2, w3, w4)) ->+    B.word32BE w1 <> B.word32BE w2 <> B.word32BE w3 <> B.word32BE w4
+ internal/Net/DNSBase/Encode/Internal/State.hs view
@@ -0,0 +1,436 @@+-- |+-- Module      : Net.DNSBase.Encode.Internal.State+-- Description : Encoder state monad and wire-format primitives+-- Copyright   : (c) IIJ Innovation Institute Inc., 2009+--               (c) Viktor Dukhovni, 2020-2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}++module Net.DNSBase.Encode.Internal.State+    ( EncodeErr(..)+    , ErrorContext+    , SPut, SPutM, localSPut+    , buildCompressed+    , encodeCompressed+    , buildVerbatim+    , encodeVerbatim+    , putDomain+    , putWireForm+    , put8+    , put16+    , put32+    , put64+    , putIPv4+    , putIPv6+    , putByteString+    , putByteStringLen8+    , putByteStringLen16+    , putShortByteString+    , putShortByteStringLen8+    , putShortByteStringLen16+    , putUtf8Text+    , putUtf8TextLen8+    , putUtf8TextLen16+    , putSizedBuilder+    , putReplicate+    -- Encoder state mutation+    , passLen+    , failWith+    , setContext+    ) where++import qualified Control.Monad.Trans.RWS.CPS+        as R ( RWST, evalRWST, ask, get, gets, local+             , pass, put, tell )+import qualified Control.Monad.STE as STE+import qualified Control.Monad.STE.Internal as STE+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Extra as B+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Short as SB+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Unsafe as T+import GHC.ST as G (ST(..))++import qualified Net.DNSBase.Internal.NameComp as NC+import Net.DNSBase.Internal.Domain+import Net.DNSBase.Encode.Internal.Metric+import Net.DNSBase.Internal.Error+import Net.DNSBase.Internal.Util++----------------------------------------------------------------++stToSTE :: G.ST s a -> STE.STE e s a+stToSTE = coerce++----------------------------------------------------------------++-- | Encoder state, the NCTree (DNS name compression tree) is mutable in the ST+-- monad.+data EncState s = EncState+    { encOffset :: Int+    , encDoNC   :: Bool+    , encNCTree :: NC.NCTree s+    }++-- | Initial encoder state.+encInit :: Bool -- ^ If "True", DNS name compression is enabled+        -> STE.STE e s (EncState s)+encInit donamecomp = EncState 0 donamecomp <$> stToSTE (NC.empty 0)++----------------------------------------------------------------++type ErrorContext r = (Typeable r, Show r, Eq r)++buildSPut :: ErrorContext r+        => (forall s. SPut s r)+        -> Bool+        -> Either (EncodeErr (Maybe r)) (Int, Builder)+buildSPut m donc = STE.handleSTE id do+    st <- encInit donc+    evalSPutM (m >> gets encOffset) Nothing st++-- | Execute the composed 'Builder' endomorphisms to encode a packet of the+-- cumulative length.+runSPut :: ErrorContext r+        => (forall s. SPut s r)+        -> Bool+        -> Either (EncodeErr (Maybe r)) ByteString+runSPut m donc = do+    (len, builder) <- buildSPut m donc+    pure $ LB.toStrict+         $ B.toLazyByteStringWith (strat len) mempty builder+  where+    strat len = B.untrimmedStrategy len len++-- | Perform a stateful encoding with DNS name compression.  The initial error+-- context is "Nothing".  Specific values can be provided during the+-- computation by using 'localSPut'.+buildCompressed :: ErrorContext r+                => (forall s. SPut s r)+                -> Either (EncodeErr (Maybe r)) Builder+buildCompressed m = snd <$> buildSPut m True++-- | Perform a stateful encoding with DNS name compression.  The initial error+-- context is "Nothing".  Specific values can be provided during the+-- computation by using 'localSPut'.+encodeCompressed :: ErrorContext r+                 => (forall s. SPut s r)+                 -> Either (EncodeErr (Maybe r)) ByteString+encodeCompressed m = runSPut m True++-- | Perform a stateful encoding without DNS name compression.  The initial+-- error context is "Nothing".  Specific values can be provided during the+-- computation by using 'localSPut'.+buildVerbatim :: ErrorContext r+              => (forall s. SPut s r)+              -> Either (EncodeErr (Maybe r)) Builder+buildVerbatim m = snd <$> buildSPut m False++-- | Perform a stateful encoding without DNS name compression.  The initial+-- error context is "Nothing".  Specific values can be provided during the+-- computation by using 'localSPut'.+encodeVerbatim :: ErrorContext r+               => (forall s. SPut s r)+               -> Either (EncodeErr (Maybe r)) ByteString+encodeVerbatim m = runSPut m False++-- | Encode a domain with possible name compression if the entire name fits in+-- the first 16K of the output.+putDomain :: ErrorContext r => Domain -> SPut s r+putDomain domain = do+    EncState{..} <- get+    let !wlen = B.length (wireBytes domain) - 1+    if | wlen > 0 && encDoNC+       , !end <- encOffset + wlen+       , !ls <- revLabels domain+        -> do (!slen, !off) <- liftSPut . stToSTE $ NC.lookup ls encNCTree+              when (end <= MaxPtr) $+                  liftSPut . stToSTE $ NC.insert ls end encNCTree+              putCompressed domain wlen slen off+       | otherwise -> putWireForm domain+  where+    putCompressed !dom !dlen !slen !off+        | slen == 0 = putWireForm dom+        | otherwise = do+              when (slen < dlen) do+                  putByteString $ B.take (dlen - slen) $ wireBytes domain+              put16 $ toEnum $ (MaxPos - MaxPtr) + off++-- | Encode a domain name verbatim, without name compression.+putWireForm :: ErrorContext r => Domain -> SPut s r+putWireForm = encVar (SB.length . shortBytes) (B.shortByteString . shortBytes)+{-# INLINE putWireForm #-}++----------------------------------------------------------------++pattern MaxPos :: Int+pattern MaxPos = 0xffff++pattern MaxPtr :: Int+pattern MaxPtr = 0x3fff++{-# INLINE addPos #-}+addPos :: ErrorContext r => Int -> SPut s r+addPos n = do+    !s@EncState{ encOffset = pos } <- get+    let !pos' = pos + n+    when (n > MaxPos || pos' > MaxPos) do+        ask >>= liftSPut . STE.throwSTE . EncodeTooLong+    put $! s { encOffset = pos' }++{-# INLINE encFix #-}+encFix :: ErrorContext r => Int -> (a -> Builder) -> a -> SPut s r+encFix size enc a = addPos size >> tell (enc a)++{-# INLINE encVar #-}+encVar :: ErrorContext r => (a -> Int) -> (a -> Builder) -> a -> SPut s r+encVar getSize enc a = encFix (getSize a) enc a++----------------------------------------------------------------++-- | Write a single octet.+put8 :: ErrorContext r => Word8 -> SPut s r+put8 = encFix 1 B.word8+{-# INLINE put8 #-}++-- | Write a big-endian 16-bit word.+put16 :: ErrorContext r => Word16 -> SPut s r+put16 = encFix 2 B.word16BE+{-# INLINE put16 #-}++-- | Write a big-endian 32-bit word.+put32 :: ErrorContext r => Word32 -> SPut s r+put32 = encFix 4 B.word32BE+{-# INLINE put32 #-}++-- | Write a big-endian 64-bit word.+put64 :: ErrorContext r => Word64 -> SPut s r+put64 = encFix 8 B.word64BE+{-# INLINE put64 #-}++-- | Write the four octets of an IPv4 address in network order.+putIPv4 :: ErrorContext r => IPv4 -> SPut s r+putIPv4 = put32 . fromIPv4w+{-# INLINE putIPv4 #-}++-- | Write the sixteen octets of an IPv6 address in network order.+putIPv6 :: ErrorContext r => IPv6 -> SPut s r+putIPv6 ip6 =+    putSizedBuilder $! mbWord32 w0+                    <> mbWord32 w1+                    <> mbWord32 w2+                    <> mbWord32 w3+  where+    (w0, w1, w2, w3) = fromIPv6w ip6+{-# INLINE putIPv6 #-}++-- | Write the bytes of a 'ByteString' verbatim, with no length prefix.+putByteString :: ErrorContext r => ByteString -> SPut s r+putByteString b =+    unless (B.null b) $ encVar B.length B.byteString b++-- | Write the bytes of a 'ShortByteString' verbatim, with no length prefix.+putShortByteString :: ErrorContext r => ShortByteString -> SPut s r+putShortByteString b =+    unless (SB.null b) $ encVar SB.length B.shortByteString b++-- | Write a DNS /character-string/: an 8-bit length prefix followed+-- by the bytes.  Fails with 'EncodeTooLong' if the input exceeds 255 bytes.+putByteStringLen8 :: ErrorContext r => ByteString -> SPut s r+putByteStringLen8 bs@(B.length -> len) | len <= 0xff = do+    addPos (len + 1)+    tell $ B.word8 (iw8 len) <> B.byteString bs+putByteStringLen8 _ =+    failWith EncodeTooLong++-- | 'ShortByteString' counterpart of 'putByteStringLen8'.+putShortByteStringLen8 :: ErrorContext r => ShortByteString -> SPut s r+putShortByteStringLen8 bs@(SB.length -> len) | len <= 0xff = do+    addPos $ len + 1+    tell $ B.word8 (iw8 len) <> B.shortByteString bs+putShortByteStringLen8 _ = failWith EncodeTooLong++-- | Write a 16-bit-length-prefixed 'ByteString'.  Fails with+-- 'EncodeTooLong' if the input exceeds 65535 bytes.+putByteStringLen16 :: ErrorContext r => ByteString -> SPut s r+putByteStringLen16 bs@(B.length -> len) | len <= 0xffff = do+    addPos $ len + 2+    tell $ B.word16BE (iw16 len) <> B.byteString bs+putByteStringLen16 _ = failWith EncodeTooLong++-- | 'ShortByteString' counterpart of 'putByteStringLen16'.+putShortByteStringLen16 :: ErrorContext r => ShortByteString -> SPut s r+putShortByteStringLen16 bs@(SB.length -> len) | len <= 0xffff = do+    addPos $ len + 2+    tell $ B.word16BE (iw16 len) <> B.shortByteString bs+putShortByteStringLen16 _ = failWith EncodeTooLong++-- | Write the UTF-8 encoding of a 'Text' verbatim, with no+-- length prefix.+putUtf8Text :: ErrorContext r => Text -> SPut s r+putUtf8Text t =+    unless (T.null t) $ encVar T.lengthWord8 T.encodeUtf8Builder t++-- | Write a UTF-8-encoded 'Text' with an 8-bit length prefix+-- (length in /bytes/, not codepoints).  Fails with 'EncodeTooLong'+-- if the UTF-8 encoding exceeds 255 bytes.+putUtf8TextLen8 :: ErrorContext r => Text -> SPut s r+putUtf8TextLen8 t@(T.lengthWord8-> len) | len <= 0xff = do+    addPos $ len + 1+    tell $ B.word8 (iw8 len) <> T.encodeUtf8Builder t+putUtf8TextLen8 _ = failWith EncodeTooLong++-- | Write a UTF-8-encoded 'Text' with a 16-bit length prefix+-- (length in /bytes/).  Fails with 'EncodeTooLong' if the UTF-8+-- encoding exceeds 65535 bytes.+putUtf8TextLen16 :: ErrorContext r => Text -> SPut s r+putUtf8TextLen16 t@(T.lengthWord8-> len) | len <= 0xffff = do+    addPos $ len + 2+    tell $ B.word16BE (iw16 len) <> T.encodeUtf8Builder t+putUtf8TextLen16 _ = failWith EncodeTooLong++iw8 :: Int -> Word8+iw8 = fromIntegral+{-# INLINE iw8 #-}++iw16 :: Int -> Word16+iw16 = fromIntegral+{-# INLINE iw16 #-}++-- | Write @n@ copies of the byte @w@ (used for fixed-width+-- zero-padded fields).+putReplicate :: ErrorContext r => Word8 -> Word8 -> SPut s r+putReplicate n w =+    encFix (fromEnum n) B.lazyByteString $+        LB.replicate (fromIntegral n) w++-- | Write a length-tracked 'SizedBuilder' verbatim, advancing the+-- encoder offset by the builder's recorded length.  Fails with+-- 'EncodeTooLong' when the builder itself carries the overflow+-- sentinel.+putSizedBuilder :: ErrorContext r => SizedBuilder -> SPut s r+putSizedBuilder (SizedBuilder len b) = addPos len >> tell b+putSizedBuilder _                    = failWith EncodeTooLong+{-# INLINE putSizedBuilder #-}++------------------------------------------++-- | Wrap a writer with an outer 16-bit length prefix that is+-- computed automatically from the writer's output.  Used for+-- @RDLENGTH@ and the various length-prefixed sub-fields of RR+-- data (SVCB option values, EDNS option values, and so on).+passLen :: ErrorContext r => SPutM s r a -> SPutM s r a+passLen m = pass $ do+        pos <- addPos 2 >> gets encOffset+        x <- m+        len <- subtract pos <$> gets encOffset+        return (x, prependLen len)++prependLen :: Int -> B.Builder -> B.Builder+prependLen = mappend . B.word16BE . fromIntegral++-- | Abort the encoder with the given error, attaching the current+-- 'ErrorContext' from the reader environment.  Used by individual+-- writers when an out-of-range or otherwise invalid value cannot+-- be serialised.+failWith :: ErrorContext r => (forall a. ErrorContext a => a -> EncodeErr a) -> SPut s r+failWith f = ask >>= liftSPut . STE.throwSTE . f++-- | Run a sub-encoder with the given context value installed, so+-- that any 'failWith' inside reports its error against that+-- context.  Used to label sections of the encode (RR header, RR+-- data, EDNS option, ...) so that error messages identify which+-- field went wrong.+setContext :: ErrorContext r => r -> SPutM s r a -> SPutM s r a+setContext r = localSPut (const $ Just r)+{-# INLINE setContext #-}++----------------------------------------------------------------++type BaseM s r = STE.STE (EncodeErr (Maybe r)) s+type RWST s r = R.RWST (Maybe r) Builder (EncState s) (BaseM s r)++-- | Encode an output packet in the ST monad, with @r@ as an+-- optional error context (typically the RData being encoded, when+-- applicable).+type SPut s r = SPutM s r ()++-- | The underlying SPut monad+newtype SPutM s r a = SPutM { _unSPutM :: RWST s r a }++instance Functor (SPutM s r) where+    fmap :: forall a b. (a -> b) -> SPutM s r a -> SPutM s r b+    fmap = coerce (fmap :: (a -> b) -> RWST s r a -> RWST s r b)+    {-# INLINE fmap #-}++    (<$) :: forall a b. a -> SPutM s r b -> SPutM s r a+    (<$) = coerce ((<$) :: a -> RWST s r b -> RWST s r a)+    {-# INLINE (<$) #-}++instance Applicative (SPutM s r) where+    pure :: forall a. a -> SPutM s r a+    pure = coerce (pure :: a -> RWST s r a)+    {-# INLINE pure #-}++    liftA2 :: forall a b c. (a -> b -> c) -> SPutM s r a -> SPutM s r b -> SPutM s r c+    liftA2 = coerce (liftA2 :: (a -> b -> c) -> RWST s r a -> RWST s r b -> RWST s r c)+    {-# INLINE liftA2 #-}++    (<*>) :: forall a b. SPutM s r (a -> b) -> SPutM s r a -> SPutM s r b+    (<*>) = coerce ((<*>) :: RWST s r (a -> b) -> RWST s r a -> RWST s r b)+    {-# INLINE (<*>) #-}++    (*>) :: forall a b. SPutM s r a -> SPutM s r b -> SPutM s r b+    (*>) = coerce ((*>) :: RWST s r a -> RWST s r b -> RWST s r b)+    {-# INLINE (*>) #-}++    (<*) :: forall a b. SPutM s r a -> SPutM s r b -> SPutM s r a+    (<*) = coerce ((<*) :: RWST s r a -> RWST s r b -> RWST s r a)+    {-# INLINE (<*) #-}++instance Monad (SPutM s r) where+    (>>=) :: forall a b. SPutM s r a -> (a -> SPutM s r b) -> SPutM s r b+    (>>=) = coerce ((>>=) :: RWST s r a -> (a -> RWST s r b) -> RWST s r b)+    {-# INLINE (>>=) #-}++evalSPutM :: forall s r a. (forall t. SPutM t r a) -> (Maybe r) -> (EncState s) -> BaseM s r (a, Builder)+evalSPutM m = coerce (R.evalRWST (coerce m :: (forall t. RWST t r a)) :: Maybe r -> EncState s -> BaseM s r (a, Builder))+{-# INLINE evalSPutM #-}++liftSPut :: forall s r a. BaseM s r a -> SPutM s r a+liftSPut = coerce (lift :: BaseM s r a -> RWST s r a)++ask :: forall s r. SPutM s r (Maybe r)+ask = coerce (R.ask :: RWST s r (Maybe r))+{-# INLINE ask #-}++get :: forall s r. SPutM s r (EncState s)+get = coerce (R.get :: RWST s r (EncState s))+{-# INLINE get #-}++gets :: forall s r a. (EncState s -> a) -> SPutM s r a+gets = coerce (R.gets :: (EncState s -> a) -> RWST s r a)+{-# INLINE gets #-}++-- | Run the encoder with a modified context+localSPut :: forall s r a. (Maybe r -> Maybe r) -> SPutM s r a -> SPutM s r a+localSPut = coerce (R.local :: (Maybe r -> Maybe r) -> RWST s r a -> RWST s r a)+{-# INLINE localSPut #-}++pass :: forall s r a. SPutM s r (a, Builder -> Builder) -> SPutM s r a+pass = coerce (R.pass :: RWST s r (a, Builder -> Builder) -> RWST s r a)+{-# INLINE pass #-}++put :: forall s r. EncState s -> SPutM s r ()+put = coerce (R.put :: EncState s -> RWST s r ())+{-# INLINE put #-}++tell :: forall s r. Builder -> SPutM s r ()+tell = coerce (R.tell :: Builder -> RWST s r ())+{-# INLINE tell #-}
+ internal/Net/DNSBase/Internal/Bytes.hs view
@@ -0,0 +1,84 @@+-- |+-- Module      : Net.DNSBase.Internal.Bytes+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Internal.Bytes+    ( Bytes16(..)+    , Bytes32(..)+    , Bytes64(..)+    , ByteString+    , ShortByteString+    ) where++import qualified Data.Base16.Types as B16+import qualified Data.Base64.Types as B64+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Base32.Hex as B32+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Short as SB+import qualified Data.Text as T+import Data.String (IsString(..))++import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util++-- | ByteStrings with a hexadecimal presentation form+newtype Bytes16 = Bytes16 { getShort16 :: ShortByteString }+    deriving (Eq, Ord, Semigroup, Monoid) via ShortByteString+instance Presentable Bytes16 where+    present = (<>) . B.byteStringHex . fromShort16+instance Show Bytes16 where+    showsPrec _ = shows . B16.extractBase16 . B16.encodeBase16' . fromShort16+instance IsString Bytes16 where+    fromString s = case B16.decodeBase16Untyped $ BS.pack s of+        Right bs -> toShort16 bs+        Left err -> error $ T.unpack err+++-- | ByteStrings with a base32 presentation form+newtype Bytes32 = Bytes32 { getShort32 :: ShortByteString }+    deriving (Eq, Ord, Semigroup, Monoid) via ShortByteString+instance Presentable Bytes32 where+    present = present . B32.encodeBase32Unpadded' . fromShort32+instance Show Bytes32 where+    showsPrec _ = shows . B32.encodeBase32Unpadded' . fromShort32+instance IsString Bytes32 where+    fromString s = case B32.decodeBase32Unpadded $ BS.pack s of+        Right bs -> toShort32 bs+        Left err -> error $ T.unpack err+++-- | ByteStrings with a base64 presentation form+newtype Bytes64 = Bytes64 { getShort64 :: ShortByteString }+    deriving (Eq, Ord, Semigroup, Monoid) via ShortByteString+instance Presentable Bytes64 where+    present = present . B64.extractBase64 . B64.encodeBase64' . fromShort64+instance Show Bytes64 where+    showsPrec _ = shows . B64.extractBase64 . B64.encodeBase64' . fromShort64+instance IsString Bytes64 where+    fromString s = case B64.decodeBase64Untyped $ BS.pack s of+        Right bs -> toShort64 bs+        Left err -> error $ T.unpack err++fromShort16 :: Bytes16 -> ByteString+fromShort16 = SB.fromShort . coerce++fromShort32 :: Bytes32 -> ByteString+fromShort32 = SB.fromShort . coerce++fromShort64 :: Bytes64 -> ByteString+fromShort64 = SB.fromShort . coerce++toShort16 :: ByteString -> Bytes16+toShort16 = coerce . SB.toShort++toShort32 :: ByteString -> Bytes32+toShort32 = coerce . SB.toShort++toShort64 :: ByteString -> Bytes64+toShort64 = coerce . SB.toShort
+ internal/Net/DNSBase/Internal/Domain.hs view
@@ -0,0 +1,1049 @@+-- |+-- Module      : Net.DNSBase.Internal.Domain+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE+    DeriveLift+  , DerivingStrategies+  , RecordWildCards+  , TemplateHaskell+  #-}++module Net.DNSBase.Internal.Domain+    ( -- ** Domain name data type+      Domain(.., RootDomain)+    , DnsTriple(..)+    , Host+    , fromHost+    , toHost+    , Mbox+    , fromMbox+    , toMbox+    -- *** Canonicalisation to lower case+    , canonicalise+    -- *** Working with labels+    , appendDomain+    , consDomain+    , unconsDomain+    , fromLabels+    , labelCount+    , toLabels+    , revLabels+    , commonSuffix+    -- ** Validating import from wire form+    , wireToDomain+    -- ** Decode presentation form to Domain+    , decodePresentationDomain+    , decodePresentationMbox+    -- ** Compile-time literals+    , dnLit+    , mbLit+    -- ** Binary serialization functions+    , wireBytes+    , mbWireForm+    , buildDomain+    -- ** Predicates+    , isLDHLabel+    , isLDHName+    -- ** Sorting and comparison+    , compareWireHost+    , equalWireHost+    , canonicalNameOrder+    , sortDomains+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Extra as B+import qualified Data.ByteString.Short as SB+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Unsafe as B+import qualified Data.List as L+import qualified Data.Primitive.ByteArray as A+import qualified Data.Text as T+import qualified Data.Text.Array as TA+import qualified Data.Text.Internal as TI+import qualified Data.Text.Unsafe as T+import qualified Language.Haskell.TH.Syntax as TH+import Control.Monad.ST (ST, runST)+import Data.Bifunctor (first)+import Data.Foldable (foldlM)++import Net.DNSBase.Encode.Internal.Metric+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.RRCLASS+import Net.DNSBase.Internal.RRTYPE+import Net.DNSBase.Internal.Text+import Net.DNSBase.Internal.Util++---------------------------------------- Domain newtype++-- | This type holds the /wire form/ of fully-qualified DNS domain+-- names encoded as A-labels.+--+-- The encoding of valid domain names to /presentation form/ (the+-- 'Presentable' instance) performs any required escaping of+-- special characters to ensure lossless round-trip encoding and+-- decoding of valid DNS names, and compatibility with the+-- standard zone file format.  Valid names are not limited to the+-- letter-digit-hyphen (LDH) syntax of hostnames, all 8-bit+-- characters are allowed in DNS names, subject to the 63-byte+-- limit on /wire form/ label length and 255-byte limit on the+-- /wire form/ domain name (including the terminal empty label).+--+-- Equality and comparison are based on the wire-form and are+-- case-sensitive.  The 'Host' newtype implements case-insensitive+-- equality and comparison over the same wire-form bytes.  The+-- 'toHost' and 'fromHost' functions implement coercions between+-- the two types.+--+newtype Domain = Domain_+    {+    -- | The /wire form/ of a domain name, including the zero-valued+    -- length byte of the terminal empty label.+    shortBytes :: ShortByteString+    } deriving stock TH.Lift+      deriving newtype (Eq, Ord)+++-- | Coercible to/from a domain, but its presentation form is canonical (lower+-- case) and has no terminating @.@, unless this is the root domain.+--+-- Equality and order are on the wire form, but are case-insensitive.+newtype Host = Host ShortByteString++-- | Case-insensitive equality on the wire form.+instance Eq Host where+    a == b = fromHost a `equalWireHost` fromHost b++-- | Case-insensitive order on the wire form.+instance Ord Host where+    a `compare` b = fromHost a `compareWireHost` fromHost b++-- | Coerce a 'Domain' to a 'Host'.+toHost :: Domain -> Host;   toHost = coerce+-- | Coerce a 'Host' to a 'Domain'.+fromHost :: Host -> Domain; fromHost = coerce+++-- | Coercible to\/from a domain, but its presentation form uses the @\@@ sign+-- as the separator after the first label, and does not escape literal @.@+-- characters within the first label. The second and subsequent labels are+-- canonicalised to lower-case.  No terminating @.@ is appended unless this+-- is the root domain.+--+-- Equality and order are on the wire form, but are case-insensitive.+newtype Mbox = Mbox ShortByteString deriving (Eq, Ord) via Host++-- | Coerce a 'Domain' to an 'Mbox'.  This changes the presentation form+-- to one in which the first label is separated from the rest by an @\'\@\'@+-- character, and any dots in the first label remain unescaped. No period+-- is appended after the last label.  The same form can be parsed by:+--+-- * 'Net.DNSBase.Domain.mbLit8'+-- * 'Net.DNSBase.Domain.makeMbox8'+-- * 'Net.DNSBase.Domain.makeMbox8Str'+-- * 'mbLit'+-- * 'decodePresentationMbox'+--+-- provided the first label (localpart) uses only 7-bit ASCII characters.+-- Mailboxes with non-ASCII localparts (EAI addresses) must be valid UTF-8+-- and can only be parsed by 'decodePresentationMbox' or 'mbLit', but+-- the presentation form of 'Mbox' does escapes all non-ASCII bytes in+-- @\\DDD@ decimal form, and would be rejected by all the above parsers.+-- A UTF-8 presentation form that respects EAI addresses is not yet+-- available, and would probably want a new @EAIMbox@ data type.+--+toMbox :: Domain -> Mbox;   toMbox = coerce+-- | Coerce an 'Mbox' to a 'Domain'.+fromMbox :: Mbox -> Domain; fromMbox = coerce+++-- | An /RRSet/ is uniquely idenfified by a name, type, class triple.+data DnsTriple = DnsTriple {+    dnsTripleName  :: Domain+  , dnsTripleType  :: RRTYPE+  , dnsTripleClass :: RRCLASS+  } deriving (Eq, Show)++instance Presentable DnsTriple where+    present DnsTriple {..} =+        present dnsTripleName+        . presentSp dnsTripleClass+        . presentSp dnsTripleType+++-- | The internal representation of Domains is not exposed, so neither the the+-- wire form nor any labels except the last can be empty.  The total length+-- cannot exceed 255 and no label can be longer than 63 bytes.+impossible :: a+impossible = error "Impossible wire format domain"++rootDomain :: Domain+rootDomain = coerce $ SB.singleton 0++-- | The root 'Domain' (presentation form @.@).+pattern RootDomain :: Domain+pattern RootDomain <- Domain_ (SB.length -> 1) where+    RootDomain = rootDomain++-- | Return the wire form of a 'Domain' name as a 'ByteString'+wireBytes :: Domain -> ByteString+wireBytes = SB.fromShort . shortBytes++-- | Case-insensitive equality of domain names.+equalWireHost :: Domain -> Domain -> Bool+equalWireHost (Domain_ sa) (Domain_ sb)+    | lena /= lenb                                 = False+    | A.compareByteArrays arra 0 arrb 0 lena == EQ = True+    | otherwise                                    = go 0+  where+    lena = SB.length sa+    lenb = SB.length sb+    arra = sbsToByteArray sa+    arrb = sbsToByteArray sb++    go !off+        | off + 1 == lena = True+        | tolower wa /= tolower wb = False+        | otherwise = go $ off + 1+      where+        wa = A.indexByteArray arra off+        wb = A.indexByteArray arrb off++-- | Canonical name order:+-- <https://datatracker.ietf.org/doc/html/rfc4034#section-6.1>.  For sorting+-- lists of more than a few elements, it may be best to perform a /decorate/,+-- sort, /undecorate/ via 'sortDomains'.+--+canonicalNameOrder :: Domain -> Domain -> Ordering+canonicalNameOrder a b+    | a `equalWireHost` b = EQ+    | otherwise = compare (revLabels $ canonicalise a)+                          (revLabels $ canonicalise b)++-- | Case-insensitive comparison of the wire forms of domains.+compareWireHost :: Domain -> Domain -> Ordering+compareWireHost (Domain_ sa) (Domain_ sb) = go 0+  where+    lena = SB.length sa+    lenb = SB.length sb+    arra = sbsToByteArray sa+    arrb = sbsToByteArray sb++    go !off+        | off + 1 == lena = compare lena lenb+        | off + 1 == lenb = compare lena lenb+        | cmp /= EQ       = cmp+        | otherwise       = go $ off + 1+      where+        wa = A.indexByteArray arra off+        wb = A.indexByteArray arrb off+        cmp = compare (tolower wa) (tolower wb)++-- | Perform a /decorate/, sort, /undecorate/ sort to return a list of domains+-- in canonical order.+sortDomains :: [Domain] -> [Domain]+sortDomains = L.sortOn (revLabels . canonicalise)++-- | Conversion to /presentation form/ via a bytestring 'Builder'.+instance Presentable Domain where+    present = presentDomain+    -- | Executes the 'Domain' builder with sensibly short buffers.+    presentLazy d k = B.toLazyByteStringWith domainStrat k $ present d mempty++-- | Conversion to /presentation form/ via a bytestring 'Builder'.+instance Presentable Host where+    present = presentHost . coerce+    -- | Executes the 'Host' builder with sensibly short buffers.+    presentLazy h k = B.toLazyByteStringWith domainStrat k $ present h mempty++-- | Conversion to /presentation form/ via a bytestring 'Builder'.+instance Presentable Mbox where+    present = presentMbox . coerce+    -- | Executes the 'Mbox' builder with sensibly short buffers.+    presentLazy m k = B.toLazyByteStringWith domainStrat k $ present m mempty++-- | Shows the presentation form string, adding double quotes and additional+-- string escapes as needed.  To get the /raw/ string, use 'presentString'.+instance Show Domain where+    showsPrec p d = showsPrec p $ presentString d mempty++-- | Shows the presentation form string, adding double quotes and additional+-- string escapes as needed.  To get the /raw/ string, use 'presentString'.+instance Show Host where+    showsPrec p h = showsPrec p $ presentString h mempty++-- | Shows the presentation form string, adding double quotes and additional+-- string escapes as needed.  To get the /raw/ string, use 'presentString'.+instance Show Mbox where+    showsPrec p m = showsPrec p $ presentString m mempty++---------------------------------------- Wire-form assembly++-- | Execute a builder to produce a 'Domain'.  Used by the wire-form+-- decoder to turn the @\<prefix\>\<suffix\>@ Builder produced by+-- pointer-following into a 'Domain'; the presentation-form parsers+-- live in "Net.DNSBase.Domain" and write directly into a fresh+-- 'A.MutableByteArray' rather than going via Builder.+buildDomain :: Maybe B.Builder -> Maybe Domain+buildDomain mb = mb >>= \b -> do+    let buf = LB.toStrict $ B.toLazyByteStringWith domainStrat mempty b+    guard $ B.length buf < 256+    pure $! Domain_ $ SB.toShort buf++---------------------------------------- Conversions+++-- | Given two 'Domain's attempt to construct a new new domain consisting+-- of the labels of the first, followed by the labels of the second.  Fails+-- (returns 'Nothing') if the result would be too long.+--+appendDomain :: Domain -> Domain -> Maybe Domain+appendDomain p@(subtract 1 . coerce SB.length -> plen)+             s@(coerce SB.length -> slen)+    | plen == 0 = Just s+    | slen == 1 = Just p+    | len <- plen + slen+    , len < 256 = Just $! Domain_ $ combine len+    | otherwise = Nothing+  where+    combine len = baToShortByteString $ A.runByteArray do+        mba <- A.newByteArray len+        A.copyByteArray mba 0 (sbsToByteArray $ shortBytes p) 0 plen+        A.copyByteArray mba plen (sbsToByteArray $ shortBytes s) 0 slen+        pure mba+++-- | Canonicalise a 'Domain' to lower-case form.+canonicalise :: Domain -> Domain+canonicalise domain@(shortBytes -> bytes)+    | SB.any isupper bytes = Domain_ $ SB.map tolower bytes+    | otherwise = domain+++-- | Attempt to prepend the given label to the given domain, provided the label+-- length is 63 bytes or less, and the resulting domain is not too long.+--+consDomain :: ShortByteString -> Domain -> Maybe Domain+consDomain label@(SB.length -> llen)  suffix@(coerce SB.length -> slen) = do+    let len = llen + 1 + slen+    guard $ llen > 0 && llen <= 63 && len < 256+    pure $! Domain_ $ combine len+  where+    combine len = baToShortByteString $ A.runByteArray do+        mba <- A.newByteArray len+        A.writeByteArray mba 0 (i2w llen)+        A.copyByteArray mba 1 (sbsToByteArray label) 0 llen+        A.copyByteArray mba (llen+1) (sbsToByteArray $ shortBytes suffix) 0 slen+        pure mba+++-- | Given a 'Domain', return a tuple containing its first unescaped label as a+-- 'ShortByteString' and the remainder of the 'Domain' after removing the first+-- label.  Returns 'Nothing' for the root domain.+--+unconsDomain :: Domain -> Maybe (ShortByteString, Domain)+unconsDomain (Domain_ sbs)+    | len > 1   = Just (label, Domain_ suffix)+    | otherwise = Nothing+  where+    len     = SB.length sbs+    ba      = sbsToByteArray sbs+    llen    = w2i $ A.indexByteArray ba 0+    slen    = len - llen - 1+    !label  = baToShortByteString $ A.cloneByteArray ba 1 llen+    !suffix = baToShortByteString $ A.cloneByteArray ba (llen + 1) slen+++-- | Given a constituent list of raw unescaped labels, construct the+-- corresponding /wire form/ domain name. No label may be empty or longer than+-- 63 bytes, and the number of labels + the sum of label lengths must not+-- exceed 254.  The return value is 'Nothing' if the length constraints are+-- violated.+--+-- prop> fromLabels (toLabels dn) == Just dn+fromLabels :: [ShortByteString] -> Maybe Domain+fromLabels ls = do+    len <- foldlM space 1 ls+    pure $! Domain_ $ combine len+  where+    space :: Int -> ShortByteString -> Maybe Int+    space acc (SB.length -> len)+        | len > 0 && len < 64+        , new <- acc + len + 1+        , new < 256 = Just new+        | otherwise = Nothing++    combine len = baToShortByteString $ A.runByteArray do+        mba <- A.newByteArray len+        go mba 0 ls++    go mba off (l : rest) = do+        let !llen = SB.length l+        A.writeByteArray mba off $ i2w llen+        A.copyByteArray mba (off+1) (sbsToByteArray l) 0 llen+        go mba (off + llen + 1) rest+    go mba off _ = mba <$ A.writeByteArray @Word8 mba off 0+++-- | Validating import of a wire-form 'ShortByteString' as a+-- 'Domain'.  Returns 'Just' iff the bytes are a well-formed DNS+-- domain on the wire:+--+--   * total length in @1..255@,+--   * every label length byte in @1..63@ except the trailing+--     zero-byte root label,+--   * label boundaries align exactly with the buffer end -- i.e.+--     the terminating empty label's NUL length-byte is the last+--     byte, and there is no truncation or trailing garbage.+--+-- Suitable for receiving bytes the caller cannot prove+-- well-formed (e.g. labels handed back by a foreign library or+-- another package).  Wire-form bytes that come straight from the+-- decoder in "Net.DNSBase.Decode.Domain" are already validated and+-- do not need to round-trip through this check.+wireToDomain :: ShortByteString -> Maybe Domain+wireToDomain sbs+    | total >= 1, total <= 255, walk 0 = Just (Domain_ sbs)+    | otherwise                        = Nothing+  where+    !arr   = sbsToByteArray sbs+    !total = SB.length sbs++    walk :: Int -> Bool+    walk !off+        | off >= total = False    -- ran off end without hitting root NUL+        | otherwise =+            let !lb = w2i (A.indexByteArray arr off :: Word8)+            in if lb == 0+                 then off + 1 == total              -- root NUL is the last byte+                 else lb <= 63 && off + 1 + lb < total+                                && walk (off + 1 + lb)+++-- | Template-Haskell typed splice for a compile-time 'Domain'+-- literal.  The caller supplies a parser of type+-- @'Text' -> 'Either' e 'ShortByteString'@; @dnLit@ packs the+-- source 'String' literal as 'Text', runs the parser at compile+-- time, additionally checks the bytes via 'wireToDomain', and+-- embeds the resulting 'Domain' as a constant.  An invalid literal+-- (parser failure /or/ wire-shape failure) becomes a compile-time+-- error.+--+-- The @dnsbase@ library deliberately does not bundle a domain+-- parser; users compose a parser of their choice and pass it in.+-- The natural source of validating parsers is the @idna2008@+-- package, whose parsers already operate on 'Text'.+-- Template-Haskell staging forbids referring to a same-module+-- top-level binding from inside the splice, so the parser must+-- either be defined in an /imported/ module or bound by a @let@+-- /inside/ the splice; for a single-call site the latter is the+-- more compact form:+--+-- > import qualified Text.IDNA2008 as I+-- >+-- > example :: Domain+-- > example = $$(let parser = fmap I.wireBytesShort . I.mkDomain+-- >               in dnLit parser "www.example.org")+--+-- @mkDomain@ runs strict IDNA2008 with default label forms and+-- no mappings, returning just the validated @idna2008@ library\'s+-- 'Domain' object.  The @I.wireBytesShort@ function extracts the+-- wire form bytes needed by 'dnLit'.+--+-- For looser policies (mappings, emoji domain tolerance, etc.) use+-- @parseDomainOpt@ with an explicit @LabelFormSet@ and @IDNAOpts@,+-- and discard the @LabelInfo@ half of its result.+--+-- Hoisting the parser into a separate module avoids retyping the+-- composition at every literal:+--+-- > -- in MyDomainParsers.hs+-- > strictParser :: Text -> Either I.IdnaError ShortByteString+-- > strictParser = fmap I.wireBytesShort . I.mkDomain+-- >+-- > -- in any module that imports MyDomainParsers+-- > example :: Domain+-- > example = $$(dnLit strictParser "www.example.org")+--+-- The source literal is converted to 'Text' before the parser is+-- invoked; literals whose UTF-8 byte length exceeds 1024 are+-- rejected as invalid without consulting the parser.  The emitted+-- splice is a constant 'Domain' value (the wire-form+-- 'ShortByteString' is materialised once from its compile-time+-- @Addr#@ literal on first evaluation); the splice itself runs no+-- runtime IDNA code, and the caller's binary carries no+-- @idna2008@ dependency unless the user imports it themselves.+--+dnLit :: forall e m. (Show e, MonadFail m, TH.Quote m)+      => (Text -> Either e ShortByteString) -- ^ Parser+      -> String -- ^ Input literal (source code shape)+      -> TH.Code m Domain+dnLit parse s = TH.joinCode case packBounded mboxPresentationMaxBytes s of+    Nothing -> fail $ "Invalid literal domain " ++ show s+                   ++ ": presentation form longer than "+                   ++ show mboxPresentationMaxBytes ++ " bytes"+    Just t  -> case parse t of+        Left why -> fail $ "Invalid literal domain " ++ show s+                        ++ ": " ++ show why+        Right bs -> case wireToDomain bs of+            Just dn -> pure (TH.liftTyped dn)+            Nothing -> fail $ "Invalid domain: " ++ show s++----------------------------------------------------------------------+-- Decode a presentation-form domain+----------------------------------------------------------------------++-- | Decode a domain in presentation form.  The caller supplies the+-- parser; this entry point validates the parser's output as a+-- wire-form 'ShortByteString' that 'wireToDomain' accepts.+--+-- When the parser returns an error @e@, the return value is+-- @Left (Just e)@.  If a buggy parser produces an invalid wire+-- form, the return value is @Left Nothing@.+decodePresentationDomain+    :: forall e+    .  (Text -> Either e ShortByteString) -- ^ Parser+    -> Text                               -- ^ Input to be parsed+    -> Either (Maybe e) Domain+decodePresentationDomain parser t = case parser t of+    Right bs -> maybe (Left Nothing) Right $ wireToDomain bs+    Left why -> Left $ Just why++----------------------------------------------------------------------+-- Decode a presentation-form mbox+----------------------------------------------------------------------++-- | Parse a presentation-form mailbox into a 'Domain'.+--+-- The input is split at the first unescaped @\'\@\'@ if any;+-- otherwise at the first unescaped @\'.\'@; otherwise the entire+-- input is the localpart and the resulting 'Domain' has a single+-- non-root label.  A separator present but followed by empty+-- domain text (e.g. @\"postmaster\@\"@ or @\"postmaster.\"@) is+-- treated the same way as if the separator were absent: the+-- localpart is one label, the domain part is the root domain.+--+-- Following EAI semantics (RFC 6532), the localpart's wire bytes+-- are either pure 7-bit ASCII or a well-formed UTF-8 sequence.+-- The localpart decoder:+--+--   * Copies unescaped 'Text' bytes verbatim into the wire form.+--     A 'Text' is already valid UTF-8, so the bytes for one+--     codepoint are 1, 2, 3 or 4 bytes long depending on the+--     codepoint; no decoding or validation is needed.+--   * @\\DDD@ (three ASCII decimal digits, @0..127@) emits the+--     single ASCII byte with that value.  Values @>= 128@ are+--     rejected.+--   * @\\X@ (any other single character) emits @X@ as a single+--     ASCII byte; @X@'s codepoint must be @< 0x80@.+--+-- The rules above apply only to the /localpart/ -- the first+-- label of the mailbox name.  The post-separator 'Text' (if any)+-- is handed verbatim to the caller-supplied domain parser, which+-- decodes any remaining labels.+--+-- The parser's output is validated to be a wire-form+-- 'ShortByteString' that 'wireToDomain' accepts.  If length+-- limits permit, the decoded localpart is prepended to form the+-- combined 'Domain'.+--+-- When the parser returns an error @e@, the return value is+-- @Left (Just e)@.  If a buggy parser produces an invalid wire+-- form, the return value is @Left Nothing@.+decodePresentationMbox+    :: forall e+    .  (Text -> Either e ShortByteString) -- ^ Parser+    -> Text                               -- ^ Input to be parsed+    -> Either (Maybe e) Domain+decodePresentationMbox parseDom t = do+    (lpBytes, rest) <- maybe (Left Nothing) pure $ runST (decodeLocalpart t)+    if SB.length lpBytes > 63+        then Left Nothing+        else do+            !domWire <- if T.null rest+                            then Right rootWire+                            else first Just (parseDom rest)+            let !combined = lpBytes <> domWire+            maybe (Left Nothing) Right $ wireToDomain combined+  where+    !rootWire = SB.singleton 0++----------------------------------------------------------------------+-- Localpart byte walker+----------------------------------------------------------------------++-- | Snapshot of the buffer position when the optimistic @\'\@\'@-mode+-- walker passes an unescaped @\'.\'@.  If the walker reaches+-- end-of-input without seeing an unescaped @\'\@\'@ the snapshot+-- becomes the chosen separator and the localpart is truncated to+-- the bytes that came before the dot.+data DotSnap+    = NoDot+    | DotAt {-# UNPACK #-} !Int  -- ^ buffer position at the dot+            {-# UNPACK #-} !Int  -- ^ source-array offset after the dot++-- | Decode the localpart of a presentation-form mailbox.  Returns+-- the length-prefixed wire-form bytes for the localpart's label+-- (one length byte plus the content bytes) together with the+-- unconsumed remainder of the input (the slice of 'Text' after+-- the separator, or empty if no separator was found).+--+-- 'Nothing' indicates a malformed localpart (bad escape, length+-- overflow, raw @>= 128@ byte from a literal escape).+--+-- The walker chooses the separator by cheap presence-scanning the+-- first 256 bytes of the input for an @\'\@\'@ byte (0x40, which+-- can't appear inside a UTF-8 continuation sequence).  Finding+-- one switches the walker to @\'\@\'@-optimistic mode with a+-- @\'.\'@-snapshot fallback; otherwise the walker uses+-- @\'.\'@-only mode.  The 256-byte window is enough: the largest+-- valid localpart presentation form (63 wire bytes, each encoded+-- as @\\DDD@) fits in 252 bytes plus one for the @\'\@\'@.+decodeLocalpart :: forall s. Text -> ST s (Maybe (ShortByteString, Text))+decodeLocalpart (TI.Text src srcOff srcLen) = do+    buf <- A.newByteArray 64+    A.writeByteArray buf 0 (0 :: Word8)+    if firstAtIn srcOff (min 256 srcLen) src+        then loopAt buf 1 NoDot srcOff+        else loopDot buf 1 srcOff+  where+    !srcEnd = srcOff + srcLen++    -- @\'\@\'@-optimistic walker.  Records the position of the first+    -- unescaped @\'.\'@ as a fallback in case every @\'\@\'@ is escaped.+    loopAt :: A.MutableByteArray s -> Int -> DotSnap -> Int+           -> ST s (Maybe (ShortByteString, Text))+    loopAt buf !bufPos !snap !i+      | i >= srcEnd = case snap of+            NoDot              -> finalise buf bufPos srcEnd+            DotAt dp dskip     -> finalise buf dp dskip+      | otherwise = case TA.unsafeIndex src i of+            0x40  {- '@' -}  -> finalise buf bufPos (i + 1)+            0x5C  {- '\\' -} -> case decodeEscape src (i + 1) srcEnd of+                Nothing      -> pure Nothing+                Just (b, i') -> putByte buf bufPos b+                                  (loopAt buf (bufPos + 1) snap i')+            0x2E  {- '.' -}  ->+                let !snap' = case snap of+                        NoDot -> DotAt bufPos (i + 1)+                        _     -> snap+                in putByte buf bufPos 0x2E+                     (loopAt buf (bufPos + 1) snap' (i + 1))+            c | c < 0x80     -> putByte buf bufPos c+                                  (loopAt buf (bufPos + 1) snap (i + 1))+              | otherwise    -> copyUtf8 buf bufPos i c $ \bufPos' i' ->+                                  loopAt buf bufPos' snap i'++    -- @\'.\'@-only walker (no @\'\@\'@ in the first 256 bytes of input).+    loopDot :: A.MutableByteArray s -> Int -> Int+            -> ST s (Maybe (ShortByteString, Text))+    loopDot buf !bufPos !i+      | i >= srcEnd = finalise buf bufPos srcEnd+      | otherwise = case TA.unsafeIndex src i of+            0x2E  {- '.' -}  -> finalise buf bufPos (i + 1)+            0x5C  {- '\\' -} -> case decodeEscape src (i + 1) srcEnd of+                Nothing      -> pure Nothing+                Just (b, i') -> putByte buf bufPos b+                                  (loopDot buf (bufPos + 1) i')+            c | c < 0x80     -> putByte buf bufPos c+                                  (loopDot buf (bufPos + 1) (i + 1))+              | otherwise    -> copyUtf8 buf bufPos i c $ \bufPos' i' ->+                                  loopDot buf bufPos' i'++    -- Write a single byte at 'bufPos' and continue with @k@.+    -- Rejects writes past the 64-byte buffer (slots 0..63).+    putByte :: A.MutableByteArray s -> Int -> Word8+            -> ST s (Maybe a) -> ST s (Maybe a)+    putByte buf !bufPos !b k+      | bufPos > 63 = pure Nothing+      | otherwise   = do A.writeByteArray buf bufPos b+                         k++    -- Copy a UTF-8 multi-byte sequence (width determined by the+    -- lead byte) from 'src' at offset @i@ into 'buf' at @bufPos@.+    -- The 'Text' input is well-formed UTF-8, so no decoding or+    -- validation is needed: just byte-copy the continuation bytes.+    copyUtf8 :: A.MutableByteArray s -> Int -> Int -> Word8+             -> (Int -> Int -> ST s (Maybe a)) -> ST s (Maybe a)+    copyUtf8 buf !bufPos !i !lead k+      | bufPos + width > 64 = pure Nothing+      | otherwise = do+          A.writeByteArray @Word8 buf bufPos lead+          copyTrailing 1+          k (bufPos + width) (i + width)+      where+        !width+          | lead < 0xC0 = 1  -- never hit for well-formed Text+          | lead < 0xE0 = 2+          | lead < 0xF0 = 3+          | otherwise   = 4+        copyTrailing !j+          | j >= width = pure ()+          | otherwise  = do+              A.writeByteArray buf (bufPos + j)+                  (TA.unsafeIndex src (i + j))+              copyTrailing (j + 1)++    -- Stamp the length byte at slot 0, copy the used prefix into+    -- a 'ShortByteString', and slice the remaining input.+    finalise :: A.MutableByteArray s -> Int -> Int+             -> ST s (Maybe (ShortByteString, Text))+    finalise buf !bufPos !restOff = do+        let !contentLen = bufPos - 1+        A.writeByteArray buf 0 (fromIntegral contentLen :: Word8)+        let collect !i !acc+              | i < 0     = pure acc+              | otherwise = do+                  b <- A.readByteArray buf i+                  collect (i - 1) (b : acc)+        bytes <- collect (bufPos - 1) []+        let !sbs  = SB.pack (bytes :: [Word8])+            !rest = TI.Text src restOff (srcEnd - restOff)+        pure $ Just (sbs, rest)++-- | True if a @\'\@\'@ byte (0x40) appears anywhere in+-- @arr[off..off+lim-1]@.  Used as a cheap presence test before+-- choosing the localpart walker's separator policy.  An @\'\@\'@+-- is ASCII and so cannot appear inside a UTF-8 multi-byte+-- sequence, so a plain byte scan reliably finds every literal+-- occurrence in the input (escaped ones are also matched, but+-- the walker will reject them and fall back to the+-- @\'.\'@-snapshot).+firstAtIn :: Int -> Int -> TA.Array -> Bool+firstAtIn !off !lim arr = go off+  where+    !end = off + lim+    go !i+      | i >= end                        = False+      | TA.unsafeIndex arr i == 0x40    = True+      | otherwise                       = go (i + 1)++-- | Decode a @\\@-escape starting at @arr[off]@ (the byte+-- /after/ the backslash).  Returns the decoded byte and the+-- offset of the byte just past the escape.  Both @\\DDD@+-- (three ASCII decimal digits, @0..127@) and @\\X@ (any other+-- single ASCII byte) decode to a single ASCII byte; values+-- @>= 128@ are rejected.+decodeEscape :: TA.Array -> Int -> Int -> Maybe (Word8, Int)+decodeEscape arr !i !srcEnd+    | i >= srcEnd = Nothing+    | !w <- TA.unsafeIndex arr i+    , !d <- fromIntegral (w - 0x30)+    = if | w > 0x7f  -> Nothing+         | d > 9     -> Just (w, i + 1)+         | i + 3 > srcEnd -> Nothing+         | !e <- fromIntegral (TA.unsafeIndex arr (i + 1) - 0x30), e <= 9+         , !f <- fromIntegral (TA.unsafeIndex arr (i + 2) - 0x30), f <= 9+         , !n <- 100 * d + 10 * e + f :: Int+         , n < 0x80  -> Just (fromIntegral n, i + 3)+         | otherwise -> Nothing++-- | Pack a 'String' to 'Text', rejecting inputs whose UTF-8+-- byte length exceeds @maxBytes@.  Used by 'dnLit' and 'mbLit' to+-- short-circuit obviously-invalid literal inputs before invoking+-- the user parser.+--+-- The implementation uses 'T.unfoldrN' with a codepoint cap of+-- @maxBytes + 1@, which terminates even on infinite input+-- 'String's: a codepoint is at least one UTF-8 byte, so+-- consuming @maxBytes + 1@ codepoints is always sufficient to+-- decide whether the input fits within the @maxBytes@-byte cap.+packBounded :: Int -> String -> Maybe Text+packBounded !maxBytes s+    | T.lengthWord8 t > maxBytes = Nothing+    | otherwise                  = Just t+  where+    !t = T.unfoldrN (maxBytes + 1) L.uncons s++-- | Upper bound on the length of a valid mailbox or domain+-- presentation form, in UTF-8 bytes.  Anything longer is rejected+-- before the parser is invoked.  The worst case is a fully+-- @\\DDD@-escaped 254-octet name with full-width Unicode dots+-- between labels -- still well under 1024 bytes, so this is a+-- generous over-estimate that catches accidental overlong inputs+-- without putting a precise limit on legitimate ones.+mboxPresentationMaxBytes :: Int+mboxPresentationMaxBytes = 1024++-- | Template-Haskell typed splice for a compile-time mailbox+-- literal.  Packs the source 'String' literal as 'Text'+-- (rejecting inputs longer than 1024 bytes) and hands it to+-- 'decodePresentationMbox': the localpart is parsed locally with+-- DNS-style escapes, and the post-separator domain text is passed+-- to the caller-supplied parser.  An invalid literal (localpart+-- failure /or/ domain-parser failure /or/ combined-length+-- failure) becomes a compile-time error.+--+-- The parser argument has the same shape as 'dnLit'\'s:+-- @'Text' -> 'Either' e 'ShortByteString'@.  The user can pass+-- the same parser they pass to 'dnLit' (typically a composition+-- with @idna2008@), and the mailbox literal inherits the same IDN+-- policy for the domain portion of the name.  See 'dnLit' for the+-- standard idioms.+mbLit :: forall e m. (Show e, MonadFail m, TH.Quote m)+      => (Text -> Either e ShortByteString) -- ^ Parser+      -> String -- ^ Input literal (source code shape)+      -> TH.Code m Domain+mbLit parse s = TH.joinCode case packBounded mboxPresentationMaxBytes s of+    Nothing -> fail $ "Invalid mailbox literal " ++ show s+                   ++ ": presentation form longer than "+                   ++ show mboxPresentationMaxBytes ++ " bytes"+    Just t  -> case decodePresentationMbox parse t of+        Left e  -> fail $ "Invalid mailbox literal " ++ show s+                       ++ ": " ++ maybe mempty show e+        Right d -> pure (TH.liftTyped d)+++-- | Given a 'Domain/, return its label count.  The root domain has zero labels.+--+-- >>> labelCount $$(dnLit8 "example.org")+-- 2+--+-- >>> toLabels $$(mbLit8 "first.last@example.org")+-- 3+--+labelCount :: Domain -> Word+labelCount (sbsToByteArray . shortBytes -> arr) = go 0 0+  where+    go :: Word -> Int -> Word+    go !acc !off+        | w <- A.indexByteArray arr off+        , w /= 0    = go (acc + 1) (off + w2i w + 1)+        | otherwise = acc++-- | Does the given 'Domain' name consist entirely of LDH labels?+isLDHName :: Domain -> Bool+isLDHName = go . SB.unpack . shortBytes+  where+    go :: [Word8] -> Bool+    go [] = impossible+    go (0:[]) = True+    go (w:ws)+        | Just rest <- goLabels 0 (w2i w) ws+          = go rest+        | otherwise = False++    goLabels :: Int -> Int -> [Word8] -> Maybe [Word8]+    goLabels !_ !_ [] = impossible+    goLabels !_ !0 !_ = impossible+    goLabels !_ 1  (!b:rest)+        | isLDByte b = Just rest+        | otherwise = Nothing+    goLabels 0 !len  (!b:bs)+        | isLDByte b  = goLabels 1 (len - 1) bs+        | otherwise = Nothing+    goLabels !off !len (!b:bs)+        | isLDHByte b = goLabels (off + 1) (len - 1) bs+        | otherwise = Nothing++-- | Is the given 'ShortByteString' a valid non-empty LDH label?+isLDHLabel :: ShortByteString -> Bool+isLDHLabel = go <$> SB.length <*> SB.unpack+  where+    go len bytes+        | len > 0 && len < 64 = goBytes 0 len bytes+        | otherwise = False++    goBytes :: Int -> Int -> [Word8] -> Bool+    goBytes !_ !_ [] = impossible+    goBytes !_ !0 _  = impossible+    goBytes !_ !1 (!b:_) = isLDByte b+    goBytes !0 !len (!b:bs)+        | isLDByte b = goBytes 1 (len - 1) bs+        | otherwise = False+    goBytes !off !len (!b:bs)+        | isLDHByte b = goBytes (off + 1) (len - 1) bs+        | otherwise = False++isLDByte :: Word8 -> Bool+isLDByte w+    | w - 0x30 < 10            = True+    | (w .&. 0xdf) - 0x41 < 26 = True+    | otherwise                = False++isLDHByte :: Word8 -> Bool+isLDHByte w+    | w - 0x30 < 10            = True+    | (w .&. 0xdf) - 0x41 < 26 = True+    | w == 0x2d                = True+    | otherwise                = False+++-- | Given a 'Domain/, return its constituent list of raw unescaped labels,+-- most-significant (TLD) label last.+--+-- >>> toLabels $$(dnLit8 "example.org")+-- ["example","org"]+--+-- >>> toLabels $$(mbLit8 "first.last@example.org")+-- ["first.last","example","org"]+--+toLabels :: Domain -> [ShortByteString]+toLabels (Domain_ sbs) = go 0+  where+    ba  = sbsToByteArray sbs+    go !off+        | llen <- w2i $ A.indexByteArray ba off+        , llen /= 0+        , l <- baToShortByteString $ A.cloneByteArray ba (off+1) llen+          = l : go (off + llen + 1)+        | otherwise = []+++-- | Given a Domain, return its constituent list of raw unescaped labels in+-- reverse order, with the TLD first.+--+-- >>> revLabels $$(dnLit8 "example.org")+-- ["org","example"]+--+-- >>> revLabels $$(mbLit8 "first.last@example.org")+-- ["org","example","first.last"]+--+revLabels :: Domain -> [ByteString]+revLabels = go [] . wireBytes+  where+    go acc !bs+        | B.length bs > 1+          = let !llen = w2i $ B.unsafeHead bs+                !rest = B.unsafeTail bs+                !lbs = B.unsafeTake llen rest+             in go (lbs : acc) (B.unsafeDrop llen rest)+        | otherwise+          = acc+++-- | Return the longest common suffix of two input domains.+commonSuffix :: Domain -> Domain -> Domain+commonSuffix (Domain_ s1) (Domain_ s2) = go (min len1 len2) 0 0+  where+    len1 = SB.length s1+    len2 = SB.length s2+    ba1  = sbsToByteArray s1+    ba2  = sbsToByteArray s2++    -- When leading labels or suffix lengths are unequal, discard the label+    -- that leaves the shortest suffix, reducing the maximum match size to its+    -- length.  When they're equal, and leave equal length suffixes retain the+    -- match size and continue with both suffixes.  Once either suffix is just+    -- the root domain, we're done.  If both get there at the same time, 'sz'+    -- is the common suffix length.+    go sz off1 off2+        | i1 == 0 || i2 == 0+          = if | i1 /= i2 || sz == 1 -> RootDomain+               | otherwise           -> tailSlice+        | r1 >= sz+          = go sz t1 off2+        | r2 >= sz+          = go sz off1 t2+        | r2 < r1+          = go r2 t1 off2+        | r2 > r1+          = go r1 off1 t2+        | i1 /= i2 || EQ /= A.compareByteArrays ba1 off1 ba2 off2 i1+          = go r1 t1 t2+        | otherwise+          = go sz t1 t2+      where+        i1 = w2i $ A.indexByteArray ba1 off1+        t1 = off1 + i1 + 1+        r1 = len1 - t1+        i2 = w2i $ A.indexByteArray ba2 off2+        t2 = off2 + i2 + 1+        r2 = len2 - t2+        tailSlice = Domain_ $+            baToShortByteString $ A.cloneByteArray ba1 (len1 - sz) sz+++-- | Encode a 'Domain' name without name compression+mbWireForm :: Domain -> SizedBuilder+mbWireForm d = mbShortByteString (shortBytes d)+{-# INLINE mbWireForm #-}++---------------------------------------- Wire -> Presentation++-- | Build the standard (dot-terminated) /presentation form/ of 'Domain'.+presentDomain :: Domain -> Builder -> Builder+presentDomain = fromWire dotB W_dot++-- | Build the /presentation form/ of a 'Domain' without a trailing dot.+-- The root domain is nevertheless presented as a single @.@ byte.+presentHost :: Domain -> Builder -> Builder+presentHost = toCanonical W_dot++-- | Build an ad hoc /mailbox form/ of a 'Domain', without a trailing dot,+-- and with @\'\@\'@ as the first label separator.+presentMbox :: Domain -> Builder -> Builder+presentMbox = toCanonical W_at++-- | Build a presentation form.+fromWire :: (Builder -> Builder) -> Word8 -> Domain -> Builder -> Builder+fromWire dterm sep0 (B.uncons . wireBytes -> ht) k+    | Just (len, bs) <- ht = go sep0 len bs+    | otherwise            = impossible+  where+    go :: Word8 -> Word8 -> ByteString -> Builder+    go _   0   _     = dotB k+    go sep len bytes =+        let (label, suffix) = B.splitAt (fromEnum len) bytes+         in case B.uncons suffix of+                Just (slen, sbytes)+                    | slen > 0 -> presentDomainLabel sep label+                                  . presentByte sep+                                  $ go W_dot slen sbytes+                _   -> presentDomainLabel W_dot label $ dterm k++-- | Build a canonical presentation form (folded to lower case)+toCanonical :: Word8 -> Domain -> Builder -> Builder+toCanonical sep0 (B.uncons . wireBytes -> ht) k+    | Just (len, bs) <- ht = go sep0 len bs+    | otherwise            = impossible+  where+    go :: Word8 -> Word8 -> ByteString -> Builder+    go _   0   _     = dotB k+    go sep len bytes =+        let (label, suffix) = B.splitAt (fromEnum len) bytes+         in canon sep label+            $ case B.uncons suffix of+               Just (slen, sbytes)+                   | slen > 0 -> presentByte sep (go W_dot slen sbytes)+               _              -> k+      where+        canon W_dot = presentHostLabel W_dot+        canon w     = presentDomainLabel w++---------------------------------------- Util++-- | Most domain names are short, use small buffers, but no need to make them+-- too tight since we ultimately copy again into a short bytestring.+domainStrat :: B.AllocationStrategy+domainStrat = B.untrimmedStrategy 32 128++pattern W_dot    :: Word8;      pattern W_dot    = 0x2e+pattern W_at     :: Word8;      pattern W_at     = 0x40++dotB :: Builder -> Builder+dotB = presentByte W_dot++w2i :: Word8 -> Int+w2i = fromIntegral+{-# INLINE w2i #-}++i2w :: Int -> Word8+i2w = fromIntegral+{-# INLINE i2w #-}++-- | Upper case ASCII letter?+{-# INLINE isupper #-}+isupper :: Word8 -> Bool+isupper w = (w - 0x41 < 26)++-- | Map upper case ASCII to lower case.+{-# INLINE tolower #-}+tolower :: Word8 -> Word8+tolower w | isupper w = w + 32+tolower w = w
+ internal/Net/DNSBase/Internal/EDNS.hs view
@@ -0,0 +1,141 @@+-- |+-- Module      : Net.DNSBase.Internal.EDNS+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Internal.EDNS+    ( -- * Fixed portion of EDNS(0) OPT pseudo-RR+      EDNS(..)+    , defaultEDNS+    , maxUdpSize+    , minUdpSize+    ) where++import Net.DNSBase.EDNS.Internal.Option+import Net.DNSBase.Internal.Util++----------------------------------------------------------------+-- EDNS (RFC 6891, EDNS(0))+----------------------------------------------------------------++-- | Data type representing extension fields of a version @0@+-- [EDNS](https://tools.ietf.org/html/rfc6891) message.  When a single EDNS(0)+-- @OPT@ pseudo-RR is present in the additional section of a DNS message, it is+-- processed as an @EDNS(0)@ extension header.  The @OPT@ pseudo-RR@ is then+-- elided from the additional section of the decoded message.+--+-- The EDNS @OPT@ pseudo-RR augments the message error status with an 8-bit+-- field that together with the 4-bit @RCODE@ from the unextended DNS header+-- forms the full 12-bit extended @RCODE@.  In order to avoid potential+-- misinterpretation of the response @RCODE@, when the OPT record is decoded,+-- the upper eight bits of the error status are combined with the @RCODE@ of+-- the basic message header to form a single 12-bit result.  The decoded 'EDNS'+-- pseudo-header, omits the extended @RCODE@ bits, they are instead found in+-- the upper eight bits of the message @RCODE@.+--+-- Likewise, when decoding EDNS messages the extension flags are folded into+-- the upper 16-bits of an extended 32-bit @flags@ field in the message header.+-- Consequently, the 'EDNS' extension header record needs no extension @RCODE@+-- or @flags@ fields.+--+-- The reverse process occurs when encoding messages.  The low four bits of the+-- message header @RCODE@ are encoded into the basic DNS header, while the+-- upper eight bits are encoded as part of the EDNS @OPT@ pseudo-RR.+-- Similarly, the high 16 bits of the flags are also encoded in the @OPT@+-- pseudo-RR.  Encoding of messages with an @RCODE@ larger than 15 or any+-- extension flags set fails unless EDNS is enabled.+--+-- When encoding messages for transmission, the 'EDNS' extension header is used+-- to generate the additional OPT record.  Do not add explicit @OPT@ records to+-- the additional section, instead configure EDNS via the message 'Net.DNSBase.Message.ednsHeader'+-- field.+--+-- The fixed part of an @OPT@ pseudo-RR is structured as follows+-- ([RFC891 6.1.2](<https://tools.ietf.org/html/rfc6891#section-6.1.2>)):+--+-- > +------------+--------------+------------------------------++-- > | Field Name | Field Type   | Description                  |+-- > +------------+--------------+------------------------------++-- > | NAME       | domain name  | MUST be 0 (root domain)      |+-- > | TYPE       | u_int16_t    | OPT (41)                     |+-- > | CLASS      | u_int16_t    | requestor's UDP payload size |+-- > | TTL        | u_int32_t    | extended RCODE and flags     |+-- > | RDLEN      | u_int16_t    | length of all RDATA          |+-- > | RDATA      | octet stream | {attribute,value} pairs      |+-- > +------------+--------------+------------------------------++--+-- The extended RCODE and flags, which OPT stores in the RR Time to Live+-- (TTL) field, are structured as follows+-- ([RFC6891 6.1.3](<https://tools.ietf.org/html/rfc6891#section-6.1.3>)):+--+-- > +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++-- > |          EXTENDED-RCODE       |             VERSION           |+-- > +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++-- > | DO|                             Z                             |+-- > +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++--+data EDNS = EDNS {+    -- | EDNS version, presently only version 0 is defined.+    ednsVersion :: {-# UNPACK #-} Word8+    -- | Supported UDP payload size.+  , ednsUdpSize  :: {-# UNPACK #-} Word16+    -- | EDNS options (e.g. 'Net.DNSBase.EDNS.Option.NSID.O_nsid', ...), corresponding to the (attribute,+    -- value) pairs in the RDATA field of the @OPT@ psuedo-RR.+  , ednsOptions  :: [EdnsOption]+  } deriving (Eq, Show)++-- | The default EDNS pseudo-header for queries.  In accordance+-- with the recommendation in+-- [RFC9715, Appedix A](https://datatracker.ietf.org/doc/html/rfc9715#appendix-A-3)+-- the UDP buffer size defaults to 1400 bytes, this should result+-- in replies that fit into both the IPv4 and IPv6 MTU in typical+-- Internet-connected networks.+--+-- A small minority of IPv6 networks are rumoured to have smaller+-- MTUs of around 1280 bytes, and the corresponding DNS UDP size+-- might then be 1232 bytes.+--+-- Since this library is a stub resolver, it is expected that the+-- configured iterative resolvers are "near" enough to not require+-- pessimistic UDP size limits.  With a loopback conenction to a+-- local resolver it may even make sense to set the UDP size limit+-- at the 16KB maximum.+--+-- There is no single best value for the buffer size, too large+-- risks fragmentation issues, while too small risks TCP fallback+-- which is more costly and may fail.+--+-- @+-- defaultEDNS = EDNS+--     { ednsVersion = 0      -- The default EDNS version is 0+--     , ednsUdpSize = 1400   -- RFC9715 recommended value+--     , ednsOptions = []     -- No EDNS options by default+--     }+-- @+--+defaultEDNS :: EDNS+defaultEDNS = EDNS+    { ednsVersion = 0      -- ^ The default EDNS version is 0+    , ednsUdpSize = 1400   -- ^ IPv6-safe UDP MTU+    , ednsOptions = []     -- ^ No EDNS options by default+    }++-- | Maximum UDP size that can be advertised.  If the 'ednsUdpSize' of 'EDNS'+--   is larger, then this value is sent instead.  This value is likely to work+--   only for local nameservers on the loopback network.  Servers generally+--   enforce a smaller limit.+--+-- >>> maxUdpSize+-- 16384+maxUdpSize :: Word16+maxUdpSize = 16384++-- | Minimum UDP size to advertise. If 'ednsUdpSize' of 'EDNS' is smaller,+--   then this value is sent instead.+--+-- >>> minUdpSize+-- 512+minUdpSize :: Word16+minUdpSize = 512
+ internal/Net/DNSBase/Internal/Error.hs view
@@ -0,0 +1,181 @@+-- |+-- Module      : Net.DNSBase.Internal.Error+-- Description : DNS protocol and library error types+-- Copyright   : (c) IIJ Innovation Institute Inc., 2009+--               (c) Viktor Dukhovni, 2020-2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Internal.Error+    ( DNSError(..)+    , DecodeContext(..)+    , DnsSection(..)+    , DnsXprt(..)+    , MessageSource(..)+    , NetworkContext(..)+    , ProtocolContext(..)+    , UserContext(..)+    , EncodeErr(..)+    , EncodeContext(..)+    ) where++import Control.Exception (Exception, IOException)++import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.Peer+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.RCODE (RCODE)+import Net.DNSBase.Internal.RRTYPE (RRTYPE)+import Net.DNSBase.Internal.Util++-- | DNS API errors.+--+data DNSError+    = BadConfiguration String+      -- ^ Resolver misconfiguration.+    | BadNameserver IOException+      -- ^ Nameserver name -> address lookup failure.+    | DecodeError DecodeContext String+      -- ^ Error while decoding from wire form.+    | EncodeError EncodeContext+      -- ^ Error while encoding to wire form.+    | InvalidDomain String+      -- ^ Invalid domain name presentation form.+    | NetworkError NetworkContext+      -- ^ Error in connection establishment, data transmission or a timeout.+    | ProtocolError ProtocolContext+      -- ^ Unexpected DNS message.+    | ResponseError RCODE+      -- ^ DNS message indicates a remote error condition.+    | UserError UserContext+      -- ^ Invalid request.+    deriving (Eq)++instance Exception DNSError+instance Show DNSError where+    showsPrec _ (BadConfiguration rc) = showString "Configuration error: " .+                                        showString rc+    showsPrec _ (BadNameserver io)    = showString "Unusable nameserver: " .+                                        shows io+    showsPrec _ (DecodeError ctx str) = showString "Decode error: " .+                                        presentString ctx . showChar ' ' . showString str+    showsPrec _ (EncodeError ec)      = showString "encoding error: " .+                                        shows ec+    showsPrec _ (InvalidDomain ed)    = showString "invalid domain: " .+                                        showString ed+    showsPrec _ (NetworkError en)     = shows en+    showsPrec _ (ProtocolError ep)    = shows ep+    showsPrec _ (ResponseError rc)    = showString "server error: rcode = " .+                                        showString (presentString rc mempty)+    showsPrec _ (UserError eu)        = shows eu++----------------------------------------------------------------++-- | Request or response context in which a failure occurred.  The+-- `decodeTriple` holds the name, class and type of the problem RR, provided+-- the error was not in one of those fields.+data DecodeContext+    = DecodeContext+    { decodeSection :: DnsSection+    , decodeSource  :: Maybe MessageSource+    , decodeTriple  :: Maybe DnsTriple+    } deriving (Eq)++instance Presentable DecodeContext where+    present DecodeContext {..} =+        maybe id ((present @String "from" .) . presentSp) decodeSource+        . presentSp @String "in" . presentSp decodeSection+        . maybe id ((presentSp @String "at" .) . presentSp) decodeTriple++-- | Message /section/ for error reporting.  The message header and EDNS @OPT@+-- record are also considered /sections/ in this context.+data DnsSection+    = DnsHeaderSection+      -- ^ While parsing the message header.+    | DnsQuestionSection+      -- ^ While parsing the question section.+    | DnsAnswerSection+      -- ^ While parsing the answer section.+    | DnsAuthoritySection+      -- ^ While parsing the authority section.+    | DnsAdditionalSection+      -- ^ While parsing the additional section.+    | DnsEDNSSection+      -- ^ While parsing the EDNS OPT record.+    | DnsNonSection+      -- ^ While parsing a wire-form message fragment.+  deriving (Eq, Show)++instance Presentable DnsSection where+    present DnsHeaderSection     = present @String "the message header"+    present DnsQuestionSection   = present @String "the question section"+    present DnsAnswerSection     = present @String "the answer section"+    present DnsAuthoritySection  = present @String "the authority section"+    present DnsAdditionalSection = present @String "the additional section"+    present DnsEDNSSection       = present @String "an EDNS OPT pseudo-RR"+    present DnsNonSection        = present @String "a wire-form fragment"++----------------------------------------------------------------++data NetworkContext =+    -- | The number of retries for the request was exceeded.+    RetryLimitExceeded+    -- | TCP fallback request timed out.+  | TimeoutExpired+    -- | Network failure.+  | NetworkFailure IOException+  | ServerFailure+  deriving (Eq, Show)++data ProtocolContext =+    -- ^ The sequence number of the answer doesn't match our query. This+    --   could indicate foul play.+    SequenceNumberMismatch+    -- ^ The question section of the response doesn't match our query. This+    --   could indicate foul play.+  | QuestionMismatch+  deriving (Eq, Show)++data UserContext =+    -- | The RRTYPE requested is invalid for queries.+    InvalidQueryType RRTYPE+    -- | The domain for query is illegal.+  | IllegalDomain String+    -- | The response message question count is not equal to 1.+  | BadResponseQuestionCount Int+  deriving (Eq, Show)++----------------------------------------------------------------++-- | Encoding error, polymorphic over the context type+data EncodeErr r where+    -- | message or field too long+    EncodeTooLong :: (Typeable r, Show r, Eq r) => r -> EncodeErr r+    -- | Invalid input+    CantEncode    :: (Typeable r, Show r, Eq r) => r -> EncodeErr r+    -- | Unencodable reserved type+    ReservedType  :: (Typeable r, Show r, Eq r) => RRTYPE -> r -> EncodeErr r+    -- | RCODE or flags require EDNS+    EDNSRequired  :: EncodeErr r++deriving instance (Eq r) => Eq (EncodeErr r)+deriving instance (Show r) => Show (EncodeErr r)++data EncodeContext = forall r. (Typeable r, Show r, Eq r) => EncodeContext (EncodeErr r)++instance Show EncodeContext where+    show (EncodeContext err) = show err++instance Eq EncodeContext where+    (EncodeContext (EncodeTooLong (_a :: a))) == (EncodeContext (EncodeTooLong (_b :: b))) =+        case teq a b of+            Just Refl -> _a == _b+            _         -> False+    (EncodeContext (CantEncode (_a :: a))) == (EncodeContext (CantEncode (_b :: b))) =+        case teq a b of+            Just Refl -> _a == _b+            _         -> False+    (EncodeContext EDNSRequired) == (EncodeContext EDNSRequired) = True+    _ == _ = False
+ internal/Net/DNSBase/Internal/Flags.hs view
@@ -0,0 +1,254 @@+-- |+-- Module      : Net.DNSBase.Internal.Flags+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Internal.Flags+    ( DNSFlags+        ( QRflag+        , AAflag+        , TCflag+        , RDflag+        , RAflag+        , Zflag+        , ADflag+        , CDflag+        , DOflag+        )+    -- * DNS flag construction and inspection+    , basicFlags+    , extendFlags+    , extendedFlags+    , extractOpcode+    , extractRCODE+    , hasAllFlags+    , hasAnyFlags+    , makeDNSFlags+    , maskDNSFlags+    , complementDNSFlags+    -- * DNS flag query control support+    , FlagOps+    , setFlagBits+    , clearFlagBits+    , resetFlagBits+    , emptyFlagOps+    , applyFlagOps+    , defaultQueryFlags+    ) where++import Net.DNSBase.Internal.RCODE+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Opcode+import Net.DNSBase.Internal.Util+++-- | The basic DNS header flags word is a mixture of flag bits and numbers,+-- <https://tools.ietf.org/html/rfc2535#section-6.1>.+--+--                                  1  1  1  1  1  1+--    0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |QR|   Opcode  |AA|TC|RD|RA| Z|AD|CD|   RCODE   |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- The RFC numbering of the bits looks little-endian, but we represent the+-- basic flags as a big-ending 16 bit word with @QR@ in the high (15th) bit.+-- This gives correct values for the @Opcode@ and @RCODE@, whose MSB bits are+-- on the left (the @Opcode@ and @RCODE@ values are big-endian).+--+-- Therefore, when ordering the bits for presentation, we output the stored+-- bits in MSB-to-LSB order, and also do the same with the extended bits+-- below. This matches the left-to-right order from the RFCs.+--+-- The basic header flags are extended with 16 more bits in the low-order+-- second word (bytes 3+4) of the TTL field of the EDNS(0) OPT pseudo-RR:+-- <https://tools.ietf.org/html/rfc6891#section-6.1.3>.+--+--    1  1  1  1  2  2  2  2  2  2  2  2  2  2  3  3+--    6  7  8  9  0  1  2  3  4  5  6  7  8  9  0  1+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |DO|                    Z                       |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- The DNSFlags type combines both the extended and basic flags into a 32-bit+-- word, with the extended flags in the MSB 16-bits.  The bits corresponding+-- to the @Opcode@ and @RCODE@ cannot be set and are always zero.+--+-- Additional bits may be registered from time to time, see the+-- [IANA DNS Header Flags](https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-12)+-- and+-- [IANA EDNS Header Flags](https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-13>)+-- registries.+--+-- Flags can be combined via the 'Monoid' instance, or set explicitly via+-- 'makeDNSFlags'.+--+-- The integral values of the flags are user-visible, users manipulating the+-- flags directly, rather than exclusively via the provided pattern synonyms+-- need to be mindful of the representation.+--+newtype DNSFlags = DNSFlags Word32 deriving (Eq, Show)++instance Semigroup DNSFlags where+    (DNSFlags a) <> (DNSFlags b) = DNSFlags $ (a .|. b) .&. validBits++instance Monoid DNSFlags where+    mempty = DNSFlags 0++-- | Output the names of the flags set.  If none set, outputs a dash: @-@.+instance Presentable DNSFlags where+    present (DNSFlags fl) k =+        case filter (testBit fl . bitpos) [0..31] of+            []     -> present '-' k+            (v:vs) -> bitName v $ foldr ($) k [bitNameSp v' | v' <- vs]+      where+        bitpos n = (15 - n) `mod` 32+        bitNameSp n = present ' ' . bitName n+        bitName n = case DNSFlags $ shiftL 1 (bitpos n) of+            QRflag -> p "qr"+            AAflag -> p "aa"+            TCflag -> p "tc"+            RDflag -> p "rd"+            RAflag -> p "ra"+            Zflag  -> p "z"+            ADflag -> p "ad"+            CDflag -> p "cd"+            DOflag -> p "do"+            _      -> p "bit" . present n+        p = present @String++------------------------------------------++-- | Reserve (i.e. mask out) 4-bit segments corresponding to the @Opcode@+-- and @RCODE@ fields of a basic DNS header. High 16 bits from EDNS are+-- all included, if present.+validBits :: Word32+validBits = complement 0b0111_1000_0000_1111++extractRCODE :: Word16 -> RCODE+extractRCODE bits = RCODE $ bits .&. 0b1111++extractOpcode :: Word16 -> Opcode+extractOpcode bits = Opcode . fromIntegral $ (bits `shiftR` 11) .&. 0b1111++-- | Compute a combined basic DNS header flags word+basicFlags :: Opcode    -- ^ Opcode+           -> RCODE     -- ^ Extended (12-bit) RCODE+           -> DNSFlags  -- ^ Basic and EDNS flags+           -> Word16    -- ^ Flags field for basic DNS header+{-# INLINE basicFlags #-}+basicFlags (Opcode op) (RCODE rc) (DNSFlags fl) =+    opbits .|. flbits .|. rcbits+  where+    opbits = (fromIntegral op .&. 0xF) `shiftL` 11+    rcbits = (fromIntegral rc .&. 0xF)+    flbits = (fromIntegral fl .&. 0xFFFF)++-- | Compute the EDNS flags+extendedFlags :: DNSFlags -- ^ DNSFlags bits+              -> Word16   -- ^ Corresponding EDNS(0) flags word+{-# INLINE extendedFlags #-}+extendedFlags (DNSFlags fl) = fromIntegral $ fl `unsafeShiftR` 16 .&. 0xFFFF++-- | Test whether all flags in the first argument are set in the second.+hasAllFlags :: DNSFlags -> DNSFlags -> Bool+hasAllFlags wanted have = maskDNSFlags wanted have == wanted++-- | Test whether any flags in the first argument are set in the second.+hasAnyFlags :: DNSFlags -> DNSFlags -> Bool+hasAnyFlags wanted have = maskDNSFlags wanted have /= mempty++-- | Construct flags from an explicit integral bit field.  The basic DNS bits+-- are taken from the least-significant 16 bits of the input, and the EDNS+-- flags from the adjacent 16 bits of the input.  Reserved and out of range+-- bits are silently ignored.+makeDNSFlags :: Integral a => a -> DNSFlags+makeDNSFlags fl = DNSFlags $ fromIntegral fl .&. validBits+{-# INLINE makeDNSFlags #-}++-- | Apply bitwise @and@ to two DNSFlags values.+maskDNSFlags :: DNSFlags -> DNSFlags -> DNSFlags+maskDNSFlags (DNSFlags a) (DNSFlags b) = DNSFlags $ a .&. b++-- | Return the flags /not set/.+complementDNSFlags :: DNSFlags -> DNSFlags+complementDNSFlags (DNSFlags fl) = DNSFlags $ complement fl .&. validBits++-- | Combine basic header flags (low 16 bits)+--     with EDNS extended flags (high 16 bits)+extendFlags :: DNSFlags -> Word16 -> DNSFlags+extendFlags (DNSFlags lo) hi =+    DNSFlags $ (fromIntegral hi `shiftL` 16) .|. (lo .&. 0xFFFF)++------------------------------------------++-- | QR (Query or Response) - Clear in queries, set in responses.+pattern QRflag :: DNSFlags+pattern QRflag  = DNSFlags 0x8000+-- | AA (Authoritative answer) - This bit is valid in responses, and specifies+-- that the responding name server is an authority for the domain name in+-- question section.+pattern AAflag :: DNSFlags+pattern AAflag  = DNSFlags 0x0400+-- | TC (Truncated Response) - Specifies that the response was truncated due+-- to length greater than that permitted on the transmission channel.+pattern TCflag :: DNSFlags+pattern TCflag  = DNSFlags 0x0200+-- | RD (Recursion Desired) - This bit may be set in a query and is copied into+-- the response.  If RD is set, it directs the name server to pursue the query+-- recursively.  Authoritative servers may refuse recursive queries, and,+-- conversely, iterative resolvers may refuse non-recursive queries.+pattern RDflag :: DNSFlags+pattern RDflag  = DNSFlags 0x0100+-- | RA (Recursion available) - This is a response bit, and denotes whether+-- recursive query support is available in the name server.+pattern RAflag :: DNSFlags+pattern RAflag  = DNSFlags 0x0080+-- | Z (Reserved, zero until future specification)+pattern  Zflag :: DNSFlags+pattern  Zflag  = DNSFlags 0x0040+-- | AD (Authentic Data) bit - RFC4035, Section 3.2.3.+-- See also [RFC6840, Section 5.8](https://tools.ietf.org/html/rfc6840#section-5.8)+pattern ADflag :: DNSFlags+pattern ADflag  = DNSFlags 0x0020+-- | CD (Checking Disabled) bit - RFC4035, Section 3.2.2.+pattern CDflag :: DNSFlags+pattern CDflag  = DNSFlags 0x0010+-- | DO (DNSSEC OK) bit - RFC3225, Section 3, RFC6891, Section-6.1.4.+pattern DOflag :: DNSFlags+pattern DOflag  = DNSFlags 0x80000000++----------------------------------------++data FlagOps =+     FlagOps { clearBits :: DNSFlags+             , setBits   :: DNSFlags+             } deriving (Eq, Show)++setFlagBits :: DNSFlags -> FlagOps -> FlagOps+setFlagBits (DNSFlags fl) (FlagOps (DNSFlags fl0) (DNSFlags fl1)) =+    FlagOps (DNSFlags (fl0 .&. complement fl))+            (DNSFlags (fl1 .|. fl))++clearFlagBits :: DNSFlags -> FlagOps -> FlagOps+clearFlagBits (DNSFlags fl) (FlagOps (DNSFlags fl0) (DNSFlags fl1)) =+    FlagOps (DNSFlags (fl0 .|. fl))+            (DNSFlags (fl1 .&. complement fl))++resetFlagBits :: DNSFlags -> FlagOps -> FlagOps+resetFlagBits (DNSFlags fl) (FlagOps (DNSFlags fl0) (DNSFlags fl1)) =+    FlagOps (DNSFlags (fl0 .&. complement fl))+            (DNSFlags (fl1 .&. complement fl))++emptyFlagOps :: FlagOps+emptyFlagOps = FlagOps (DNSFlags 0x0) (DNSFlags 0x0)++applyFlagOps :: FlagOps -> DNSFlags -> DNSFlags+applyFlagOps (FlagOps (DNSFlags fl0) (DNSFlags fl1)) (DNSFlags fl) =+    DNSFlags (fl .&. (complement (fl0 .&. validBits)) .|. (fl1 .&. validBits))++-- | Default query flags include just the 'RDflag'.+defaultQueryFlags :: DNSFlags+defaultQueryFlags = RDflag
+ internal/Net/DNSBase/Internal/Message.hs view
@@ -0,0 +1,221 @@+-- |+-- Module      : Net.DNSBase.Internal.Message+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Internal.Message+    ( DNSMessage(..)+    , QueryID+    , putMessage+    , putRequest+    )+    where++import Net.DNSBase.EDNS.Internal.Option+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.Flags+import Net.DNSBase.Internal.Opcode+import Net.DNSBase.Internal.RCODE+import Net.DNSBase.Internal.RData+import Net.DNSBase.Internal.RRTYPE+import Net.DNSBase.Internal.EDNS+import Net.DNSBase.Internal.RRCLASS+import Net.DNSBase.Internal.RR+import Net.DNSBase.Internal.Util++-- | DNS over UDP uses 16-bit query ids to better correlate questions and+-- answers and to (inadequately) reduce the risk of cache-poisoning through+-- forged response packets.  They are still used with TCP to keep the header+-- format the same.+type QueryID = Word16++----------------------------------------------------------------++-- | DNS query or response header, here consisting of just the query ID and+-- the flags, sans the record counts, which are implicit in the corresponding+-- lists, [RFC1035 4.1.1](https://tools.ietf.org/html/rfc1035#section-4.1.1),+-- updated by [RFC2535](https://tools.ietf.org/html/rfc2535#section-6.1).+--+-- The basic DNS header contains the following fields:+--+-- >                                 1  1  1  1  1  1+-- >   0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                      ID                       |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |QR|   Opcode  |AA|TC|RD|RA| Z|AD|CD|   RCODE   |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                    QDCOUNT                    |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                    ANCOUNT                    |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                    NSCOUNT                    |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                    ARCOUNT                    |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- The basic 4-bit @RCODE@ is augmented with 8 bits from the EDNS header,+-- forming a single /extended/ 12-bit @RCODE@, with the basic @RCODE@ as its+-- least-significant 4 bits.  Similarly, the /extended/ 32-bit 'DNSFlags' are+-- a combination of the basic flags above with 16 more flag bits from the+-- EDNS header, with the basic flags in the low 16-bits (with the @Opcode@+-- and @RCODE@ bits always cleared).+--++-- | DNS message format for queries and replies,+-- [RFC1035 4.1](https://tools.ietf.org/html/rfc1035#section-4.1)+--+-- >  +---------------------++-- >  |        Header       |+-- >  +---------------------++-- >  |       Question      | the question for the name server+-- >  +---------------------++-- >  |        Answer       | RRs answering the question+-- >  +---------------------++-- >  |      Authority      | RRs pointing toward an authority+-- >  +---------------------++-- >  |      Additional     | RRs holding additional information+-- >  +---------------------++--+data DNSMessage = DNSMessage+    { dnsMsgId :: QueryID       -- ^ Query or reply identifier.+    , dnsMsgOp :: Opcode        -- ^ The requested operation+    , dnsMsgRC :: RCODE         -- ^ The (extended) result code+    , dnsMsgFl :: DNSFlags      -- ^ The (extended) flags+    , dnsMsgEx :: Maybe EDNS    -- ^ EDNS pseudo-header+    , dnsMsgQu :: [DnsTriple]   -- ^ The question name, type, class+    , dnsMsgAn :: [RR]          -- ^ Answers+    , dnsMsgNs :: [RR]          -- ^ Authority records+    , dnsMsgAr :: [RR]          -- ^ Additional records+    } deriving (Eq, Show)++-- | Encode the DNS Question,+-- [RFC1035 4.1.2](https://tools.ietf.org/html/rfc1035#section-4.1.2)+--+-- >                                 1  1  1  1  1  1+-- >   0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                                               |+-- > /                     QNAME                     /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                     QTYPE                     |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                     QCLASS                    |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+putQuestion :: DnsTriple -> SPut s RData+putQuestion DnsTriple{..} = do+    putDomain dnsTripleName+    put32 $ fromIntegral @Word16 (coerce dnsTripleType) `unsafeShiftL` 16 .|.+            fromIntegral @Word16 (coerce dnsTripleClass)++----------------------------------------------------------------++-- | Stub-resolver fast path for building an outgoing query: emits+-- the DNS header (with the given query ID, request flags, and the+-- four section counts hard-coded for a single question), the+-- single question, and — unless EDNS is disabled — the OPT+-- pseudo-RR carrying the supplied 'EDNS' record.  Used by the+-- resolver in "Net.DNSBase.Internal.Transport".  Fails with+-- 'EDNSRequired' when extended flag bits are set but no 'EDNS'+-- record was supplied.+putRequest :: QueryID+           -> DNSFlags+           -> Maybe EDNS+           -> DnsTriple+           -> SPut s RData+putRequest qid flags (Just EDNS{..}) question = do+    -- header+    put64 $ fromIntegral qid `unsafeShiftL` 48 .|.+            fromIntegral (basicFlags Query NOERROR flags) `unsafeShiftL` 32 .|.+            -- RR counts+            0x0001_0000+    put32 $ 0x0000_0001+    --+    putQuestion question+    -- OPT pseudo-RR+    put8 0  -- Root Domain+    put64 $ fromIntegral @Word16 (coerce OPT) `unsafeShiftL` 48 .|.+            fromIntegral ednsUdpSize `unsafeShiftL` 32 .|.+            fromIntegral ednsVersion `unsafeShiftL` 16 .|.+            fromIntegral (extendedFlags flags)+    if (null ednsOptions)+    then put16 0+    else passLen $ mapM_ putOption ednsOptions+putRequest qid flags _ question = do+    let ef = extendedFlags flags+    when (ef /= 0) $ failWith $ const EDNSRequired+    -- header+    put64 $ fromIntegral qid `unsafeShiftL` 48 .|.+            fromIntegral (basicFlags Query NOERROR flags) `unsafeShiftL` 32 .|.+            -- RR counts+            0x0001_0000+    put32 $ 0x0000_0000+    --+    putQuestion question++-- | General-purpose wire-form encoder for a 'DNSMessage'.  Emits+-- the 12-byte header followed by each section (question, answer,+-- authority, additional) in turn, appending the OPT pseudo-RR to+-- the additional section when 'dnsMsgEx' is present.  Use this+-- for responses or any message with non-trivial section contents;+-- for the stub-resolver request path 'putRequest' is more direct.+putMessage :: DNSMessage -> SPut s RData+putMessage DNSMessage{..}+    | Just EDNS{..} <- dnsMsgEx+      = do+        -- header+        put64 $ msgid `unsafeShiftL` 48 .|.+                flags `unsafeShiftL` 32 .|.+                -- RR counts+                qdcount `unsafeShiftL` 16 .|.+                ancount+        put32 $ nscount `unsafeShiftL` 16 .|.+                arcount+        --+        mapM_ putQuestion dnsMsgQu+        mapM_ putRR dnsMsgAn+        mapM_ putRR dnsMsgNs+        -- OPT pseudo-RR+        put8 0  -- Root Domain+        put32 $ fromIntegral @Word16 (coerce OPT) `unsafeShiftL` 16 .|.+                fromIntegral ednsUdpSize+        put32 $ (fromIntegral rc .&. 0xff0) `unsafeShiftL` 20 .|.+                fromIntegral ednsVersion `unsafeShiftL` 16 .|.+                fromIntegral (extendedFlags dnsMsgFl)+        if (null ednsOptions)+        then put16 0+        else passLen $ mapM_ putOption ednsOptions+        -- Remaining additional records+        mapM_ putRR dnsMsgAr+    | otherwise+      = do+        let ef = extendedFlags dnsMsgFl+        when (rc > 0xf || ef /= 0) $ failWith $ const EDNSRequired+        -- header+        put64 $ msgid `unsafeShiftL` 48 .|.+                flags `unsafeShiftL` 32 .|.+                -- RR counts+                qdcount `unsafeShiftL` 16 .|.+                ancount+        put32 $ nscount `unsafeShiftL` 16 .|.+                arcount+        --+        mapM_ putQuestion dnsMsgQu+        mapM_ putRR dnsMsgAn+        mapM_ putRR dnsMsgNs+        mapM_ putRR dnsMsgAr+  where+    msgid   = fromIntegral dnsMsgId+    qdcount = fromIntegral $ length dnsMsgQu+    ancount = fromIntegral $ length dnsMsgAn+    nscount = fromIntegral $ length dnsMsgNs+    arcount = fromIntegral $ length dnsMsgAr + 1+    flags   = fromIntegral $ basicFlags dnsMsgOp dnsMsgRC dnsMsgFl+    (RCODE rc) = dnsMsgRC
+ internal/Net/DNSBase/Internal/NameComp.hs view
@@ -0,0 +1,67 @@+-- |+-- Module      : Net.DNSBase.Internal.NameComp+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Internal.NameComp+    ( NCTree+    , empty+    , insert+    , lookup+    ) where++import Prelude hiding (lookup)+import Control.Monad.ST as ST+import qualified Data.ByteString as B+import qualified Data.HashTable.ST.Basic as LH+import qualified Data.HashTable.Class as H++type Path = [B.ByteString]+type Map s = LH.HashTable s B.ByteString+data NCTree s = NCTree (Map s (NCTree s)) Int++-- | Create a root node with given value+empty :: Int -> ST.ST s (NCTree s)+empty n = flip NCTree n <$> H.new++-- | Insert a domain with the given labels with last label ending at given+-- offset (if stored uncompressed).  The caller MUST not insert any paths whose+-- tail lies beyond the first 16k of the DNS message.  That is the end offset+-- must not exceed @0x3fff@.+insert :: Path -> Int -> NCTree s -> ST.ST s ()+insert = go+  where+    go :: Path -> Int  -> NCTree s -> ST.ST s ()+    go (!l:ls) !end !(NCTree m _) =+        H.mutateST m l $ alter ls $! end - B.length l - 1+    go _ _ _ = pure ()++    -- | Alter (create or update) the node with given index and start position+    alter :: Path -> Int -> Maybe (NCTree s) -> ST.ST s (Maybe (NCTree s), ())+    alter !ls !start !old = case old of+        -- At existing intermediate nodes recurse to store the rest of the path+        Just  n | null ls   -> pure $ node n+                | otherwise -> node n <$ go ls start n+        -- In new intermediate nodes store the tip offset + distance from tip+        Nothing | null ls   -> node <$> empty start+                | otherwise -> do+                    e <- empty start+                    node e <$ go ls start e+      where+        node n = (Just n, ())++-- | Return the length of the path prefix (domain suffix) and corresponding+-- offset for the input path (reversed list of wire-form labels), counting both+-- the length (1) and payload size of each label, not including the terminal+-- NUL label.+lookup :: Path -> (NCTree s) -> ST.ST s (Int, Int)+lookup labels root = go labels root 0+  where+    go (!l:ls) !(NCTree m off) !slen = do+        mn <- H.lookup m l+        case mn of+            Just n  -> go ls n $! slen + B.length l + 1+            _       -> pure (slen, off)+    go _ (NCTree _ off) slen = pure (slen, off)
+ internal/Net/DNSBase/Internal/Nat16.hs view
@@ -0,0 +1,46 @@+-- |+-- Module      : Net.DNSBase.Internal.Nat16+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE+    DataKinds+  , MagicHash+  #-}++module Net.DNSBase.Internal.Nat16+    ( type Nat16+    , Nat+    , Typeable+    , natToWord16+    , withNat16+    )+    where++import Data.Kind (Constraint)+import Data.Typeable ((:~:)(Refl), Typeable)+import Data.Word (Word16)+import GHC.TypeNats ( Nat, CmpNat, KnownNat, SNat+                    , natVal', withSomeSNat, withKnownNat )+import GHC.Exts ( proxy# )+import Unsafe.Coerce (unsafeCoerce)++type Nat16 :: Nat -> Constraint+type Nat16 n = (KnownNat n, CmpNat n 65536 ~ LT)++-- | Convert 16-bit type-level natural to corresponding RRTYPE.+natToWord16 :: forall (n :: Nat) -> KnownNat n => Word16+natToWord16 n = fromIntegral $ natVal' @n proxy#+{-# INLINE natToWord16 #-}++-- | Convert RRTYPE to 16-bit natural @SomeNat@ singleton.+withNat16 :: forall r. Word16 -> (forall n -> Nat16 n => r) -> r+withNat16 w f = withSomeSNat (fromIntegral w) go+  where+    go :: forall n. SNat n -> r+    go s = case magic n of { Refl -> withKnownNat s (f n) }+    magic :: forall n -> CmpNat n 65536 :~: LT+    magic _ = unsafeCoerce (Refl @LT)+{-# INLINE withNat16 #-}
+ internal/Net/DNSBase/Internal/Opcode.hs view
@@ -0,0 +1,73 @@+-- |+-- Module      : Net.DNSBase.Internal.Opcode+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Internal.Opcode+    ( Opcode+        ( Opcode+        , Query+        , IQuery+        , Status+        , Notify+        , Update+        , DSO+        )+    ) where++import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util++-- | The DNS request Opcode from the basic DNS header.  Attempts to construct+-- an 'Opcode' larger than 15 will produce in an error.+--+newtype Opcode = Op_ Word8 deriving (Eq, Ord, Enum, Show)++instance Bounded Opcode where+    minBound = Op_ 0+    maxBound = Op_ 0xf++{-# COMPLETE Opcode #-}+pattern Opcode :: Word8 -> Opcode+pattern Opcode w <- Op_ w where+    Opcode w+        | Op_ w <= maxBound = Op_ w+        | otherwise         = error "Opcode out of range"++-- | The 'Presentable' instance outputs BIND-compatible names.+instance Presentable Opcode where+    present Query    = present @String "QUERY"+    present IQuery   = present @String "IQUERY"+    present Status   = present @String "STATUS"+    present Notify   = present @String "NOTIFY"+    present Update   = present @String "UPDATE"+    present DSO      = present @String "DSO"+    present (Op_ op) = present @String "OPCODE" . present op++------------------------------------------++-- | Query - [RFC1035]+pattern Query        :: Opcode+pattern Query         = Opcode 0++-- | IQuery - [RFC3425]+pattern IQuery       :: Opcode+pattern IQuery        = Opcode 1++-- | Status - [RFC1035]+pattern Status       :: Opcode+pattern Status        = Opcode 2++-- | Notify - [RFC1996]+pattern Notify       :: Opcode+pattern Notify        = Opcode 4++-- | Update - [RFC2136]+pattern Update       :: Opcode+pattern Update        = Opcode 5++-- | DSO - [RFC8490] DNS Stateful Operations+pattern DSO          :: Opcode+pattern DSO           = Opcode 6
+ internal/Net/DNSBase/Internal/Peer.hs view
@@ -0,0 +1,50 @@+-- |+-- Module      : Net.DNSBase.Internal.Peer+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Internal.Peer+    ( MessageSource(..)+    , DnsXprt ( DnsOverUDP+              , DnsOverTCP+              , DnsOverTLS+              , DnsOverQUIC+              )+    ) where+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util++-- | Transport between DNS client and server+newtype DnsXprt = DnsXprt Word8+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral)++instance Presentable DnsXprt where+    present DnsOverUDP  = present @String "UDP"+    present DnsOverTCP  = present @String "TCP"+    present DnsOverTLS  = present @String "DoT"+    present DnsOverQUIC = present @String "DoQ"+    present t           = present @String "Xprt" . present @Word8 (coerce t)++pattern DnsOverUDP  :: DnsXprt; pattern DnsOverUDP  = DnsXprt 0+pattern DnsOverTCP  :: DnsXprt; pattern DnsOverTCP  = DnsXprt 1+pattern DnsOverTLS  :: DnsXprt; pattern DnsOverTLS  = DnsXprt 2+pattern DnsOverQUIC :: DnsXprt; pattern DnsOverQUIC = DnsXprt 3++-- | DNS client or server peer endpoint.+data MessageSource = MessageSource+    { dnsPeerXprt :: DnsXprt+    , dnsPeerName :: Maybe String+    , dnsPeerAddr :: IP+    , dnsPeerPort :: Word16+    } deriving (Eq)++instance Presentable MessageSource where+    present MessageSource {..} =+        present dnsPeerXprt . present '@'+        . maybe id present dnsPeerName+        . presentCharSep '[' dnsPeerAddr . present ']'+        . presentCharSep ':' dnsPeerPort
+ internal/Net/DNSBase/Internal/Present.hs view
@@ -0,0 +1,282 @@+-- |+-- Module      : Net.DNSBase.Internal.Present+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Internal.Present+    ( -- * Presentable class+      Presentable(..)+    -- ** Builder combinators+    , presentByte+    , presentCharSep+    , presentCharSepLn+    , presentLn+    , presentSep+    , presentSepLn+    , presentSp+    , presentSpLn+    -- *** Newtype for parsing and presenting 64-bit epoch times.+    , Epoch64(..)+    -- ** Build directly to a 'String' or 'ByteString'+    , presentString+    , presentStrict+    -- ** Re-exports from "Data.ByteString.Builder"+    , Builder+    , hPutBuilder+    -- *** 'hPutBuilder' specialised to @stdout@+    , putBuilder+    ) where++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Extra as B+import qualified Data.ByteString.Builder.Prim as P+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.IP.Builder as IP+import qualified System.IO as IO+import Data.ByteString.Builder (hPutBuilder)+import Data.ByteString.Builder.Prim ((>$<), (>*<))+import Data.String (IsString(..))+import Data.Time.Clock.System (SystemTime(..), utcToSystemTime)+import Data.Time.Format (defaultTimeLocale, parseTimeOrError)++import Net.DNSBase.Internal.Util++-- | Return DNS presentation form, as a lazy ByteString builder, taking a+-- continuation.  Since DNS record presentation form is ASCII, we don't need+-- Unicode strings, and lazy ByteString builders perform one to two orders of+-- magnitude faster.+--+-- Complex builders with nested sub-components are much more efficient when+-- constructed in continuation passing style.+--+class Presentable a where+    -- | Serialise the input value with the given continuation.+    present :: a        -- ^ Value to serialise+            -> Builder  -- ^ Continuation+            -> Builder  -- ^ Final output++    -- | Run the builder immediately, producing a lazy 'L.ByteString' with the+    -- given tail.+    presentLazy :: a -- ^ Value to serialise+                -> L.ByteString -- ^ Lazy bytestring suffix+                -> L.ByteString -- ^ Final output+    presentLazy a k = B.toLazyByteStringWith strat k $ present a mempty+      where+        strat = B.safeStrategy 128 B.smallChunkSize++instance Presentable Builder where+    present = (<>)++-- | Append a char, assumed 8-bit only.+instance Presentable Char where+    present = (<>) . B.char8+    {-# INLINE present #-}++-- | Append a string, assumed ASCII.+instance Presentable String where+    present = (<>) . B.string8+    {-# INLINE present #-}++-- | Append a 'ShortByteString' assumed already escaped to not require+-- additional escaping or quoting.+--+instance Presentable ShortByteString where+    present = (<>) . B.shortByteString+    {-# INLINE present #-}++instance Presentable ByteString where+    present = (<>) . B.byteString+    {-# INLINE present #-}++-- Append a decimal Int+instance Presentable Int where+    present = (<>) . B.intDec+    {-# INLINE present #-}++-- Append a decimal Int64+instance Presentable Int64 where+    present = (<>) . B.int64Dec+    {-# INLINE present #-}++-- Append a decimal Int32+instance Presentable Int32 where+    present = (<>) . B.int32Dec+    {-# INLINE present #-}++-- Append a decimal Int16+instance Presentable Int16 where+    present = (<>) . B.int16Dec+    {-# INLINE present #-}++-- Append a decimal Int8+instance Presentable Int8 where+    present = (<>) . B.int8Dec+    {-# INLINE present #-}++-- Append a decimal word8+instance Presentable Word8 where+    present = (<>) . B.word8Dec+    {-# INLINE present #-}++instance Presentable Word16 where+    present = (<>) . B.word16Dec+    {-# INLINE present #-}++instance Presentable Word32 where+    present = (<>) . B.word32Dec+    {-# INLINE present #-}++instance Presentable Word64 where+    present = (<>) . B.word64Dec+    {-# INLINE present #-}++instance Presentable IP where+    present = (<>) . IP.ipBuilder++instance Presentable IPv4 where+    present = (<>) . IP.ipv4Builder++instance Presentable IPv6 where+    present = (<>) . IP.ipv6Builder++-- | Prepend a single literal byte to a continuation builder.  The+-- workhorse separator primitive that the other combinators+-- ('presentSep', 'presentSp', 'presentLn', ...) are built on.+presentByte :: Word8 -> Builder -> Builder+presentByte = (<>) . B.word8+{-# INLINE presentByte #-}++-- | Append the presentation of @a@ followed by a newline (@\\n@,+-- 0x0a).  Use this to terminate each record when emitting a+-- zone-file-style stream, as in+-- @foldr presentLn mempty records@.+presentLn :: Presentable a => a -> Builder -> Builder+presentLn a = present a . presentByte 0x0a+{-# INLINE presentLn #-}++-- | Append with a leading separator+presentSep :: Presentable a => Word8 -> a -> Builder -> Builder+presentSep sep a = presentByte sep . present a+{-# INLINE presentSep #-}++-- | Append with a leading separator and a trailing newline+presentSepLn :: Presentable a => Word8 -> a -> Builder -> Builder+presentSepLn sep a = presentByte sep . presentLn a+{-# INLINE presentSepLn #-}++-- | Append with a leading 'Char' octet separator+presentCharSep :: Presentable a => Char -> a -> Builder -> Builder+presentCharSep sep a = present sep . present a+{-# INLINE presentCharSep #-}++-- | Append with a leading separator and a trailing newline+presentCharSepLn :: Presentable a => Char -> a -> Builder -> Builder+presentCharSepLn sep a = present sep . presentLn a+{-# INLINE presentCharSepLn #-}++-- | Append with a leading space+presentSp :: Presentable a => a -> Builder -> Builder+presentSp = presentSep 0x20+{-# INLINE presentSp #-}++-- | Append with a leading space and a trailing newline+presentSpLn :: Presentable a => a -> Builder -> Builder+presentSpLn a = presentByte 0x20 . presentLn a+{-# INLINE presentSpLn #-}++-- | Immediately construct a strict 'ByteString' from the input followed by+-- the given lazy 'L.ByteString' tail.+presentStrict :: Presentable a => a -> L.ByteString -> ByteString+presentStrict a = L.toStrict . presentLazy a++-- | Immediately construct a 'String' from the input followed by the given+-- tail.+presentString :: Presentable a => a -> String -> String+presentString a k = L8.unpack (presentLazy a mempty) ++ k++-- | Execute the Builder writing output to @IO.stdout@.+-- Typically, @stdout@ should be set in 'IO.BinaryMode' with+-- 'IO.BlockBuffering'.  See 'IO.hSetBinaryMode' and+-- 'IO.hSetBuffering' for details.+--+putBuilder :: Builder -> IO ()+putBuilder = hPutBuilder IO.stdout++-- | 64-bit extended representation of 32-bit DNS clock-arithmetic types.+-- The presentation form is as a YYYYMMDDHHMMSS string.+newtype Epoch64 = Epoch64 Int64+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral)++-- | Parse DNSSEC YYYYmmddHHMMSS time format to 'Epoch64' value+instance IsString Epoch64 where+    fromString = coerce . systemSeconds . utcToSystemTime . parseUTC+      where+        parseUTC = parseTimeOrError False defaultTimeLocale "%Y%m%d%H%M%S"++instance Show Epoch64 where+    showsPrec _ e = showChar '"' . presentString e . showChar '"'++instance Presentable Epoch64 where+    -- <http://howardhinnant.github.io/date_algorithms.html>+    -- (years prior 1000 are not supported).+    -- This avoids all the pain of converting epoch time to NominalDiffTime ->+    -- UTCTime -> LocalTime then using formatTime with defaultTimeLocale!+    -- >>> :{+    -- let testVector :: [(String, Epoch64)]+    --     testVector =+    --         [ ( "19230704085602", -1467299038)+    --         , ( "19331017210945", -1142563815)+    --         , ( "19480919012827", -671668293 )+    --         , ( "19631210171455", -191227505 )+    --         , ( "20060819001740", 1155946660 )+    --         , ( "20180723061122", 1532326282 )+    --         , ( "20281019005024", 1855529424 )+    --         , ( "20751108024632", 3340406792 )+    --         , ( "21240926071415", 4883008455 )+    --         , ( "21270331070215", 4962150135 )+    --         , ( "21371220015305", 5300560385 )+    --         , ( "21680118121052", 6249787852 )+    --         , ( "21811012210032", 6683202032 )+    --         , ( "22060719093224", 7464648744 )+    --         , ( "22100427121648", 7583717808 )+    --         , ( "22530821173957", 8950757997 )+    --         , ( "23010804210243", 10463979763)+    --         , ( "23441111161706", 11829514626)+    --         , ( "23750511175551", 12791843751)+    --         , ( "23860427060801", 13137746881) ]+    --  in (==) <$> map (flip presentString "" . snd) <*> map fst $ testVector+    -- :}+    -- True+    --+    present (Epoch64 t) k =+        B.int64Dec year+        <> pad2 mon+        <> pad2 day+        <> pad2 hh+        <> pad2 mm+        <> pad2 ss+        <> k+      where+        (!z0, !s) = t `divMod` 86400+        !z = z0 + 719468+        (!era, !doe) = z `divMod` 146097+        !yoe = (doe - doe `quot` 1460 + doe `quot` 36524+                   - doe `quot` 146096) `quot` 365+        !y = yoe + era * 400+        !doy = doe - (365*yoe + yoe `quot` 4 - yoe `quot` 100)+        !mp = (5*doy + 2) `quot` 153+        !day = doy - (153*mp + 2) `quot` 5 + 1+        !mon = 1 + (mp + 2) `rem` 12+        !year = y + (12 - mon) `quot` 10+        (!hh, (!mm, !ss)) = flip divMod 60 <$> s `divMod` 3600++        pad2 :: Integral a => a -> Builder+        pad2 = P.primBounded w2 . fromIntegral+          where+            w2 = P.condB+                   do (> 9)+                   do P.word8Dec+                   do ((), ) >$< (const 0x30 >$< P.liftFixedToBounded P.word8) >*< P.word8Dec
+ internal/Net/DNSBase/Internal/RCODE.hs view
@@ -0,0 +1,179 @@+-- |+-- Module      : Net.DNSBase.Internal.RCODE+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Internal.RCODE+    ( RCODE+        ( RCODE+        , NOERROR+        , FORMERR+        , SERVFAIL+        , NXDOMAIN+        , NOTIMP+        , REFUSED+        , YXDOMAIN+        , YXRRSET+        , NXRRSET+        , NOTAUTH+        , NOTZONE+        , DSOTYPENI+        , BADVERS+        , BADSIG+        , BADKEY+        , BADTIME+        , BADMODE+        , BADNAME+        , BADALG+        , BADTRUNC+        , BADCOOKIE+        )+    , extendRCODE+    ) where++import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util++-- | The extended (12-bit) DNS RCODE consisting of 4 bits from the basic DNS+-- header, possibly augmented with 8 more bits from the EDNS header.+--+-- Should always be zero in well-formed requests.  When decoding replies, the+-- high eight bits from any EDNS response are combined with the 4-bit RCODE+-- from the DNS header.  When encoding a message, if EDNS is disabled RCODE+-- values larger than 15 are mapped to 'FORMERR'.+--+-- RCODES 12 through 15 are reserved, see+-- [IANA](https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-6)+newtype RCODE = RC_ Word16 deriving (Eq, Ord, Enum, Show)++instance Bounded RCODE where+    minBound = RC_ 0+    maxBound = RC_ 0xfff++-- | Smart constructor ensures provided values are valid.+-- Attempts to construct a values larger than 4095 raises an error.+pattern RCODE :: Word16 -> RCODE+pattern RCODE w <- RC_ w where+    RCODE w+        | RC_ w <= maxBound = RC_ w+        | otherwise         = error "RCODE out of range"+{-# COMPLETE RCODE #-}++-- | Combine basic header RCODE (low 4 bits)+-- with EDNS extended RCODE (high 8 bits)+extendRCODE :: RCODE -> Word8 -> RCODE+extendRCODE (RCODE lo) hi =+    RCODE $ (fromIntegral hi `shiftL` 4) .|. (lo .&. 0xF)+++instance Presentable RCODE where+    present NOERROR    = present @String "NOERROR"+    present FORMERR    = present @String "FORMERR"+    present SERVFAIL   = present @String "SERVFAIL"+    present NXDOMAIN   = present @String "NXDOMAIN"+    present NOTIMP     = present @String "NOTIMP"+    present REFUSED    = present @String "REFUSED"+    present YXDOMAIN   = present @String "YXDOMAIN"+    present YXRRSET    = present @String "YXRRSET"+    present NXRRSET    = present @String "NXRRSET"+    present NOTAUTH    = present @String "NOTAUTH"+    present NOTZONE    = present @String "NOTZONE"+    present DSOTYPENI  = present @String "DSOTYPENI"+    present BADVERS    = present @String "BADVERS"+    present BADSIG     = present @String "BADSIG"+    present BADKEY     = present @String "BADKEY"+    present BADTIME    = present @String "BADTIME"+    present BADMODE    = present @String "BADMODE"+    present BADNAME    = present @String "BADNAME"+    present BADALG     = present @String "BADALG"+    present BADTRUNC   = present @String "BADTRUNC"+    present BADCOOKIE  = present @String "BADCOOKIE"+    present (RC_ rc)   = present @String "RCODE" . present rc++------------------------------------------++-- | NOERROR - [RFC1035]+pattern NOERROR :: RCODE+pattern NOERROR = RCODE 0++-- | FORMERR - [RFC1035]+pattern FORMERR :: RCODE+pattern FORMERR = RCODE 1++-- | SERVFAIL - [RFC1035]+pattern SERVFAIL :: RCODE+pattern SERVFAIL = RCODE 2++-- | NXDOMAIN - [RFC1035]+pattern NXDOMAIN     :: RCODE+pattern NXDOMAIN     = RCODE 3++-- | NOTIMP - [RFC1035]+pattern NOTIMP       :: RCODE+pattern NOTIMP       = RCODE 4++-- | REFUSED - [RFC1035]+pattern REFUSED      :: RCODE+pattern REFUSED      = RCODE 5++-- | YXDOMAIN - [RFC2136][RFC6672]+pattern YXDOMAIN     :: RCODE+pattern YXDOMAIN     = RCODE 6++-- | YXRRSET - [RFC2136]+pattern YXRRSET      :: RCODE+pattern YXRRSET      = RCODE 7++-- | NXRRSET - [RFC2136]+pattern NXRRSET      :: RCODE+pattern NXRRSET      = RCODE 8++-- | NOTAUTH - [RFC2136]+pattern NOTAUTH      :: RCODE+pattern NOTAUTH      = RCODE 9++-- | NOTZONE - [RFC2136]+pattern NOTZONE      :: RCODE+pattern NOTZONE      = RCODE 10++-- | DSOTYPENI - [RFC8490]+pattern DSOTYPENI    :: RCODE+pattern DSOTYPENI    = RCODE 11++-- | BADVERS - [RFC6891]+pattern BADVERS      :: RCODE+pattern BADVERS      = RCODE 16++-- | BADSIG - [RFC2845]+pattern BADSIG       :: RCODE+pattern BADSIG       = RCODE 16++-- | BADKEY - [RFC2845]+pattern BADKEY       :: RCODE+pattern BADKEY       = RCODE 17++-- | BADTIME - [RFC2845]+pattern BADTIME      :: RCODE+pattern BADTIME      = RCODE 18++-- | BADMODE - [RFC2930]+pattern BADMODE      :: RCODE+pattern BADMODE      = RCODE 19++-- | BADNAME - [RFC2930]+pattern BADNAME      :: RCODE+pattern BADNAME      = RCODE 20++-- | BADALG - [RFC2930]+pattern BADALG       :: RCODE+pattern BADALG       = RCODE 21++-- | BADTRUNC - [RFC4635]+pattern BADTRUNC     :: RCODE+pattern BADTRUNC     = RCODE 22++-- | BADCOOKIE - [RFC7873]+pattern BADCOOKIE    :: RCODE+pattern BADCOOKIE    = RCODE 23
+ internal/Net/DNSBase/Internal/RData.hs view
@@ -0,0 +1,241 @@+-- |+-- Module      : Net.DNSBase.Internal.RData+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++{-# LANGUAGE DefaultSignatures #-}+module Net.DNSBase.Internal.RData+    ( -- * RData class+      RData(..)+    , fromRData+    , monoRData+    , rdataType+    , rdataEncode+    , rdataEncodeCanonical+      -- ** Opaque RData+    , OpaqueRData(..)+    , opaqueRData+    , toOpaqueRData+      -- ** Extensibility+    , KnownRData(..)+    , RDataCodec(..)+    , RDataMap+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Short as SB+import Data.IntMap (IntMap)++import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Internal.Bytes+import Net.DNSBase.Internal.Nat16+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.RRTYPE+import Net.DNSBase.Internal.Util++-- | Abstract DNS Resource Record (type-specific) data.+--+-- The decoding, encoding and presentation functions are responsible for just+-- the value, presentation of the associated RR type defaults to the built-in+-- names, for novel types override 'rdTypePres'.+--+-- The 'Show' instance is typically derived, and will output the type+-- constructor (its output strives to produce syntactically valid Haskell+-- values), in contrast with 'Presentable' which produces RFC-standard+-- presentation forms.+class ( Typeable a, Eq a, Ord a, Show a, Presentable a+      ) => KnownRData a where+    -- | The codec-consumed extension value for type @a@.  Defaults+    -- to @()@.  Types with non-trivial extension data (SVCB and+    -- HTTPS, which carry the SvcParam decoder map) supply their+    -- own associated-type definition.+    type RDataExtensionVal a :: Type+    type RDataExtensionVal a = ()++    -- | The library's built-in starting 'RDataExtensionVal' for type+    -- @a@.  Used as the baseline when the library installs its+    -- built-in registration for @a@, and as the starting point+    -- when the user extends the codec for @a@.  For+    -- @'RDataExtensionVal' a ~ ()@ types the class default applies.+    rdataExtensionVal :: forall b -> b ~ a => RDataExtensionVal a+    default rdataExtensionVal :: (RDataExtensionVal a ~ ())+                              => forall b -> b ~ a => RDataExtensionVal a+    rdataExtensionVal _ = ()++    rdType     :: forall b -> b ~ a => RRTYPE+    rdTypePres :: forall b -> b ~ a => Builder -> Builder+    rdDecode   :: forall b -> b ~ a => RDataExtensionVal a -> Int -> SGet RData+    -- Default encoding+    rdEncode   :: a -> SPut s RData+    -- Canonical encoding for DNSSEC validation.+    cnEncode   :: a -> SPut s RData+    cnEncode    = rdEncode++    -- | Override for user-friendly types for non-built-in types added at+    -- runtime (as part of resolver configuration).  Otherwise, defaults to+    -- @TYPE@/number/.+    rdTypePres _ = present $ rdType a+    {-# INLINE rdTypePres #-}++-- | Wrapper around any concrete 'KnownRData' type.+--+-- Its presentation form includes both the type and the value, space-separated.+-- The underlying concrete types present just their values.+data RData = forall a. KnownRData a => RData a++-- | Recover a typed RR payload from the existential 'RData' wrapper.+-- Returns @'Just' x@ when the dynamic payload's type matches the+-- caller's expected type @a@, and 'Nothing' otherwise.+--+-- The target type is selected by the result-side pattern; once+-- there's a concrete constructor on the @Just@ side, the+-- @'KnownRData' a@ constraint is resolved without an explicit type+-- ascription.  A typical use is a view-pattern dispatch that+-- handles two or more RR types at once:+--+-- > evalIP :: (IP -> a) -> RData -> Maybe a+-- > evalIP f (fromRData -> Just (T_A    ip)) = Just $! f (IPv4 ip)+-- > evalIP f (fromRData -> Just (T_AAAA ip)) = Just $! f (IPv6 ip)+-- > evalIP _ _                               = Nothing+--+-- 'fromRData' is the right tool when the value in hand is already+-- an 'RData'.  If you instead have an 'Net.DNSBase.RR.RR' (or a list of them, as+-- returned by 'Net.DNSBase.Lookup.lookupAnswers'), 'Net.DNSBase.RR.rrDataCast' is the convenience+-- composition @'fromRData' . 'Net.DNSBase.RR.rrData'@.  And 'monoRData' performs+-- the filter-and-cast over a 'Foldable' container in one step.+fromRData  :: forall a. KnownRData a => RData -> Maybe a+fromRData (RData a) = cast a+{-# INLINE fromRData #-}++instance Show RData where+    showsPrec p (RData a) = showsP p $ showString "RData " . shows' a++-- | Presents the type and value, space-separated.+instance Presentable RData where+    present (RData (a :: t)) = rdTypePres t . presentSp a++-- | Known RData Proxy + Codec parameter pair+data RDataCodec where+    RDataCodec :: KnownRData a+              => Proxy a+              -> RDataExtensionVal a+              -> RDataCodec++-- | Map associating a type-specific length-aware 'RData' decoder+-- to each 'Net.DNSBase.RRTYPE.RRTYPE'+type RDataMap = IntMap RDataCodec++-- | Filter a 'Foldable' of 'RData' down to the elements whose+-- payload type matches the caller's target @a@, returning a+-- monomorphic list of those typed values.  Elements with a+-- different payload type are dropped.+--+-- For example, the @T_mx@ payloads from a mixed 'RData' list:+--+-- > mxs :: [RData] -> [T_mx]+-- > mxs = monoRData+--+-- Equivalent to @'Data.Maybe.mapMaybe' 'fromRData' . 'Data.Foldable.toList'@,+-- but in one fused pass.  See 'fromRData' for the single-element+-- cast, and 'Net.DNSBase.RR.rrDataCast' for the 'Net.DNSBase.RR.RR'-input analogue.+monoRData :: forall a t. (KnownRData a, Foldable t) => t RData -> [a]+monoRData = foldr (maybe id (:) . fromRData) []+{-# INLINE monoRData #-}++{-# INLINE rdataType #-}+rdataType :: RData -> RRTYPE+rdataType (RData (_ :: t)) = rdType t++instance Eq RData where+    (RData (_a :: a)) == (RData (_b :: b)) =+        case teq a b of+            Just Refl -> _a == _b+            _         -> False++-- | Compare RData first by RRtype number, then by content.+-- When two RRtype numbers match, but the data types nevertheless differ, order+-- opaque type after non-opaque.  In the unlikely case of two non-opaque types+-- with the same RRtype, compare their opaque encodings (this could throw an+-- error if one of the objects is not encodable, perhaps because encoding would+-- be too long).+instance Ord RData where+    ra@(RData (_a :: a)) `compare` rb@(RData (_b :: b)) =+        compare (rdType a) (rdType b)+        <> if | Just Refl <- teq a b -> compare _a _b+              | isOpaque (rdType a) ra -> GT+              | isOpaque (rdType b) rb -> LT+              | otherwise -> ocmp (toOpaqueRData ra) (toOpaqueRData rb)+      where+        ocmp (Right oa) (Right ob) = compare oa ob+        ocmp (Left e)   _          = error $ show e+        ocmp _          (Left e)   = error $ show e++-- | Perform a default encoding of the contained 'KnownRData'.+rdataEncode :: RData -> SPut s RData+rdataEncode rd@(RData a) = setContext rd $ rdEncode a++-- | Perform a canonical encoding of the contained 'KnownRData'.+rdataEncodeCanonical :: RData -> SPut s RData+rdataEncodeCanonical rd@(RData a) = setContext rd $ cnEncode a++-- | Opaque 'RData', for RRTYPEs not known at runtime+--+data OpaqueRData n = Nat16 n => OpaqueRData ShortByteString+deriving instance Eq (OpaqueRData n)+deriving instance Ord (OpaqueRData n)+instance Show (OpaqueRData n) where+    showsPrec p (OpaqueRData bs) = showsP p $+        showString "OpaqueRData @"+        . shows (natToWord16 n) . showChar ' '+        . shows @Bytes16 (coerce bs)++instance Presentable (OpaqueRData n) where+    present (OpaqueRData val) =+        present "\\#"+        . presentSp (SB.length val)+        . present16 val+      where+        present16 = presentSp @Bytes16 . coerce++instance Nat16 n => KnownRData (OpaqueRData n) where+    rdType _ = RRTYPE $ natToWord16 n+    rdTypePres _ = present "TYPE"+                 . present (natToWord16 n)+    rdEncode (OpaqueRData bs) = putShortByteString bs+    rdDecode _ _ = RData . OpaqueRData @n <.> getShortNByteString++-- | Create opaque RData from its type number and Bytes16 value+opaqueRData :: Word16 -> ShortByteString -> RData+opaqueRData w bs = withNat16 w go+  where+    go :: forall (n :: Nat) -> Nat16 n => RData+    go n = RData $ (OpaqueRData bs :: OpaqueRData n)++-- | Convert 'RData' to its /opaque/ equivalent of the same RRtype.+-- 'OpaqueRData' values will be returned as-is.  Otherwise, this will attempt+-- to encode the record without name compression, the encoding may fail, in+-- which case the return value will be 'Nothing'.+--+toOpaqueRData :: RData -> Either (EncodeErr (Maybe RData)) RData+toOpaqueRData rd@(rdataType -> rt) = withNat16 (coerce rt) go+  where+    go :: forall (n :: Nat) -> Nat16 n => Either (EncodeErr (Maybe RData)) RData+    go n | isOpaque rt rd = Right rd+         | otherwise+           = RData . mkopaque <$> encodeVerbatim do rdataEncode rd+             where+               mkopaque :: B.ByteString -> OpaqueRData n+               mkopaque bs = OpaqueRData $ SB.toShort bs++-- | Check whether the given 'RData' is opaque of given RRtype.+--+isOpaque :: RRTYPE -> RData -> Bool+isOpaque rt rd = withNat16 (coerce rt) go+  where+    go :: forall (n :: Nat) -> Nat16 n => Bool+    go n = isJust (fromRData rd :: Maybe (OpaqueRData n))
+ internal/Net/DNSBase/Internal/RR.hs view
@@ -0,0 +1,93 @@+-- |+-- Module      : Net.DNSBase.Internal.RR+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Internal.RR+    ( RR(..)+    , putRR+    , rrDataCast+    , rrType+    ) where++import Net.DNSBase.Encode.Internal.Metric+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Internal.Domain (Domain, equalWireHost)+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.RData+import Net.DNSBase.Internal.RRTYPE+import Net.DNSBase.Internal.RRCLASS+import Net.DNSBase.Internal.Util++-- | DNS Resource Record [RFC1035 3.2.1](https://tools.ietf.org/html/rfc1035#section-3.2.1)+--+-- >                                 1  1  1  1  1  1+-- >   0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                                               |+-- > /                                               /+-- > /                      NAME                     /+-- > |                                               |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                      TYPE                     |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                     CLASS                     |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                      TTL                      |+-- > |                                               |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                   RDLENGTH                    |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--|+-- > /                     RDATA                     /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- The @TYPE@ field is implicit in the polymorphic 'rrData'.+--+data RR = RR+    { rrOwner :: Domain+    , rrClass :: RRCLASS+    , rrTTL   :: Word32+    , rrData  :: RData+    } deriving (Show)++instance Eq RR where+    a == b = rrOwner a `equalWireHost` rrOwner b+          && rrClass a ==              rrClass b+          && rrTTL   a ==              rrTTL   b+          && rrData  a ==              rrData  b++instance Presentable RR where+    present RR{..} =+        present rrOwner+        . presentSp rrTTL+        . presentSp rrClass+        . presentSp rrData++putRR :: RR -> SPut s RData+putRR RR{..} = do+    putDomain rrOwner+    putSizedBuilder $!+        mbWord16 (coerce $ rdataType rrData)+        <> mbWord16 (coerce rrClass)+        <> mbWord32 rrTTL+    passLen $ rdataEncode rrData++-- | Attempt to cast the 'RData' payload of an 'RR' to a+-- 'KnownRData' type, obtaining its type-specific representation.+-- Returns 'Nothing' if the types do not match.+--+-- Note that /opaque/ 'RData' payloads can't be cast directly to+-- type-specific forms, instead their content has to be explicitly+-- decoded (see 'Net.DNSBase.RData.fromOpaque').+rrDataCast :: KnownRData a => RR -> Maybe a+rrDataCast = fromRData . rrData+{-# INLINE rrDataCast #-}++-- | Returns the 'RRTYPE' of the 'RData' payload of the 'RR'.+rrType :: RR -> RRTYPE+rrType = rdataType . rrData
+ internal/Net/DNSBase/Internal/RRCLASS.hs view
@@ -0,0 +1,54 @@+-- |+-- Module      : Net.DNSBase.Internal.RRCLASS+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Internal.RRCLASS+    ( RRCLASS( ..+             , IN+             , CS+             , CHAOS+             , HESIOD+             , NONE+             , ANYCLASS+             )+    ) where++import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util+++-- | DNS query or resource record class.+newtype RRCLASS = RRCLASS Word16+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++instance Presentable RRCLASS where+    present IN       = present @String "IN"+    present CS       = present @String "CS"+    present CHAOS    = present @String "CHAOS"+    present HESIOD   = present @String "HESIOD"+    present NONE     = present @String "NONE"+    present ANYCLASS = present @String "*"+    present c        = present @String "CLASS" . present @Word16 (coerce c)++-- | IN class, <https://tools.ietf.org/html/rfc1035#section-3.2.4>+pattern IN        :: RRCLASS;     pattern IN        = RRCLASS 1++-- | CS class (obsolete), <https://tools.ietf.org/html/rfc1035#section-3.2.4>+pattern CS        :: RRCLASS;     pattern CS        = RRCLASS 2++-- | CHAOS class, <https://tools.ietf.org/html/rfc1035#section-3.2.4>+pattern CHAOS     :: RRCLASS;     pattern CHAOS     = RRCLASS 3++-- | HESIOD class, <https://tools.ietf.org/html/rfc1035#section-3.2.4>+pattern HESIOD    :: RRCLASS;     pattern HESIOD    = RRCLASS 4++-- | NONE class (Only used in the update protocol),+-- <https://tools.ietf.org/html/rfc2136>+pattern NONE      :: RRCLASS;     pattern NONE      = RRCLASS 254++-- | ANYCLASS (valid only as a query class),+-- <https://tools.ietf.org/html/rfc1035#section-3.2.5>+pattern ANYCLASS  :: RRCLASS;     pattern ANYCLASS  = RRCLASS 255
+ internal/Net/DNSBase/Internal/RRTYPE.hs view
@@ -0,0 +1,695 @@+-- |+-- Module      : Net.DNSBase.Internal.RRTYPE+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE ExplicitNamespaces #-}++module Net.DNSBase.Internal.RRTYPE+    ( -- * DNS RRTYPE numbers+      RRTYPE ( ..+             , A+             , NS+             , MD+             , MF+             , CNAME+             , SOA+             , MB+             , MG+             , MR+             , NULL+             , WKS+             , PTR+             , HINFO+             , MINFO+             , MX+             , TXT+             , RP+             , AFSDB+             , X25+             , ISDN+             , RT+             , NSAP+             , NSAPPTR+             , SIG+             , KEY+             , PX+             , GPOS+             , AAAA+             , LOC+             , NXT+             , EID+             , NIMLOC+             , SRV+             , ATMA+             , NAPTR+             , KX+             , CERT+             , A6+             , DNAME+             , SINK+             , OPT+             , APL+             , DS+             , SSHFP+             , IPSECKEY+             , RRSIG+             , NSEC+             , DNSKEY+             , DHCID+             , NSEC3+             , NSEC3PARAM+             , TLSA+             , SMIMEA+             , HIP+             , NINFO+             , RKEY+             , TALINK+             , CDS+             , CDNSKEY+             , OPENPGPKEY+             , CSYNC+             , ZONEMD+             , SVCB+             , HTTPS+             , DSYNC+             , HHIT+             , BRID+             , NID+             , L32+             , L64+             , LP+             , NXNAME+             , IXFR+             , AXFR+             , MAILB+             , MAILA+             , ANY+             , CAA+             , AMTRELAY+             , RESINFO+             , WALLET+             , CLA+             , IPN+             )+    -- ** Associated type-level naturals+    , type N_a+    , type N_ns+    , type N_md+    , type N_mf+    , type N_cname+    , type N_soa+    , type N_mb+    , type N_mg+    , type N_mr+    , type N_null+    , type N_wks+    , type N_ptr+    , type N_hinfo+    , type N_minfo+    , type N_mx+    , type N_txt+    , type N_rp+    , type N_afsdb+    , type N_x25+    , type N_isdn+    , type N_rt+    , type N_nsap+    , type N_nsapptr+    , type N_sig+    , type N_key+    , type N_px+    , type N_gpos+    , type N_aaaa+    , type N_loc+    , type N_nxt+    , type N_eid+    , type N_nimloc+    , type N_srv+    , type N_atma+    , type N_naptr+    , type N_kx+    , type N_cert+    , type N_a6+    , type N_dname+    , type N_sink+    , type N_opt+    , type N_apl+    , type N_ds+    , type N_sshfp+    , type N_ipseckey+    , type N_rrsig+    , type N_nsec+    , type N_dnskey+    , type N_dhcid+    , type N_nsec3+    , type N_nsec3param+    , type N_tlsa+    , type N_smimea+    , type N_hip+    , type N_ninfo+    , type N_rkey+    , type N_talink+    , type N_cds+    , type N_cdnskey+    , type N_openpgpkey+    , type N_csync+    , type N_zonemd+    , type N_svcb+    , type N_https+    , type N_dsync+    , type N_hhit+    , type N_brid+    , type N_nid+    , type N_l32+    , type N_l64+    , type N_lp+    , type N_nxname+    , type N_ixfr+    , type N_axfr+    , type N_mailb+    , type N_maila+    , type N_any+    , type N_caa+    , type N_amtrelay+    , type N_resinfo+    , type N_wallet+    , type N_cla+    , type N_ipn+    -- Internal+    , rrtypeMax+    ) where++import Net.DNSBase.Internal.Nat16+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util++-- | DNS Resource Record type numbers.  The 'Presentable' instance+-- displays the standard presentation form of the type name for+-- known types, or else @TYPEnnnnn@ for a generic type number+-- @nnnnn@.+--+newtype RRTYPE = RRTYPE Word16+    deriving newtype ( Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read )++instance Presentable RRTYPE where+    present A            = present @String "A"+    present NS           = present @String "NS"+    present MD           = present @String "MD"+    present MF           = present @String "MF"+    present CNAME        = present @String "CNAME"+    present SOA          = present @String "SOA"+    present MB           = present @String "MB"+    present MG           = present @String "MG"+    present MR           = present @String "MR"+    present NULL         = present @String "NULL"+    present WKS          = present @String "WKS"+    present PTR          = present @String "PTR"+    present HINFO        = present @String "HINFO"+    present MINFO        = present @String "MINFO"+    present MX           = present @String "MX"+    present TXT          = present @String "TXT"+    present RP           = present @String "RP"+    present AFSDB        = present @String "AFSDB"+    present X25          = present @String "X25"+    present ISDN         = present @String "ISDN"+    present RT           = present @String "RT"+    present NSAP         = present @String "NSAP"+    present NSAPPTR      = present @String "NSAP-PTR"+    present SIG          = present @String "SIG"+    present KEY          = present @String "KEY"+    present PX           = present @String "PX"+    present GPOS         = present @String "GPOS"+    present AAAA         = present @String "AAAA"+    present LOC          = present @String "LOC"+    present NXT          = present @String "NXT"+    present EID          = present @String "EID"+    present NIMLOC       = present @String "NIMLOC"+    present SRV          = present @String "SRV"+    present ATMA         = present @String "ATMA"+    present NAPTR        = present @String "NAPTR"+    present KX           = present @String "KX"+    present CERT         = present @String "CERT"+    present A6           = present @String "A6"+    present DNAME        = present @String "DNAME"+    present SINK         = present @String "SINK"+    present OPT          = present @String "OPT"+    present APL          = present @String "APL"+    present DS           = present @String "DS"+    present SSHFP        = present @String "SSHFP"+    present IPSECKEY     = present @String "IPSECKEY"+    present RRSIG        = present @String "RRSIG"+    present NSEC         = present @String "NSEC"+    present DNSKEY       = present @String "DNSKEY"+    present DHCID        = present @String "DHCID"+    present NSEC3        = present @String "NSEC3"+    present NSEC3PARAM   = present @String "NSEC3PARAM"+    present TLSA         = present @String "TLSA"+    present SMIMEA       = present @String "SMIMEA"+    present HIP          = present @String "HIP"+    present NINFO        = present @String "NINFO"+    present RKEY         = present @String "RKEY"+    present TALINK       = present @String "TALINK"+    present CDS          = present @String "CDS"+    present CDNSKEY      = present @String "CDNSKEY"+    present OPENPGPKEY   = present @String "OPENPGPKEY"+    present CSYNC        = present @String "CSYNC"+    present ZONEMD       = present @String "ZONEMD"+    present SVCB         = present @String "SVCB"+    present HTTPS        = present @String "HTTPS"+    present DSYNC        = present @String "DSYNC"+    present HHIT         = present @String "HHIT"+    present BRID         = present @String "BRID"+    present NID          = present @String "NID"+    present L32          = present @String "L32"+    present L64          = present @String "L64"+    present LP           = present @String "LP"+    present NXNAME       = present @String "NXNAME"+    present IXFR         = present @String "IXFR"+    present AXFR         = present @String "AXFR"+    present ANY          = present @String "ANY"+    present CAA          = present @String "CAA"+    present AMTRELAY     = present @String "AMTRELAY"+    present RESINFO      = present @String "RESINFO"+    present WALLET       = present @String "WALLET"+    present CLA          = present @String "CLA"+    present IPN          = present @String "IPN"+    present (RRTYPE ty)  = present @String "TYPE" . present ty++-- | [IP4 address](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern A           :: RRTYPE;      pattern A           = RRTYPE 1+type N_a            :: Nat;         type N_a                   = 1++-- | [Authoritative name server](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern NS          :: RRTYPE;      pattern NS          = RRTYPE 2+type N_ns           :: Nat;         type N_ns                  = 2++-- | [Mail destination (Obsolete - use MX)](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern MD          :: RRTYPE;      pattern MD          = RRTYPE 3+type N_md           :: Nat;         type N_md                  = 3++-- | [Mail forwarder (Obsolete - use MX)](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern MF          :: RRTYPE;      pattern MF          = RRTYPE 4+type N_mf           :: Nat;         type N_mf                  = 4++-- | [Canonical name for an alias](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern CNAME       :: RRTYPE;      pattern CNAME       = RRTYPE 5+type N_cname        :: Nat;         type N_cname               = 5++-- | [Start of a zone of authority](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern SOA         :: RRTYPE;      pattern SOA         = RRTYPE 6+type N_soa          :: Nat;         type N_soa                 = 6++-- | [Mailbox domain name (EXPERIMENTAL)](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern MB          :: RRTYPE;      pattern MB          = RRTYPE 7+type N_mb           :: Nat;         type N_mb                  = 7++-- | [Mail group member (EXPERIMENTAL)](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern MG          :: RRTYPE;      pattern MG          = RRTYPE 8+type N_mg           :: Nat;         type N_mg                  = 8++-- | [Mail rename domain name (EXPERIMENTAL)](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern MR          :: RRTYPE;      pattern MR          = RRTYPE 9+type N_mr           :: Nat;         type N_mr                  = 9++-- | [Null RR (EXPERIMENTAL)](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern NULL        :: RRTYPE;      pattern NULL        = RRTYPE 10+type N_null         :: Nat;         type N_null                = 10++-- | [Well known service description](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern WKS         :: RRTYPE;      pattern WKS         = RRTYPE 11+type N_wks          :: Nat;         type N_wks                 = 11++-- | [Domain name pointer](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern PTR         :: RRTYPE;      pattern PTR         = RRTYPE 12+type N_ptr          :: Nat;         type N_ptr                 = 12++-- | [Host information](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern HINFO       :: RRTYPE;      pattern HINFO       = RRTYPE 13+type N_hinfo        :: Nat;         type N_hinfo               = 13++-- | [mailbox information (EXPERIMENTAL)(https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern MINFO       :: RRTYPE;      pattern MINFO       = RRTYPE 14+type N_minfo        :: Nat;         type N_minfo               = 14++-- | [Mail exchange](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern MX          :: RRTYPE;      pattern MX          = RRTYPE 15+type N_mx           :: Nat;         type N_mx                  = 15++-- | [Text strings](https://tools.ietf.org/html/rfc1035#section-3.2.2).+pattern TXT         :: RRTYPE;      pattern TXT         = RRTYPE 16+type N_txt          :: Nat;         type N_txt                 = 16++-- | [Responsible Person](https://www.rfc-editor.org/rfc/rfc1183.html#section-2.2)+pattern RP          :: RRTYPE;      pattern RP          = RRTYPE 17+type N_rp           :: Nat;         type N_rp                  = 17++-- | [AFS Data Base location](https://tools.ietf.org/html/rfc1183#section-1),+pattern AFSDB       :: RRTYPE;      pattern AFSDB       = RRTYPE 18+type N_afsdb        :: Nat;         type N_afsdb               = 18++-- | [X.25 PSDN address](https://www.rfc-editor.org/rfc/rfc1183.html#section-3.1).+pattern X25         :: RRTYPE;      pattern X25         = RRTYPE 19+type N_x25          :: Nat;         type N_x25                 = 19++-- | [ISDN address](https://www.rfc-editor.org/rfc/rfc1183.html#section-3.2).+pattern ISDN        :: RRTYPE;      pattern ISDN        = RRTYPE 20+type N_isdn         :: Nat;         type N_isdn                = 20++-- | [Route Through](https://www.rfc-editor.org/rfc/rfc1183.html#section-3.3).+pattern RT          :: RRTYPE;      pattern RT          = RRTYPE 21+type N_rt           :: Nat;         type N_rt                  = 21++-- | [NSAP style address](https://www.rfc-editor.org/rfc/rfc1706.html#section-5).+-- [DEPRECATED](https://datatracker.ietf.org/doc/status-change-int-tlds-to-historic/)+pattern NSAP        :: RRTYPE;      pattern NSAP        = RRTYPE 22+type N_nsap         :: Nat;         type N_nsap                = 22++-- | [NSAP style PTR](https://www.rfc-editor.org/rfc/rfc1706.html#section-6).+-- [DEPRECATED](https://datatracker.ietf.org/doc/status-change-int-tlds-to-historic/)+pattern NSAPPTR     :: RRTYPE;      pattern NSAPPTR     = RRTYPE 23+type N_nsapptr      :: Nat;         type N_nsapptr             = 23++-- | [Security Signature](https://www.rfc-editor.org/rfc/rfc2535#section-4.1).+pattern SIG         :: RRTYPE;      pattern SIG         = RRTYPE 24+type N_sig          :: Nat;         type N_sig                 = 24++-- | [Security Key](https://www.rfc-editor.org/rfc/rfc2535#section-3.1).+pattern KEY         :: RRTYPE;      pattern KEY         = RRTYPE 25+type N_key          :: Nat;         type N_key                 = 25++-- | [X.400 mail mapping information](https://www.rfc-editor.org/rfc/rfc2163.html#section-4).+pattern PX          :: RRTYPE;      pattern PX          = RRTYPE 26+type N_px           :: Nat;         type N_px                  = 26++-- | [Geographical Position](https://www.rfc-editor.org/rfc/rfc1712.html#section-3).+pattern GPOS        :: RRTYPE;      pattern GPOS        = RRTYPE 27+type N_gpos         :: Nat;         type N_gpos                = 27++-- | [IP6 Address](https://tools.ietf.org/html/rfc3596#section-2.1).+pattern AAAA        :: RRTYPE;      pattern AAAA        = RRTYPE 28+type N_aaaa         :: Nat;         type N_aaaa                = 28++-- | [Location Information](https://www.rfc-editor.org/rfc/rfc1876.html#section-1).+-- Not implemented:+pattern LOC         :: RRTYPE;      pattern LOC         = RRTYPE 29+type N_loc          :: Nat;         type N_loc                 = 29++-- | [Next Domain](https://www.rfc-editor.org/rfc/rfc2535.html#section-5.1).+pattern NXT         :: RRTYPE;      pattern NXT         = RRTYPE 30+type N_nxt          :: Nat;         type N_nxt                 = 30++-- | [Endpoint Identifier](http://ana-3.lcs.mit.edu/~jnc/nimrod/dns.txt).+-- Not implemented.+--+-- >                                  1  1  1  1  1  1+-- >    0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                       RDATA                   /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- *  RDATA: a string of octets containing the Endpoint Identifier.+--    The value is the binary encoding of the Identifier, meaningful+--    only to the system utilizing it.+--+pattern EID         :: RRTYPE;      pattern EID         = RRTYPE 31+type N_eid          :: Nat;         type N_eid                 = 31++-- | [Nimrod Locator](http://ana-3.lcs.mit.edu/~jnc/nimrod/dns.txt).+-- Not implemented+--+-- >                                  1  1  1  1  1  1+-- >    0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                       RDATA                   /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- *  RDATA: a variable length string of octets containing the Nimrod+--    Locator.  The value is the binary encoding of the Locator+--    specified in the Nimrod protocol[[[ref to be supplied]]].+--+pattern NIMLOC      :: RRTYPE;      pattern NIMLOC      = RRTYPE 32+type N_nimloc       :: Nat;         type N_nimloc              = 32++-- | [Server Selection](https://datatracker.ietf.org/doc/html/rfc2782#page-9).+pattern SRV         :: RRTYPE;      pattern SRV         = RRTYPE 33+type N_srv          :: Nat;         type N_srv                 = 33++-- | [ATM Address](https://www.broadband-forum.org/download/af-dans-0152.000.pdf)+-- Not implemented.+--+-- >                                  1  1  1  1  1  1+-- >    0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |          FORMAT       |                       |+-- > +--+--+--+--+--+--+--+--+                       |+-- > /                    ADDRESS                    /+-- > |                                               |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- * FORMAT: One octet that indicates the format of ADDRESS. The two possible+--   values for FORMAT are value 0 indicating ATM End System Address (AESA)+--   format and value 1 indicating E.164 format.+-- * ADDRESS: Variable length string of octets containing the ATM address of+--   the node to which this RR pertains.+--+pattern ATMA        :: RRTYPE;      pattern ATMA        = RRTYPE 34+type N_atma         :: Nat;         type N_atma                = 34++-- | [Naming Authority Pointer](https://www.rfc-editor.org/rfc/rfc3403.html#section-4)+pattern NAPTR       :: RRTYPE;      pattern NAPTR       = RRTYPE 35+type N_naptr        :: Nat;         type N_naptr               = 35++-- | [Key Exchanger](https://www.rfc-editor.org/rfc/rfc2230.html#section-2)+pattern KX          :: RRTYPE;      pattern KX          = RRTYPE 36+type N_kx           :: Nat;         type N_kx                  = 36++-- | [Cerificate](https://www.rfc-editor.org/rfc/rfc4398.html#section-2)+-- Not implemented.+pattern CERT        :: RRTYPE;      pattern CERT        = RRTYPE 37+type N_cert         :: Nat;         type N_cert                = 37++-- | [A6](https://www.rfc-editor.org/rfc/rfc2874.html#section-3.1).+pattern A6          :: RRTYPE;      pattern A6          = RRTYPE 38+type N_a6           :: Nat;         type N_a6                  = 38++-- | [Name redirection](https://tools.ietf.org/html/rfc6672#section-2.1).+pattern DNAME       :: RRTYPE;      pattern DNAME       = RRTYPE 39+type N_dname        :: Nat;         type N_dname               = 39++-- | [SINK](https://datatracker.ietf.org/doc/html/draft-eastlake-kitchen-sink-02#section-2).+-- Not implemented.+pattern SINK        :: RRTYPE;      pattern SINK        = RRTYPE 40+type N_sink         :: Nat;         type N_sink                = 40++-- | [DNS extension options](https://tools.ietf.org/html/rfc6891#section-6.1).+pattern OPT         :: RRTYPE;      pattern OPT         = RRTYPE 41+type N_opt          :: Nat;         type N_opt                 = 41++-- | [Address prefix list](https://datatracker.ietf.org/doc/html/rfc3123#section-10).+-- Not implemented.+pattern APL         :: RRTYPE;      pattern APL         = RRTYPE 42+type N_apl          :: Nat;         type N_apl                 = 42++-- | [Delegation Signer](https://www.rfc-editor.org/rfc/rfc3658#section-5)+-- See [RFC4034](https://www.rfc-editor.org/rfc/rfc4034.html#section-5) for+-- protocol details.+pattern DS          :: RRTYPE;      pattern DS          = RRTYPE 43+type N_ds           :: Nat;         type N_ds                  = 43++-- | [SSH Key fingerprint](https://www.rfc-editor.org/rfc/rfc4255.html#section-5).+pattern SSHFP       :: RRTYPE;      pattern SSHFP       = RRTYPE 44+type N_sshfp        :: Nat;         type N_sshfp               = 44++-- | [IPSEC KEY](https://www.rfc-editor.org/rfc/rfc4255.html#section-5).+pattern IPSECKEY    :: RRTYPE;      pattern IPSECKEY    = RRTYPE 45+type N_ipseckey     :: Nat;         type N_ipseckey            = 45++-- | [RRSIG](https://www.rfc-editor.org/rfc/rfc3755#section-4.1)+-- See [RFC4034](https://www.rfc-editor.org/rfc/rfc4034.html#section-3)+-- for protocol details.+pattern RRSIG       :: RRTYPE;      pattern RRSIG       = RRTYPE 46+type N_rrsig        :: Nat;         type N_rrsig               = 46++-- | [NSEC](https://www.rfc-editor.org/rfc/rfc3755#section-4.1)+-- See [RFC4034](https://www.rfc-editor.org/rfc/rfc4034.html#section-4)+-- for protocol details.+pattern NSEC        :: RRTYPE;      pattern NSEC        = RRTYPE 47+type N_nsec         :: Nat;         type N_nsec                = 47++-- | [DNSKEY](https://www.rfc-editor.org/rfc/rfc3755#section-4.1)+-- See [RFC4034](https://www.rfc-editor.org/rfc/rfc4034.html#section-2)+-- for protocol details.+pattern DNSKEY      :: RRTYPE;      pattern DNSKEY      = RRTYPE 48+type N_dnskey       :: Nat;         type N_dnskey              = 48++-- | [DHCP Information](https://datatracker.ietf.org/doc/html/rfc4701#section-7)+-- Not implemented.+pattern DHCID       :: RRTYPE;      pattern DHCID       = RRTYPE 49+type N_dhcid        :: Nat;         type N_dhcid               = 49++-- | [Hashed authenticated denial of existence](https://www.rfc-editor.org/rfc/rfc5155.html#section-11)+pattern NSEC3       :: RRTYPE;      pattern NSEC3       = RRTYPE 50+type N_nsec3        :: Nat;         type N_nsec3               = 50++-- | [NSEC3PARAM](https://www.rfc-editor.org/rfc/rfc5155.html#section-4).+pattern NSEC3PARAM  :: RRTYPE;      pattern NSEC3PARAM  = RRTYPE 51+type N_nsec3param   :: Nat;         type N_nsec3param          = 51++-- | [DANE TLSA](https://www.rfc-editor.org/rfc/rfc6698.html#section-7).+pattern TLSA        :: RRTYPE;      pattern TLSA        = RRTYPE 52+type N_tlsa         :: Nat;         type N_tlsa                = 52++-- | [DANE SMIMEA](https://www.rfc-editor.org/rfc/rfc8162.html#section-8).+pattern SMIMEA      :: RRTYPE;      pattern SMIMEA      = RRTYPE 53+type N_smimea       :: Nat;         type N_smimea              = 53++-- | [Host Identity Protocol](https://datatracker.ietf.org/doc/html/rfc8005#section-9).+-- Not implemented.+pattern HIP         :: RRTYPE;      pattern HIP         = RRTYPE 55+type N_hip          :: Nat;         type N_hip                 = 55++-- | [Zone status information](https://www.iana.org/assignments/dns-parameters/NINFO/ninfo-completed-template)+-- Not implemented.+pattern NINFO       :: RRTYPE;      pattern NINFO       = RRTYPE 56+type N_ninfo        :: Nat;         type N_ninfo               = 56++-- | [RKEY] (https://datatracker.ietf.org/doc/html/draft-reid-dnsext-rkey-00#rfc.section.3)+-- Not implemented+pattern RKEY        :: RRTYPE;      pattern RKEY        = RRTYPE 57+type N_rkey         :: Nat;         type N_rkey                = 57++-- | [Trust Anchor LINK](https://datatracker.ietf.org/doc/html/draft-wijngaards-dnsop-trust-history-02)+-- Not implemented.+pattern TALINK      :: RRTYPE;      pattern TALINK      = RRTYPE 58+type N_talink       :: Nat;         type N_talink              = 58++-- | [Child DS](https://www.rfc-editor.org/rfc/rfc7344.html#section-7).+-- The CDS RRSet expresses what the Child would like the DS RRSet to look like.+pattern CDS         :: RRTYPE;      pattern CDS         = RRTYPE 59+type N_cds          :: Nat;         type N_cds                 = 59++-- | [Child DNSKEY](https://www.rfc-editor.org/rfc/rfc7344.html#section-7).+-- DNSKEY(s) the Child wants reflected in DS.+pattern CDNSKEY     :: RRTYPE;      pattern CDNSKEY     = RRTYPE 60+type N_cdnskey      :: Nat;         type N_cdnskey             = 60++-- | [OPENPGP Key](https://www.rfc-editor.org/rfc/rfc7929.html#section-8.1).+pattern OPENPGPKEY  :: RRTYPE;      pattern OPENPGPKEY  = RRTYPE 61+type N_openpgpkey   :: Nat;         type N_openpgpkey          = 61++-- | [Child-To-Parent Synchronization](https://www.rfc-editor.org/rfc/rfc7477.html#section-6)+pattern CSYNC       :: RRTYPE;      pattern CSYNC       = RRTYPE 62+type N_csync        :: Nat;         type N_csync               = 62++-- | [Zone Message Digest](https://www.rfc-editor.org/rfc/rfc8976.html#section-5.1)+pattern ZONEMD      :: RRTYPE;      pattern ZONEMD      = RRTYPE 63+type N_zonemd       :: Nat;         type N_zonemd              = 63++-- | [General Purpose Service Binding](https://www.rfc-editor.org/rfc/rfc9460.html#name-svcb-rr-type)+pattern SVCB        :: RRTYPE;      pattern SVCB        = RRTYPE 64+type N_svcb         :: Nat;         type N_svcb                = 64++-- | [SVCB-compatible type for use with HTTP](https://www.rfc-editor.org/rfc/rfc9460.html#name-https-rr-type)+pattern HTTPS       :: RRTYPE;      pattern HTTPS       = RRTYPE 65+type N_https        :: Nat;         type N_https               = 65++-- | [Generalized DNS Notifications](https://datatracker.ietf.org/doc/html/draft-ietf-dnsop-generalized-notify-09#name-dsync-rr-type)+pattern DSYNC       :: RRTYPE;      pattern DSYNC       = RRTYPE 66+type N_dsync        :: Nat;         type N_dsync               = 66++-- | [Hierarchical Host Identity Tag](https://datatracker.ietf.org/doc/html/rfc9886#section-5.1)+-- Not implemented.+pattern HHIT        :: RRTYPE;      pattern HHIT        = RRTYPE 67+type N_hhit         :: Nat;         type N_hhit                = 67++-- | [Broadcast Remote Identification](https://datatracker.ietf.org/doc/html/rfc9886#section-5.2)+-- Not implemented.+pattern BRID        :: RRTYPE;      pattern BRID        = RRTYPE 68+type N_brid         :: Nat;         type N_brid                = 68++-- | [Node Identifier](https://www.rfc-editor.org/rfc/rfc6742.html#section-2.1)+pattern NID         :: RRTYPE;      pattern NID         = RRTYPE 104+type N_nid          :: Nat;         type N_nid                 = 104++-- | [ILNPv4 32-bit locator](https://www.rfc-editor.org/rfc/rfc6742.html#section-2.2)+pattern L32         :: RRTYPE;      pattern L32         = RRTYPE 105+type N_l32          :: Nat;         type N_l32                 = 105++-- | [ILNPv6 64-bit locator](https://www.rfc-editor.org/rfc/rfc6742.html#section-2.3)+pattern L64         :: RRTYPE;      pattern L64         = RRTYPE 106+type N_l64          :: Nat;         type N_l64                 = 106++-- | [ILNP Locator Pointer](https://www.rfc-editor.org/rfc/rfc6742.html#section-2.4)+pattern LP          :: RRTYPE;      pattern LP          = RRTYPE 107+type N_lp           :: Nat;         type N_lp                  = 107++-- | [NXDOMAIN indicator for Compact Denial of Existence](https://datatracker.ietf.org/doc/html/draft-ietf-dnsop-compact-denial-of-existence-04#section-3.4)+-- Reserved sentinel type.+pattern NXNAME      :: RRTYPE;      pattern NXNAME      = RRTYPE 128+type N_nxname       :: Nat;         type N_nxname              = 128++-- | Incremental transfer (RFC1995)+-- Reserved special-purpose type.+pattern IXFR        :: RRTYPE;      pattern IXFR        = RRTYPE 251+type N_ixfr         :: Nat;         type N_ixfr                = 251++-- | Zone transfer (RFC5936)+-- Reserved special-purpose type.+pattern AXFR        :: RRTYPE;      pattern AXFR        = RRTYPE 252+type N_axfr         :: Nat;         type N_axfr                = 252++-- | [A request for mailbox-related records (MB, MG or MR)](https://www.rfc-editor.org/rfc/rfc1035.html#section-3.2.3)+-- Reserved special-purpose type.+pattern MAILB       :: RRTYPE;      pattern MAILB       = RRTYPE 253+type N_mailb        :: Nat;         type N_mailb               = 253++-- | [A request for mail agent RRs (Obsolete - see MX)](https://www.rfc-editor.org/rfc/rfc1035.html#section-3.2.3)+-- Reserved special-purpose type.+pattern MAILA       :: RRTYPE;      pattern MAILA       = RRTYPE 254+type N_maila        :: Nat;         type N_maila               = 254++-- | A request for all records the server/cache has available+-- Reserved special-purpose type.+pattern ANY         :: RRTYPE;      pattern ANY         = RRTYPE 255+type N_any          :: Nat;         type N_any                 = 255++-- | Certification Authority Authorization (RFC6844)+pattern CAA         :: RRTYPE;      pattern CAA         = RRTYPE 257+type N_caa          :: Nat;         type N_caa                 = 257++-- | Automatic Multicast Tunneling Relay (RFC8777)+pattern AMTRELAY    :: RRTYPE;      pattern AMTRELAY    = RRTYPE 260+type N_amtrelay     :: Nat;         type N_amtrelay            = 260++-- | DNS Resolver Information+-- [RFC9606, section 8.1](https://datatracker.ietf.org/doc/html/rfc9606#section-8.1)+-- Not implemented.+pattern RESINFO     :: RRTYPE;      pattern RESINFO     = RRTYPE 261+type N_resinfo      :: Nat;         type N_resinfo             = 261++-- | Public wallet address+-- [Registration template](https://www.iana.org/assignments/dns-parameters/WALLET/wallet-completed-template)+-- Not implemented.+pattern WALLET      :: RRTYPE;      pattern WALLET      = RRTYPE 262+type N_wallet       :: Nat;         type N_wallet              = 262++-- | BP Convergence Layer Adapter+-- [draft-johnson-dns-ipn-cla](https://datatracker.ietf.org/doc/html/draft-johnson-dns-ipn-cla-07#section-5)+-- Not implemented.+pattern CLA         :: RRTYPE;      pattern CLA         = RRTYPE 263+type N_cla          :: Nat;         type N_cla                 = 263++-- | BP Node Number+-- [draft-johnson-dns-ipn-cla](https://datatracker.ietf.org/doc/html/draft-johnson-dns-ipn-cla-07#section-5)+-- Not implemented.+pattern IPN         :: RRTYPE;      pattern IPN         = RRTYPE 264+type N_ipn          :: Nat;         type N_ipn                 = 264++rrtypeMax :: RRTYPE+rrtypeMax = IPN+{-# INLINE rrtypeMax #-}
+ internal/Net/DNSBase/Internal/SockIO.hs view
@@ -0,0 +1,92 @@+-- |+-- Module      : Net.DNSBase.Internal.SockIO+-- Description : Low-level UDP/TCP socket I/O for DNS messages+-- Copyright   : (c) IIJ Innovation Institute Inc., 2009+--               (c) Viktor Dukhovni, 2020-2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Internal.SockIO (+    -- * Receiving DNS messages+    receiveUDP+  , receiveTCP+    -- * Sending pre-encoded DNS messages+  , sendUDP+  , sendTCP+  ) where++import qualified Data.ByteString as B+import qualified Network.Socket.ByteString as Socket+import Network.Socket (Socket)+import Network.Socket.ByteString (recv)+import System.IO.Error (tryIOError, mkIOError, eofErrorType)++import Net.DNSBase.Internal.Error+import Net.DNSBase.Internal.Util+import Net.DNSBase.Resolver.Internal.Types++----------------------------------------------------------------++-- | Receive and a single 'Net.DNSBase.Message.DNSMessage' over a UDP 'Socket'.  Messages+-- longer than 'Net.DNSBase.Resolver.maxUdpSize' are silently truncated, but this should not occur+-- in practice, since we cap the advertised EDNS UDP buffer size limit at the+-- same value.  A 'DNSError' is raised if the I/O operation fails.+--+receiveUDP :: Word16 -> Socket -> DNSIO B.ByteString+receiveUDP maxudp sock = withExceptT wrapError $ recv' sock bufsiz+  where+    bufsiz = fromIntegral maxudp+    wrapError = NetworkError . NetworkFailure++recv' :: Socket -> Int -> ExceptT IOError IO ByteString+recv' sock bufsiz = ExceptT $ tryIOError $ recv sock bufsiz++-- | Receive a single DNS message over a virtual-circuit (TCP) connection.  It+-- is up to the caller to implement any desired timeout. An 'DNSError' is+-- raised if the I/O operation fails.+--+receiveTCP :: Socket -> DNSIO B.ByteString+receiveTCP sock = recvDNS sock 2 >>= recvDNS sock . toLen+  where+    toLen :: ByteString -> Int+    toLen = fromIntegral . word16be++recvDNS :: Socket -> Int -> DNSIO ByteString+recvDNS sock len = withExceptT wrapError recv1+  where+    wrapError = NetworkError . NetworkFailure++    recv1 :: ExceptT IOError IO ByteString+    recv1 = recvCore len >>= cond (B.length .= len) return loop++    loop :: ByteString -> ExceptT IOError IO ByteString+    loop bs0 = do+        let left = len - B.length bs0+        bs1 <- recvCore left+        cond (B.length .= len) return loop $! bs0 <> bs1++    eofE = mkIOError eofErrorType "connection terminated" Nothing Nothing++    recvCore :: Int -> ExceptT IOError IO ByteString+    recvCore len0 = recv' sock len0+                >>= cond B.null (const $ throwE eofE) return++----------------------------------------------------------------++-- | Send an encoded 'Net.DNSBase.Message.DNSMessage' datagram over UDP.  The socket must be+-- explicitly connected to the destination nameserver.  The message length is+-- implicit in the size of the UDP datagram.  With TCP you must use 'sendTCP',+-- because TCP does not have message boundaries, and each message needs to be+-- prepended with an explicit length.+--+sendUDP :: Socket -> ByteString -> DNSIO ()+sendUDP sock = lift . void . Socket.send sock++-- | Send one or more encoded 'Net.DNSBase.Message.DNSMessage' buffers over TCP, each already+-- encapsulated with an explicit length prefix and then concatenated into a+-- single buffer.  DO NOT use 'sendTCP' with UDP.+--+sendTCP :: Socket -> ByteString -> DNSIO ()+sendTCP vc = lift . Socket.sendAll vc
+ internal/Net/DNSBase/Internal/Text.hs view
@@ -0,0 +1,235 @@+-- |+-- Module      : Net.DNSBase.Internal.Text+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Internal.Text+    ( DnsText(..)+    , DnsUtf8Text(..)+    , dnsTextCmp+    , presentCharString+    , presentDomainLabel+    , presentHostLabel+    , presentCSVList+    ) where++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Internal as B+import qualified Data.ByteString.Builder.Prim as P+import qualified Data.ByteString.Builder.Prim.Internal as P+import qualified Data.ByteString.Short as SB+import qualified Data.Text as T+import qualified Data.Text.Array as TA+import qualified Data.Text.Internal as T+import Data.ByteString.Builder.Prim ((>$<), (>*<))++import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util++newtype DnsText = DnsText SB.ShortByteString -- ^ Character string+    deriving (Eq, Show)++-- | Canonical wire-form comparison of DNS character strings.+instance Ord DnsText where+    (DnsText a) `compare` (DnsText b) = SB.length a `compare` SB.length b+                                     <>           a `compare`           b++instance Presentable DnsText where+    present = presentCharString . coerce++-- | Compare wire-form /character-strings/, by length first.+dnsTextCmp :: Coercible a ShortByteString => a -> a -> Ordering+dnsTextCmp x y = DnsText (coerce x) `compare` DnsText (coerce y)++-- | Present a dns /character-string/ with the given continuation.+-- The result is enclosed in double-quotes.+--+presentCharString :: SB.ShortByteString  -- ^ The bytes to encode.+                  -> Builder             -- ^ Continuation+                  -> B.Builder+{-# INLINE presentCharString #-}+presentCharString (SB.fromShort -> bytes) k =+    B.word8 W_dquote <> P.primMapByteStringBounded bp bytes <> B.word8 W_dquote <> k+  where+    isprint = \w -> w >= W_space && w < W_delete+    bp = P.condB isprint sp decEscBP+    sp = P.condB special bsEscBP charBP+    special = \ case+        W_dquote -> True+        W_bslash -> True+        _        -> False++-- | Present a 'Net.DNSBase.Domain.Domain' label with the given continuation.+--+presentDomainLabel :: Word8       -- ^ Label separator, typically 0x2e ('.').+                   -> ByteString  -- ^ The bytes to encode.+                   -> Builder     -- ^ Continuation+                   -> B.Builder+{-# INLINE presentDomainLabel #-}+presentDomainLabel sep bytes k =+    P.primMapByteStringBounded bp bytes <> k+  where+    isgraph = \w -> w > W_space && w < W_delete+    bp = P.condB isgraph sp decEscBP+    sp = P.condB special bsEscBP charBP+      where+        special = \ case+            W_dquote -> True+            W_bslash -> True+            W_dollar -> True+            W_open   -> True+            W_close  -> True+            W_semi   -> True+            W_at     -> True+            w        -> w == sep++-- | Present a 'Net.DNSBase.Domain.Host' label folded to lower case, with the given continuation.+--+presentHostLabel :: Word8       -- ^ Label separator, typically 0x2e ('.').+                 -> ByteString  -- ^ The bytes to encode.+                 -> Builder     -- ^ Continuation+                 -> B.Builder+{-# INLINE presentHostLabel #-}+presentHostLabel sep bytes k =+    P.primMapByteStringBounded bp bytes <> k+  where+    isgraph = \w -> w > W_space && w < W_delete+    bp = P.condB isgraph sp decEscBP+    sp = P.condB special bsEscBP (toLower >$< charBP)+    special = \ case+        W_dquote -> True+        W_bslash -> True+        W_dollar -> True+        W_open   -> True+        W_close  -> True+        W_semi   -> True+        W_at     -> True+        w        -> w == sep+    toLower w | w - W_A > 25 = w+              | otherwise     = w .|. 0x20++-- | Present a 'Net.DNSBase.Domain.Host' label folded to lower case, with the given continuation.+--+presentCSVList :: [SB.ShortByteString]  -- ^ The elements to encode.+               -> Builder               -- ^ Continuation+               -> B.Builder+{-# INLINE presentCSVList #-}+presentCSVList [] = presentByte W_dquote . presentByte W_dquote+presentCSVList (x : xs) =+    pelem W_dquote x+    . flip (foldr (pelem W_comma)) xs+    . presentByte W_dquote+  where+    pelem :: Word8 -> ShortByteString -> Builder -> Builder+    pelem sep = \sb k -> B.word8 sep <> P.primMapByteStringBounded bp (SB.fromShort sb) <> k+    isprint = \w -> w >= W_space && w < W_delete+    bp = P.condB isprint sp decEscBP'+    sp = P.condB special bsEscBP' charBP+    special = \ case+        W_dquote -> True+        W_bslash -> True+        W_comma  -> True+        _        -> False+    -- Two layers of escaping for backslashes and commas, require writing some+    -- backslashes twice:+    -- > "     -> \"+    -- > <DEL> -> \\127+    -- > ,     -> \\,+    -- > \     -> \\\\+    decEscBP' = (W_bslash,) >$< charBP >*< decEscBP+    bsEscBP'  = P.condB (== W_dquote) bsEscBP+              $ P.condB (== W_bslash) bsEsc''' bsEsc''+    bsEsc''   = (W_bslash,) . (W_bslash,)+            >$< charBP >*< charBP >*< charBP+    bsEsc'''  = (W_bslash,) . (W_bslash,) . (W_bslash,)+            >$< charBP >*< charBP >*< charBP >*< charBP++------------- Text encoding BoundedPrim helpers++charBP :: P.BoundedPrim Word8+{-# INLINE charBP #-}+charBP = P.liftFixedToBounded P.word8++bsEscBP :: P.BoundedPrim Word8+{-# INLINE bsEscBP #-}+bsEscBP = (W_bslash,) >$< charBP >*< charBP++decEscBP :: P.BoundedPrim Word8+{-# INLINE decEscBP #-}+decEscBP = P.condB (> 99) dec3 $ P.condB (> 9) dec2 dec1+  where+    dec3 = (W_bslash,)+       >$< charBP >*< P.word8Dec+    dec2 = (W_bslash,) . (W_0,)+       >$< charBP >*< charBP >*< P.word8Dec+    dec1 = ((W_bslash, W_0),) . (W_0,)+       >$< (charBP >*< charBP) >*< (charBP >*< P.word8Dec)+    {-# INLINE dec3 #-}+    {-# INLINE dec2 #-}+    {-# INLINE dec1 #-}++pattern W_space  :: Word8;      pattern W_space  = 0x20+pattern W_dquote :: Word8;      pattern W_dquote = 0x22+pattern W_dollar :: Word8;      pattern W_dollar = 0x24+pattern W_open   :: Word8;      pattern W_open   = 0x28+pattern W_close  :: Word8;      pattern W_close  = 0x29+pattern W_comma  :: Word8;      pattern W_comma  = 0x2c+pattern W_0      :: Word8;      pattern W_0      = 0x30+pattern W_semi   :: Word8;      pattern W_semi   = 0x3b+pattern W_at     :: Word8;      pattern W_at     = 0x40+pattern W_A      :: Word8;      pattern W_A      = 0x41+pattern W_bslash :: Word8;      pattern W_bslash = 0x5c+pattern W_delete :: Word8;      pattern W_delete = 0x7f++-----++-- | Supports UTF8 character strings, which are presented like all other+-- character strings, but must be valid UTF8 on the wire, and when unescaped+-- from presentation form.+newtype DnsUtf8Text = DnsUtf8Text T.Text+    deriving (Eq, Ord, Show)++instance Presentable DnsUtf8Text where+    present t = \ k ->+        B.word8 W_dquote+        <> encodeUtf8CharString (coerce t)+        <> B.word8 W_dquote+        <> k++-- | Support for escaping all non-special characters+-- Based on 'T.encodeUtf8BuilderEscaped'+encodeUtf8CharString :: T.Text -> B.Builder+encodeUtf8CharString = \txt -> B.builder (mkBuildstep txt)+  where+    printable = \w -> w >= W_space && w < W_delete+    bp = P.condB printable sp decEscBP+    sp = P.condB special bsEscBP charBP+    special = \ case+        W_dquote -> True+        W_bslash -> True+        _        -> False+    bound = P.sizeBound bp++    mkBuildstep :: T.Text -> B.BuildStep r -> B.BuildStep r+    mkBuildstep (T.Text arr off len) !k =+        outerLoop off+      where+        iend = off + len++        outerLoop !i0 !br@(B.BufferRange op0 ope)+          | i0 >= iend       = k br+          | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining)+          | otherwise        = return $ B.bufferFull bound op0 (outerLoop i0)+          where+            outRemaining = (ope `minusPtr` op0) `quot` bound+            inpRemaining = iend - i0++            goPartial !iendTmp = go i0 op0+              where+                go !i !op+                  | i < iendTmp = do+                    let w = TA.unsafeIndex arr i+                    P.runB bp w op >>= go (i + 1)+                  | otherwise = outerLoop i (B.BufferRange op ope)
+ internal/Net/DNSBase/Internal/Transport.hs view
@@ -0,0 +1,291 @@+-- |+-- Module      : Net.DNSBase.Internal.Transport+-- Description : UDP/TCP query transport, retry, and TCP fallback+-- Copyright   : (c) IIJ Innovation Institute Inc., 2009+--               (c) Viktor Dukhovni, 2020-2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Internal.Transport+    ( lookupRawCtl_+    ) where++import qualified Data.IP as IP+import Control.Exception (bracket)+import Network.Socket (AddrInfo(..), SockAddr(..), Family(AF_INET, AF_INET6))+import Network.Socket (Socket, SocketType(Stream) , close, socket, connect)+import Network.Socket (defaultProtocol)+import System.IO.Error (annotateIOError)+import System.Timeout (timeout)+import Time.System (timeCurrent)+import Time.Types (Elapsed(..), Seconds(..))++import Net.DNSBase.Decode.Internal.Message+import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.EDNS+import Net.DNSBase.Internal.Error+import Net.DNSBase.Internal.Flags+import Net.DNSBase.Internal.Message+import Net.DNSBase.Internal.RCODE+import Net.DNSBase.Internal.RRCLASS+import Net.DNSBase.Internal.RRTYPE+import Net.DNSBase.Internal.SockIO+import Net.DNSBase.Internal.Util+import Net.DNSBase.Resolver.Internal.Encoding+import Net.DNSBase.Resolver.Internal.Types++-- | Check response for a matching identifier and question.  If we ever do+-- pipelined TCP, we'll need to handle out of order responses.  See:+-- https://tools.ietf.org/html/rfc7766#section-7+--+checkResp :: DnsTriple -> QueryID -> DNSMessage -> Bool+checkResp q qid = isNothing . checkRespM q qid++-- When the response @RCODE@ is @FORMERR@, the server did not understand our+-- query packet, and so is not expected to return a matching question.+--+checkRespM :: DnsTriple -> QueryID -> DNSMessage -> Maybe DNSError+checkRespM q qid DNSMessage{..}+  | dnsMsgId /= qid = Just $ ProtocolError SequenceNumberMismatch+  | FORMERR <- dnsMsgRC+  , []        <- dnsMsgQu    = Nothing+  | [q] /= dnsMsgQu          = Just $ ProtocolError QuestionMismatch+  | otherwise                = Nothing++----------------------------------------------------------------++type Retries = Int+type Timeout = Int++type TcpLookup = Timeout -> DnsTriple -> QueryControls -> ResolvSeed -> DNSIO DNSMessage+type UdpLookup = Retries -> TcpLookup++timeout' :: Timeout -> DNSIO a -> DNSIO (Maybe a)+timeout' tmout act = ExceptT $ sequenceA <$> (timeout tmout $ runExceptT act)++bracket' :: DNSIO a -> (a -> IO b) -> (a -> DNSIO c) -> DNSIO c+bracket' get end act = ExceptT $ bracket (runExceptT get) end' act'+  where+    end' = \case+      Left _ -> return ()+      Right x -> void $ end x+    act' = \case+      Left err -> return $ Left err+      Right x  -> runExceptT $ act x++-- In lookup loop, we try UDP until we get a response.  If the response+-- is truncated, we try TCP once, with no further UDP retries.+--+-- For now, we optimize for low latency high-availability caches+-- (e.g.  running on a loopback interface), where TCP is cheap+-- enough.  We could attempt to complete the TCP lookup within the+-- original time budget of the truncated UDP query, by wrapping both+-- within a a single 'timeout' thereby staying within the original+-- time budget, but it seems saner to give TCP a full opportunity to+-- return results.  TCP latency after a truncated UDP reply will be+-- atypical.+--+-- Future improvements might also include support for TCP on the+-- initial query.+--+-- This function merges the query flag overrides from the resolver+-- configuration with any additional overrides from the caller.+--+-- | Internal entry-point used by the public IO+Either wrappers in+-- "Net.DNSBase.Lookup".  Stays in 'DNSIO' because the inner pipeline+-- (socket bracketing, timeouts, retry, TCP fallback) composes cleanly+-- in @'ExceptT' 'DNSError' 'IO'@.+lookupRawCtl_ :: Resolver -> QueryControls -> Domain -> RRCLASS -> RRTYPE -> DNSIO DNSMessage+lookupRawCtl_ Resolver{..} qctls dom qclass qtype+  | isIllegalQT qtype = throwE $ UserError $ InvalidQueryType qtype+  | otherwise = case seedServers resolvSeed of+      ns :| [] -> resolveOne ns gen retry tmout q ctls resolvSeed+      nss      -> resolveSeq nss gen retry tmout q ctls resolvSeed+  where+    gen            = fmap fromIntegral resolvRng+    conf           = seedConfig resolvSeed+    tmout          = rcTimeout conf+    retry          = rcRetries conf+    ctls           = qctls <> rcQryCtls conf+    q              = DnsTriple dom qtype qclass++    isIllegalQT (RRTYPE 0) = True+    isIllegalQT AXFR = True+    isIllegalQT IXFR = True+    isIllegalQT RRSIG = True+    isIllegalQT OPT = True+    isIllegalQT typ = typ >= NXNAME && typ < MAILB+++resolveSeq :: NonEmpty Nameserver -> IO QueryID -> UdpLookup+resolveSeq nss gen retry tmout q qctls seed = loop nss+  where+    loop (ns :| []) = resolveOne ns gen retry tmout q qctls seed+    loop (ns :| ns' : rest) =+        resolveOne ns gen retry tmout q qctls seed+            `catchE` const (loop (ns' :| rest))++-- UDP attempts must use the same ID and accept delayed answers+-- but we use a fresh ID for each TCP lookup.+--+resolveOne :: Nameserver -> IO QueryID -> UdpLookup+resolveOne ns gen retry tmout q qctls seed = do+    ident <- lift gen+    udpLookup ns ident retry tmout q qctls seed++----------------------------------------------------------------++ioErrorToDNSError :: Nameserver -> String -> DNSError -> DNSIO DNSMessage+ioErrorToDNSError ns protoName = \case+    NetworkError (NetworkFailure err) ->+      let loc  = protoName ++ "@" ++ show ns+          err' = annotateIOError err loc Nothing Nothing+       in throwE $ NetworkError $ NetworkFailure err'+    err -> throwE err++----------------------------------------------------------------++udpOpen :: AddrInfo -> DNSIO Socket+udpOpen ai = lift $ do+    sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)+    connect sock (addrAddress ai)+    return sock++-- | Enabled unless explicitly disabled.+hasEDNS :: QueryControls -> Bool+hasEDNS EdnsDisabled = False+hasEDNS _            = True++-- | Perform a UDP lookup, retrying over TCP on TC=1 or without EDNS on FORMERR.+--+-- XXX: With multiple available IP endpoints, the retry strategy is suboptimal,+-- we should try another server before trying the same server again!+--+udpLookup :: Nameserver -> QueryID -> UdpLookup+udpLookup ns ident retry tmout q qctls seed =+    case encodeQuestion ident qctls q of+      Left err -> throwE err+      Right qry -> do+        flip catchE (ioErrorToDNSError ns "udp") $+            bracket' do udpOpen (nsAddr ns)+                     do close+                     do \sock -> loop sock 0 qry qctls+  where+    loop sock !ntries qry ctls+      | ntries == retry = throwE $ NetworkError RetryLimitExceeded+      | otherwise       = do+          mres <- timeout' tmout (sendUDP sock qry >> getAns ctls sock)+          case mres of+              Nothing  -> loop sock (ntries + 1) qry ctls+              Just res -> do+                      let fl = dnsMsgFl res+                          tc = hasAnyFlags TCflag fl+                          rc = dnsMsgRC res+                          eh = dnsMsgEx res+                          cs = EdnsDisabled <> ctls+                      if | tc -> tcpLookup ns ident tmout q qctls seed+                         | rc == FORMERR && isNothing eh && hasEDNS ctls+                         , False <- hasAnyFlags DOflag $ makeQueryFlags qctls+                         , Right qry' <- encodeQuestion ident cs q+                            -- Retry without EDNS when DNSSEC was not requested+                            -- and a non-EDNS response to an EDNS query+                            -- returned FORMERR.+                         -> loop sock ntries qry' cs+                         | otherwise -> pure res++    -- | Closed UDP ports are occasionally re-used for a new query, with+    -- the nameserver returning an unexpected answer to the wrong socket.+    -- Such answers should be simply dropped, with the client continuing+    -- to wait for the right answer, without resending the question.+    -- Note, this eliminates sequence mismatch as a UDP error condition,+    -- instead we'll time out if no matching answer arrives.+    --+    getAns :: QueryControls -> Socket -> DNSIO DNSMessage+    getAns ctls sock = do+        bs <- receiveUDP maxsz sock+        msg <- decodeMsg bs seed DnsOverUDP ns+        if | checkResp q ident msg -> pure msg+           | otherwise             -> getAns ctls sock+      where+        maxsz | EdnsDisabled   <- ctls = minUdpSize+              | EdnsUdpSize sz <- ctls = sz+              | otherwise = ednsUdpSize defaultEDNS++----------------------------------------------------------------++-- Create a TCP socket with the given socket address.+tcpOpen :: SockAddr -> DNSIO Socket+tcpOpen peer = case peer of+    SockAddrInet{}  -> lift $ socket AF_INET  Stream defaultProtocol+    SockAddrInet6{} -> lift $ socket AF_INET6 Stream defaultProtocol+    _               -> throwE $ NetworkError ServerFailure++-- Perform a DNS query over TCP, if we were successful in creating+-- the TCP socket.+-- This throws DNSError only.+tcpLookup :: Nameserver -> QueryID -> TcpLookup+tcpLookup ns ident tmout q qctls seed =+    flip catchE (ioErrorToDNSError ns "tcp") $ do+        res <- bracket' do tcpOpen $ addrAddress $ nsAddr ns+                        do close+                        do perform qctls+        let rc = dnsMsgRC res+            eh = dnsMsgEx res+            cs = EdnsDisabled <> qctls+        -- If we first tried with EDNS, retry without on FORMERR.+        -- XXX: Move the retry into "perform", where we can reuse+        -- the same connection.+        if | rc == FORMERR && isNothing eh+           , EdnsEnabled <- qctls+             -> bracket' (tcpOpen addr) close (perform cs)+           | otherwise+             -> pure res+  where+    addr = addrAddress $ nsAddr ns+    perform ctls sock =+        case encodeQuestionLP ident ctls q of+            Left err -> throwE err+            Right qry -> do+                mres <- timeout' tmout $ do+                    lift $ connect sock addr+                    sendTCP sock qry+                    receiveTCP sock+                case mres of+                    Nothing -> throwE $ NetworkError TimeoutExpired+                    Just bs -> do+                        msg <- decodeMsg bs seed DnsOverTCP ns+                        maybe (pure msg) throwE $ checkRespM q ident msg++decodeMsg :: ByteString+          -> ResolvSeed+          -> DnsXprt+          -> Nameserver+          -> DNSIO DNSMessage+decodeMsg bs seed dnsPeerXprt ns@(addrAddress . nsAddr -> SockAddrInet sin_port sin_addr) = do+    Elapsed (Seconds now) <- lift timeCurrent+    either throwE pure $ decodeAtWith now True dec bs+  where+    dnsPeerAddr = IP.IPv4 $ IP.fromHostAddress sin_addr+    dnsPeerPort = fromIntegral sin_port+    dnsPeerName = nsName ns+    dec = local (setDecodeSource MessageSource{..})+                (getMessage (seedRDataMap seed) (seedOptionMap seed))++decodeMsg bs seed dnsPeerXprt ns@(addrAddress . nsAddr -> SockAddrInet6 sin6_port _ sin6_addr _) = do+    Elapsed (Seconds now) <- lift timeCurrent+    either throwE pure $ decodeAtWith now True dec bs+  where+    dnsPeerAddr = IP.IPv6 $ IP.fromHostAddress6 sin6_addr+    dnsPeerPort = fromIntegral sin6_port+    dnsPeerName = nsName ns+    dec = local (setDecodeSource MessageSource{..})+                (getMessage (seedRDataMap seed) (seedOptionMap seed))++decodeMsg bs seed _ _ = do+    Elapsed (Seconds now) <- lift timeCurrent+    either throwE pure $ decodeAtWith now True dec bs+  where+    dec = getMessage (seedRDataMap seed) (seedOptionMap seed)
+ internal/Net/DNSBase/Internal/Util.hs view
@@ -0,0 +1,172 @@+-- |+-- Module      : Net.DNSBase.Internal.Util+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Internal.Util+    ( (&), (.=), (<.>), (<$.>)+    , bool, cond+    , compose4+    , ByteArray(..), baToShortByteString, modifyArray+    , sbsToByteArray, sbsToMutableByteArray+    , Down(..), comparing+    , (.|.), (.&.), clearBit, countLeadingZeros, complement, setBit+    , shiftL, shiftR, testBit, unsafeShiftL, unsafeShiftR+    , (<|>), (>=>), forM, forM_, guard, join, mzero, replicateM, unless, void, when+    , lift, ExceptT(ExceptT), throwE, catchE, runExceptT, withExceptT+    , ByteString, Builder, ShortByteString(..), Text+    , Coercible, coerce+    , Int8, Int16, Int32, Int64+    , Word8, Word16, Word32, Word64, word16be, word32be, word64be, toBE+    , IP(..), IPv4, IPv6, fromIPv4w, fromIPv6b, fromIPv6w, toIPv4w, toIPv6b, toIPv6w+    , All(..), Sum(..)+    , catMaybes, fromMaybe, isJust, isNothing, listToMaybe+    , NonEmpty(..)+    , shows', showsP+    , Type, Typeable, (:~:)(..), Proxy(..), cast, teq+    , allocaBytesAligned, castPtr, copyBytes, byteSwap32+    , fillBytes, minusPtr, peek, peekElemOff, plusForeignPtr+    , unsafePerformFPIO+    ) where++import qualified Data.Primitive.ByteArray as A+import qualified Data.ByteString.Short as SB+import Control.Applicative ((<|>))+import Control.Monad ( (>=>), forM, forM_, guard, join, mzero, replicateM )+import Control.Monad ( unless, void, when )+import Control.Monad.ST (ST)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT(ExceptT), throwE, catchE, runExceptT, withExceptT)+import Data.Array.Byte (ByteArray(..), MutableByteArray(..))+import Data.Bits ((.|.), (.&.), clearBit, countLeadingZeros, complement)+import Data.Bits (setBit, shiftL, shiftR, testBit, unsafeShiftL, unsafeShiftR)+import Data.Bool (bool)+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder)+import Data.ByteString.Internal (ByteString(..), accursedUnutterablePerformIO)+import Data.ByteString.Short (ShortByteString(SBS))+import Data.Coerce (Coercible, coerce)+import Data.Function ((&))+import Data.IP (IP(..), IPv4, IPv6)+import Data.IP (fromIPv4w, fromIPv6b, fromIPv6w, toIPv4w, toIPv6b, toIPv6w)+import Data.Int (Int64, Int32, Int16, Int8)+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe)+import Data.Monoid (All(..), Sum(..))+import Data.Ord (Down(..), comparing)+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import Data.Type.Equality ((:~:)(..), testEquality)+import Data.Typeable (Typeable, cast)+import Data.Word (Word8, Word16, Word32, Word64, byteSwap16, byteSwap32, byteSwap64)+import Foreign (ForeignPtr, Ptr, allocaBytesAligned, castPtr, copyBytes)+import Foreign (fillBytes, minusPtr, peek, peekElemOff, plusForeignPtr)+import GHC.ByteOrder (ByteOrder(..), targetByteOrder)+import GHC.ForeignPtr (unsafeWithForeignPtr)+import Type.Reflection (TypeRep, pattern TypeRep)++(.=) :: Eq b => (a -> b) -> b -> (a -> Bool)+f .= (!x) = (==x).f+{-# INLINE (.=) #-}+infix 9 .=++-- | Map over a functor after composition, priority just below that of @'(.)'@.+(<.>) :: Functor m => (b -> c) -> (a -> m b) -> a -> m c+f <.> g = fmap f . g+{-# INLINE (<.>) #-}+infixr 8 <.>++-- | Right associative <$> with reduced priority.+(<$.>) :: Functor m => (a -> b) -> m a -> m b+(<$.>) = fmap+{-# INLINE (<$.>) #-}+infixr 2 <$.>++compose4 :: (e -> f) -> (a -> b -> c -> d -> e) -> (a -> b -> c -> d -> f)+f `compose4` g = \a b c d -> f $ g a b c d+{-# INLINE compose4 #-}++cond :: (a -> Bool) -> (a -> b) -> (a -> b) -> (a -> b)+cond p f g = \x -> bool g f (p x) x+{-# INLINE cond #-}++app_prec :: Int+app_prec = 10++-- | Show a constructor or function argument.+shows' :: Show a => a -> ShowS+shows' = showsPrec (app_prec + 1)++-- | Show a constructor with arguments.+showsP :: Int -> ShowS -> ShowS+showsP = showParen . (> 10)++toBE :: (a -> a) -> a -> a+toBE swap !x =+  case targetByteOrder of+    LittleEndian -> swap x+    BigEndian -> x+{-# INLINE toBE #-}++-- | Extremely unsafe, uses 'accursedUnutterablePerformIO' from+-- "Data.ByteString.Internal" and comes with all the associated caveats.+unsafePerformFPIO :: ForeignPtr a -> (Ptr a -> IO b) -> b+unsafePerformFPIO fp = accursedUnutterablePerformIO . unsafeWithForeignPtr fp+{-# INLINE unsafePerformFPIO #-}++-- | Caller must ensure the input is exactly 2-bytes long.+word16be :: ByteString -> Word16+word16be (BS fp 2) = unsafePerformFPIO fp $ \ptr -> do+    allocaBytesAligned 2 2 $ \buf -> do+        copyBytes buf ptr 2+        w16 <- peek $ castPtr buf+        pure $ toBE byteSwap16 w16+word16be _ = error "word16be invalid input"+{-# INLINE word16be #-}++-- | Caller must ensure the input is exactly 4-bytes long.+word32be :: ByteString -> Word32+word32be (BS fp 4) = unsafePerformFPIO fp $ \ptr -> do+    allocaBytesAligned 4 4 $ \buf -> do+        copyBytes buf ptr 4+        w32 <- peek $ castPtr buf+        pure $ toBE byteSwap32 w32+word32be _ = error "word32be invalid input"+{-# INLINE word32be #-}++-- | Caller must ensure the input is exactly 8-bytes long.+word64be :: ByteString -> Word64+word64be (BS fp 8) = unsafePerformFPIO fp $ \ptr -> do+    allocaBytesAligned 8 8 $ \buf -> do+        copyBytes buf ptr 8+        w64 <- peek $ castPtr buf+        pure $ toBE byteSwap64 w64+word64be _ = error "word64be invalid input"+{-# INLINE word64be #-}++----- Type equality++teq :: forall a -> forall b -> (Typeable a, Typeable b) => Maybe (a :~: b)+teq a b = testEquality (rep a) (rep b)+  where+    rep :: forall c -> Typeable c => TypeRep c+    rep _ = TypeRep+{-# INLINE teq #-}++----- Wrappers around "primitive" API++baToShortByteString :: ByteArray -> ShortByteString+baToShortByteString (ByteArray ba) = SBS ba++modifyArray :: MutableByteArray s -> Int -> (Word8 -> Word8) -> ST s ()+modifyArray marr i f = A.readByteArray marr i >>= A.writeByteArray marr i . f++sbsToByteArray :: ShortByteString -> ByteArray+sbsToByteArray (SBS ba) = (ByteArray ba)++sbsToMutableByteArray :: ShortByteString -> ST s (MutableByteArray s)+sbsToMutableByteArray sb@(SBS ba) =+    A.thawByteArray (ByteArray ba) 0 (SB.length sb)
+ internal/Net/DNSBase/RData/Internal/XNAME.hs view
@@ -0,0 +1,226 @@+-- |+-- Module      : Net.DNSBase.RData.Internal.XNAME+-- Description : Internal: shared codec for domain-valued RR types+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+--+-- The 'X_domain' newtype represents the RFC 1035 RR types whose+-- RDATA is a single domain name: 'T_ns', 'T_cname', 'T_ptr' and+-- the obsolete mailbox-pointer types 'T_md', 'T_mf', 'T_mb',+-- 'T_mg', 'T_mr'.  'T_dname' (RFC 6672) lives here too because it+-- has the same shape — a single 'Domain' — but it gets its own+-- newtype because its wire-form codec differs (no name+-- compression on encode).+--+-- The public API is in "Net.DNSBase.RData.XNAME" for the+-- non-obsolete subset and in "Net.DNSBase.RData.Obsolete" for the+-- old mailbox-pointer types.+{-# LANGUAGE+    MagicHash+  , UndecidableInstances+  #-}++module Net.DNSBase.RData.Internal.XNAME+    ( -- * Domain-name-valued RR types.+      -- ** Well-known (from RFC1035)+      X_domain(T_NS, T_CNAME, T_PTR, T_MB, T_MD, T_MF, T_MG, T_MR)+    , type XdomainConName, T_ns, T_cname, T_ptr, T_mb, T_md, T_mf, T_mg, T_mr+      -- ** @DNAME@+    , T_dname(..)+    ) where++import GHC.Exts (proxy#)+import GHC.TypeLits as TL (TypeError, ErrorMessage(..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal')++import Net.DNSBase.Decode.Internal.Domain+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.Nat16+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.RData+import Net.DNSBase.Internal.RRTYPE+import Net.DNSBase.Internal.Util++type XdomainConName :: Nat -> Symbol+type family XdomainConName n where+    XdomainConName N_ns      = "T_NS"+    XdomainConName N_cname   = "T_CNAME"+    XdomainConName N_ptr     = "T_PTR"+    XdomainConName N_md      = "T_MD"+    XdomainConName N_mf      = "T_MF"+    XdomainConName N_mb      = "T_MB"+    XdomainConName N_mg      = "T_MG"+    XdomainConName N_mr      = "T_MR"+    XdomainConName n         = TypeError+                             ( ShowType n+                               :<>: TL.Text " is not an RFC1035 domain-valued RRTYPE" )++-- | X_domain specialised to @NS@ records.+type T_ns      = X_domain N_ns+-- | X_domain specialised to @CNAME@ records.+type T_cname   = X_domain N_cname+-- | X_domain specialised to @PTR@ records.+type T_ptr     = X_domain N_ptr+-- | X_domain specialised to @MD@ records.+type T_md      = X_domain N_md+-- | X_domain specialised to @MF@ records.+type T_mf      = X_domain N_mf+-- | X_domain specialised to @MB@ records.+type T_mb      = X_domain N_mb+-- | X_domain specialised to @MG@ records.+type T_mg      = X_domain N_mg+-- | X_domain specialised to @MR@ records.+type T_mr      = X_domain N_mr++-- | Authoritative name server for a delegated zone+-- ([RFC 1035 section 3.3.11](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.11)).+pattern  T_NS :: Domain -> T_ns+pattern  T_NS d = (X_DOMAIN d :: T_ns)+{-# COMPLETE T_NS #-}+-- | Canonical-name alias for the owner name+-- ([RFC 1035 section 3.3.1](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.1)).+pattern  T_CNAME :: Domain -> T_cname+pattern  T_CNAME d = (X_DOMAIN d :: T_cname)+{-# COMPLETE T_CNAME #-}+-- | Domain-name pointer, typically used for reverse mapping+-- ([RFC 1035 section 3.3.12](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.12)).+pattern  T_PTR :: Domain -> T_ptr+pattern  T_PTR d = (X_DOMAIN d :: T_ptr)+{-# COMPLETE T_PTR #-}+-- | Mail destination+-- ([RFC 1035 section 3.3.4](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.4);+-- obsolete — use 'Net.DNSBase.RData.SRV.T_mx').+pattern  T_MD :: Domain -> T_md+pattern  T_MD d = (X_DOMAIN d :: T_md)+{-# COMPLETE T_MD #-}+-- | Mail forwarder+-- ([RFC 1035 section 3.3.5](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.5);+-- obsolete — use 'Net.DNSBase.RData.SRV.T_mx').+pattern  T_MF :: Domain -> T_mf+pattern  T_MF d = (X_DOMAIN d :: T_mf)+{-# COMPLETE T_MF #-}+-- | Mailbox domain+-- ([RFC 1035 section 3.3.3](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.3);+-- obsolete).+pattern  T_MB :: Domain -> T_mb+pattern  T_MB d = (X_DOMAIN d :: T_mb)+{-# COMPLETE T_MB #-}+-- | Mail group member+-- ([RFC 1035 section 3.3.6](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.6);+-- obsolete).+pattern  T_MG :: Domain -> T_mg+pattern  T_MG d = (X_DOMAIN d :: T_mg)+{-# COMPLETE T_MG #-}+-- | Mail rename+-- ([RFC 1035 section 3.3.8](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.8);+-- obsolete).+pattern  T_MR :: Domain -> T_mr+pattern  T_MR d = (X_DOMAIN d :: T_mr)+{-# COMPLETE T_MR #-}++-- | Shared wire-format representation for the RFC 1035 RR types+-- whose RDATA is a single domain name: @NS@+-- ([section 3.3.11](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.11)),+-- @CNAME@+-- ([section 3.3.1](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.1)),+-- @PTR@+-- ([section 3.3.12](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.12)),+-- and the obsolete mailbox-pointer types @MB@, @MD@, @MF@, @MG@,+-- @MR@ (RFC 1035 sections 3.3.3-3.3.8).  The type parameter @n@+-- (one of 'N_ns', 'N_cname', 'N_ptr', 'N_mb', 'N_md', 'N_mf',+-- 'N_mg', 'N_mr') determines the RR type.  Each has its own type+-- synonym ('T_ns', 'T_cname', ...) and matching pattern synonym+-- ('T_NS', 'T_CNAME', ...).+--+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                 DOMAINNAME                    /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- Although all these RR types share a common underlying+-- representation, the constructors are not shared and the types+-- are not mutually coercible — this is deliberate, to catch+-- RR-type confusion at compile time.+--+-- The target domain is subject to wire-form name compression on+-- encode+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- and canonicalises to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare in canonical wire form+-- (via 'equalWireHost' / 'compareWireHost'), so 'Ord' is+-- canonical.  Presentation preserves the original case.+type X_domain :: Nat -> Type+type role X_domain nominal+newtype X_domain n = X_DOMAIN Domain++instance (Nat16 n, KnownSymbol (XdomainConName n)) => Show (X_domain n) where+    showsPrec p (X_DOMAIN d) = showsP p $+        showString (symbolVal' (proxy# @(XdomainConName n))) . showChar ' '+        . shows' d++-- | Case-insensitive wire-form equality.+instance Eq (X_domain f) where+    a == b = coerce a `equalWireHost` coerce b++-- | Case-insensitive wire-form order.+instance Ord (X_domain f) where+    a `compare` b = coerce a `compareWireHost` coerce b++-- | Presentation form preserves case.+instance Presentable (X_domain f) where+    present = present @Domain . coerce++-- | Name compression used on input and output.+instance (Typeable n, Nat16 n, KnownSymbol (XdomainConName n))+    => KnownRData (X_domain n) where+    rdType _ = RRTYPE $ natToWord16 n+    {-# INLINE rdType #-}+    rdEncode = putDomain . coerce+    cnEncode = putSizedBuilder . mbWireForm . canonicalise . coerce+    rdDecode _ _ = const do+        RData . X_DOMAIN @n <$> getDomain++-- | The @DNAME@ resource record+-- ([RFC 6672 section 2.1](https://tools.ietf.org/html/rfc6672#section-2.1))+-- — redirection for a subtree of the domain-name space: a 'Domain'+-- naming the target subtree under which queries are rewritten.+--+-- The target field is not subject to wire-form name compression+-- on encode+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- but canonicalises to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare in canonical wire form+-- (via 'equalWireHost' / 'compareWireHost'), so 'Ord' is+-- canonical.  Presentation preserves the original case.+--+-- See 'X_domain' for the sibling family of RFC 1035 single-domain+-- RR types, which differ from @DNAME@ in that they do use name+-- compression on encode.+newtype T_dname = T_DNAME Domain -- ^ Target 'Domain'+    deriving (Show)++-- | Case-insensitive wire-form equality.+instance Eq T_dname where+    a == b = coerce a `equalWireHost` coerce b++-- | Case-insensitive wire-form order.+instance Ord T_dname where+    a `compare` b = coerce a `compareWireHost` coerce b++-- | Presentation form preserves case.+instance Presentable T_dname where+    present = present @Domain . coerce++-- | Name compression used on input only.+instance KnownRData T_dname where+    rdType _ = DNAME+    {-# INLINE rdType #-}+    rdEncode = putSizedBuilder . mbWireForm . coerce+    cnEncode = putSizedBuilder . mbWireForm . canonicalise . coerce+    rdDecode _ _ = const do+        RData . T_DNAME <$> getDomainNC
+ internal/Net/DNSBase/Resolver/Internal/Encoding.hs view
@@ -0,0 +1,81 @@+-- |+-- Module      : Net.DNSBase.Resolver.Internal.Encoding+-- Description : TBD+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Resolver.Internal.Encoding+    ( encodeQuestion+    , encodeQuestionLP+    ) where++import Net.DNSBase.EDNS.Internal.Option+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.EDNS+import Net.DNSBase.Internal.Error+import Net.DNSBase.Internal.Flags+import Net.DNSBase.Internal.Message+import Net.DNSBase.Internal.RData+import Net.DNSBase.Internal.Util+import Net.DNSBase.Resolver.Internal.Types++makeEDNS :: EDNS -> QueryControls -> Maybe EDNS+makeEDNS EDNS{..} ctl+    | EdnsDisabled <- ctl = Nothing+    | ver <- case ctl of { EdnsVersion vn -> vn; _ -> ednsVersion }+    , udp <- case ctl of { EdnsUdpSize sz -> sz; _ -> ednsUdpSize }+    , opt <- case ctl of { EdnsOptionCtl optf -> applyOptionCtl optf ednsOptions }+      = Just $ EDNS ver udp opt+++_encodeQuestion :: (forall s. QueryID+                -> DNSFlags+                -> Maybe EDNS+                -> DnsTriple+                -> SPut s RData)+                -> QueryID+                -> QueryControls+                -> DnsTriple+                -> Either DNSError ByteString+_encodeQuestion f = \qid qctl q ->+    let flg = makeQueryFlags qctl+        medns = makeEDNS defaultEDNS qctl+     in case encodeCompressed $ f qid flg medns q of+        Left err -> Left $ EncodeError $ EncodeContext err+        Right enc -> Right enc+++-- | Encode a DNS question for UDP using the provided 'QueryID', producing either a DNS error+-- if the encoding failed, or a 'ByteString' consisting of the wire-form DNS request.+--+-- The 'Net.DNSBase.Resolver.QueryControls' parameter can be used to modify the default values of various+-- DNS flags, as well as to configure EDNS version, UDP size, and options, or to disable+-- EDNS entirely.+--+-- The caller is responsible for generating the 'QueryID' via a securely seeded+-- CSPRNG.+encodeQuestion :: QueryID       -- ^ Crypto random request id+               -> QueryControls -- ^ Query flag and EDNS overrides+               -> DnsTriple     -- ^ Query name type and class+               -> Either DNSError ByteString+encodeQuestion = _encodeQuestion $ putRequest++-- | Encode a DNS question for TCP using the provided 'QueryID', producing either a DNS error+-- if the encoding failed, or a 'ByteString' consisting of the wire-form DNS request with+-- a 2-octet unsigned integral length prefix in network byte order.+--+-- The 'Net.DNSBase.Resolver.QueryControls' parameter can be used to modify the default values of various+-- DNS flags, as well as to configure EDNS version, UDP size, and options, or to disable+-- EDNS entirely.+--+-- The caller is responsible for generating the 'QueryID' via a securely seeded+-- CSPRNG.+encodeQuestionLP :: QueryID+                 -> QueryControls+                 -> DnsTriple+                 -> Either DNSError ByteString+encodeQuestionLP = _encodeQuestion $ passLen `compose4` putRequest
+ internal/Net/DNSBase/Resolver/Internal/Parser.hs view
@@ -0,0 +1,35 @@+-- |+-- Module      : Net.DNSBase.Resolver.Internal.Parser+-- Description : Parser for @\/etc\/resolv.conf@+-- Copyright   : (c) IIJ Innovation Institute Inc., 2009+--               (c) Viktor Dukhovni, 2020-2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+module Net.DNSBase.Resolver.Internal.Parser+    ( getDefaultNameservers+    ) where++import Control.Monad.Trans (lift)+import Data.Char (isSpace)+import Data.List (dropWhileEnd, stripPrefix, uncons)+import Data.Maybe (catMaybes)+import System.IO.Error (catchIOError)++import Net.DNSBase.Resolver.Internal.Types++-- XXX: this implementation is a WIP for completeness and should be improved ASAP+getDefaultNameservers :: FilePath -> DNSIO [NameserverSpec]+getDefaultNameservers fp = lift $ parseFile `catchIOError` (const $ return [])+  where+    parseFile :: IO [NameserverSpec]+    parseFile = catMaybes . map parseLine . lines <$> readFile fp++    parseLine :: String -> Maybe NameserverSpec+    parseLine (stripPrefix "nameserver" -> Just rest)+        | Just (h, t) <- uncons rest+        , isSpace h+        , name <- dropWhileEnd isSpace $ dropWhile isSpace t+        , not $ null name+        = Just $ NameserverSpec name Nothing+    parseLine _ = Nothing
+ internal/Net/DNSBase/Resolver/Internal/Types.hs view
@@ -0,0 +1,302 @@+-- |+-- Module      : Net.DNSBase.Resolver.Internal.Types+-- Description : Internal types for resolver configuration and handles+-- Copyright   : (c) IIJ Innovation Institute Inc., 2009+--               (c) Viktor Dukhovni, 2020-2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Resolver.Internal.Types+     (+     -- * Static resolver configuration+       ResolverConf(..)+     , NameserverConf(..)+     , NameserverSpec(..)+     , Nameserver(..)+     -- ** Derived resolver objects+     , ResolvSeed(..)+     , Resolver(..)+     , withResolver+     -- ** Resolver control structures+     , RDataMap+     , OptionMap+     , EdnsControls+     , QueryControls(+         QctlFlags+       , EdnsEnabled+       , EdnsDisabled+       , EdnsVersion+       , EdnsUdpSize+       , EdnsOptionCtl+       )+     -- * Resolver Monad+     , DNSIO+     , runDNSIO+     , liftDNS+     , makeQueryFlags+     ) where++import qualified Crypto.Random as C+import qualified Data.IORef as I+import Data.List (intercalate)+import Network.Socket (AddrInfo(..), PortNumber)++import Net.DNSBase.Decode.Internal.Option+import Net.DNSBase.EDNS.Internal.Option+import Net.DNSBase.Internal.EDNS+import Net.DNSBase.Internal.Error+import Net.DNSBase.Internal.Flags+import Net.DNSBase.Internal.RData+import Net.DNSBase.Internal.Util++-- | An opt-in monad for chaining multiple DNS operations with+-- short-circuit error handling.  The primary public API uses plain+-- @'IO' ('Either' 'DNSError' a)@; 'DNSIO' is a thin wrapper around+-- @'ExceptT' 'DNSError' 'IO'@ for users who prefer transformer-style+-- composition.  Convert between the two forms with 'runDNSIO' and+-- 'liftDNS'.+type DNSIO = ExceptT DNSError IO++-- | Run a 'DNSIO' computation and return its @'Either' 'DNSError' a@+-- result in plain 'IO'.+runDNSIO :: DNSIO a -> IO (Either DNSError a)+runDNSIO = runExceptT++-- | Lift a plain @'IO' ('Either' 'DNSError' a)@ action into 'DNSIO',+-- for combining with other 'DNSIO' steps.+liftDNS :: IO (Either DNSError a) -> DNSIO a+liftDNS = ExceptT++-- | User-supplied resolver configuration.  Carries the caller's+-- choices: where nameservers come from, the per-attempt timeout+-- and retry budget, default 'QueryControls', and any+-- user-registered RR-type / EDNS option codecs.  Built-in defaults+-- are not stored here — they are merged into the effective+-- configuration only when 'Net.DNSBase.Resolver.makeResolvSeed' produces a 'ResolvSeed'.+data ResolverConf = ResolverConf+    { rcSource    :: NameserverConf -- ^ Nameserver source: a resolver-conf file path or an explicit list.+    , rcTimeout   :: Int            -- ^ Per-attempt timeout in microseconds.+    , rcRetries   :: Int            -- ^ Maximum number of attempts, including the first.+    , rcQryCtls   :: QueryControls  -- ^ Default query-flag and EDNS controls.+    , rcRDataMap  :: RDataMap       -- ^ User-registered RR-type codecs, indexed by 'Net.DNSBase.RRTYPE.RRTYPE' code.+    , rcOptionMap :: OptionMap      -- ^ User-registered EDNS option codecs, indexed by 'Net.DNSBase.EDNS.OptNum.OptNum'.+    }++-- | Configuration file name, or explicit list of addresses/hostnames.+data NameserverConf = SourceFile FilePath+                    | HostList (NonEmpty NameserverSpec)++-- | Nameserver address string or hostname, with optional port.+--+data NameserverSpec = NameserverSpec+    { nameserverName :: String+    , nameserverPort :: Maybe PortNumber+    }++----------------------------------------------------------------++data Nameserver = Nameserver+    { nsName :: Maybe String    -- ^ Hostname when specified+    , nsAddr :: AddrInfo        -- ^ Corresponding address+    }++instance Show Nameserver where+    showsPrec _ (Nameserver {..}) =+        maybe id showString nsName+        . showChar '['+        . shows (addrAddress nsAddr)+        . showChar ']'++-- | Resolved, immutable resolver state built by 'Net.DNSBase.Resolver.makeResolvSeed'+-- from a 'ResolverConf'.  Combines the user's choices with the+-- library's built-in defaults: resolved nameserver addresses,+-- and the effective RR-type and EDNS-option codec maps with+-- user-registered code points overriding the library defaults+-- (except at a small set of protected code points, where+-- attempted user overrides are silently ignored).+--+-- A 'ResolvSeed' is safe to share across threads; each query-issuing+-- thread should call 'withResolver' on the same seed to obtain its+-- own per-thread 'Resolver' handle.+data ResolvSeed = ResolvSeed+    { seedConfig    :: ResolverConf       -- ^ Caller's original 'ResolverConf'.+    , seedRDataMap  :: RDataMap           -- ^ Effective RR-type codec map.+    , seedOptionMap :: OptionMap          -- ^ Effective EDNS option codec map.+    , seedServers   :: NonEmpty Nameserver -- ^ Resolved nameserver endpoints.+    }++-- | Internal DNS Resolver handle, obtained via 'withResolver'.+-- Must not be used concurrently in multiple threads.+--+data Resolver = Resolver+    { resolvSeed :: ResolvSeed -- ^ Used to construct the resolver+    , resolvRng  :: IO Word64  -- ^ Resolver's RNG+    }++-- | Provide a 'Resolver' to the supplied action.  Concurrent use of a+-- single 'Resolver' is /not/ supported: the handle carries internal+-- mutable state and the library makes no soundness guarantees if it+-- is shared across threads.  Programs that issue queries from+-- multiple threads must call 'withResolver' once per worker thread+-- (typically inside @forkIO@) to obtain a separate handle.  The+-- 'ResolvSeed' itself is immutable and is the right object to share+-- across threads.+--+-- The action runs in plain 'IO'; DNS-protocol errors from individual+-- lookups appear in the @'Either' 'DNSError' a@ return shape of each+-- lookup function inside the action.  This function does not itself+-- produce or propagate 'DNSError's.+withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a+withResolver resolvSeed f = do+    resolvRng <- getRandom <$> (C.drgNew >>= I.newIORef)+    f Resolver{..}+  where+    getRandom :: I.IORef C.ChaChaDRG -> IO Word64+    getRandom ref = do+        gen <- I.readIORef ref+        let (bs, gen') = C.randomBytesGenerate 8 gen+            !w = word64be bs+        w <$ I.writeIORef ref gen'++----------------------------------------------------------------++-- * Query control monoids++-- | Query controls consisting of an endomorphism over 'FlagOps' to modify+-- DNS flag bits, and an 'EdnsControls' structure to configure EDNS+-- behavior.+--+-- Constitutes a 'Monoid' with left-biased mappend operation+data QueryControls = QueryControls (FlagOps -> FlagOps) EdnsControls++instance Show QueryControls where+    showsPrec p (QueryControls fctl ectl) = showsP p $+        showString "QueryControls "+        . shows' (fctl emptyFlagOps) . showChar ' '+        . shows' ectl++instance Semigroup QueryControls where+    (QueryControls fl1 edns1) <> (QueryControls fl2 edns2) =+        QueryControls (fl1 . fl2) (edns1 <> edns2)++instance Monoid QueryControls where+    mempty = QueryControls id mempty++-- | Apply the requested DNS flag operation, setting or clearing the requested+-- flag bits, or restoring defaults.+pattern QctlFlags :: (FlagOps -> FlagOps) -- ^ Desired 'FlagOps' modifier+                  -> QueryControls+pattern QctlFlags fl <- QueryControls fl _ where+    QctlFlags fl = QueryControls fl mempty+{-# COMPLETE QctlFlags #-}++-- | Return the results of applying the flag query controls to the default+-- query flags, setting or clearing the requested flag bits.+makeQueryFlags :: QueryControls -> DNSFlags+makeQueryFlags (QctlFlags op) = applyFlagOps (op emptyFlagOps) defaultQueryFlags++-- | EDNS query controls.  When EDNS is disabled via @ednsEnabled FlagClear@,+-- all the other EDNS-related overrides have no effect. Semigroup append is+-- left-biased+data EdnsControls = EdnsControls+    (Maybe Bool)             -- ^ Enabled+    (Maybe Word8)            -- ^ Version+    (Maybe Word16)           -- ^ UDP Size+    (OptionCtl -> OptionCtl) -- ^ EDNS option list tweaks++instance Semigroup EdnsControls where+    (EdnsControls en1 vn1 sz1 od1) <> (EdnsControls en2 vn2 sz2 od2) =+        EdnsControls (en1 <|> en2) (vn1 <|> vn2) (sz1 <|> sz2) (od1 . od2)++instance Monoid EdnsControls where+    mempty = EdnsControls Nothing Nothing Nothing id++instance Show EdnsControls where+    show (EdnsControls en vn sz od) =+        _showOpts+            [ _showWord "edns.enabled" en+            , _showWord "edns.version" vn+            , _showWord "edns.udpsize" sz+            , _showOdOp "edns.options" $ show+                                       $ od emptyOptionCtl ]+      where+        _showOpts :: [String] -> String+        _showOpts os = intercalate "," $ filter (not . null) os++        _showWord :: Show a => String -> Maybe a -> String+        _showWord nm w = maybe "" (\s -> nm ++ ":" ++ show s) w++        _showOdOp :: String -> String -> String+        _showOdOp nm os = case os of+            "" -> ""+            _  -> nm ++ ":" ++ os++-- | Enable EDNS for this query, overriding the resolver default+-- if it had EDNS disabled.  The OPT pseudo-RR is included in the+-- outgoing query.+pattern EdnsEnabled :: QueryControls+pattern EdnsEnabled <-+    QueryControls _ (EdnsControls (Just True) _ _ _) where+    EdnsEnabled = QueryControls id (EdnsControls (Just True) Nothing Nothing id)++-- | Disable EDNS for this query.  When EDNS is disabled, the OPT+-- pseudo-RR is omitted from the outgoing query and the other+-- EDNS-related tweaks ('EdnsVersion', 'EdnsUdpSize',+-- 'EdnsOptionCtl') have no effect on the wire.+pattern EdnsDisabled :: QueryControls+pattern EdnsDisabled <-+    QueryControls _ (EdnsControls (Just False) _ _ _) where+    EdnsDisabled = QueryControls id (EdnsControls (Just False) Nothing Nothing id)++-- | Override the EDNS version advertised in the OPT pseudo-RR+-- for this query.  Only version @0@ is specified, and versions+-- other than @0@ are unlikely to be interoperable at present.+pattern EdnsVersion :: Word8 -- ^ Desired version+                    -> QueryControls+pattern EdnsVersion vn <-+    QueryControls _ (EdnsControls _ (Just vn) _ _) where+    EdnsVersion vn = QueryControls id (EdnsControls Nothing (Just vn) Nothing id)++-- | Override the maximum UDP payload size the client advertises+-- to the server for this query.  The value is clamped to the+-- 'minUdpSize' / 'maxUdpSize' range.+pattern EdnsUdpSize :: Word16 -- ^ Desired size+                    -> QueryControls+pattern EdnsUdpSize sz <-+    QueryControls _ (EdnsControls _ _ (Just sz) _) where+    EdnsUdpSize sz = QueryControls id (EdnsControls Nothing Nothing (Just capped) id)+      where+        !capped = max minUdpSize . min maxUdpSize $ sz++-- | Carry a per-call modification of the OPT pseudo-RR's EDNS+-- option list as an endomorphism @'OptionCtl' -> 'OptionCtl'@.+-- The endomorphism is applied to the resolver's ambient option+-- list at query-build time, so callers express deltas — clear+-- everything, add an option, replace an option — rather than full+-- replacements.+--+-- 'optCtlAdd' and 'optCtlSet' are the standard ways to build the+-- endomorphism.  For example, to opt out of geolocation-tailored+-- answers for a single query by signalling \"do not use my+-- subnet\" via ECS with a zero-length source prefix+-- ([RFC 7871 section 7.1.2](https://datatracker.ietf.org/doc/html/rfc7871#section-7.1.2)):+--+-- > let noEcs = EdnsOptionCtl+-- >           $ optCtlAdd [ EdnsOption+-- >                       $ O_ECS 0 0 (IPv4 (toIPv4 [0,0,0,0])) ]+-- >  in lookupAnswers rslv noEcs IN A $$(dnLit8 "example.org")+--+-- 'optCtlAdd' replaces the resolver's existing ECS option (if+-- any) with this one because they share an @OPTCODE@; other+-- options the resolver had configured pass through untouched.+-- 'optCtlSet' would instead clear the entire option list and use+-- only the supplied options.+pattern EdnsOptionCtl :: (OptionCtl -> OptionCtl)+                         -- ^ Selected modifier: optCtlAdd, ...+                      -> QueryControls+pattern EdnsOptionCtl omod <-+    QueryControls _ (EdnsControls _ _ _ omod) where+    EdnsOptionCtl omod = QueryControls id (EdnsControls Nothing Nothing Nothing omod)+{-# COMPLETE EdnsOptionCtl #-}
+ src/Net/DNSBase.hs view
@@ -0,0 +1,297 @@+{-# OPTIONS_GHC -Wno-duplicate-exports #-}+{-|+Module      : Net.DNSBase+Description : DNS Stub resolver+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++A DNS stub-resolver library with a typed 'RData' model and a+runtime extension API.  The IO layer is derived from Kazu+Yamamoto's [@dns@](https://hackage.haskell.org/package/dns)+package; what @dnsbase@ layers on top sits in the RR-data model+and the configuration story.++Every RR type's payload is modeled via a dedicated Haskell type+— these include, for example, the recent SVCB \/ HTTPS+service-binding records, with up-to-date extensible SvcParam+coverage.  EDNS option support includes Extended DNS Errors+(EDE) with a user-extensible info-code name table.  Coverage of+both widely used and historical DNS RR types is comprehensive —+only the most marginal obsolete or experimental types remain+unimplemented.  Individual payloads are held uniformly inside+the existential 'RData' wrapper, so an 'RR' value can carry any+type's data.++The basic lookup interface ('lookupA', 'lookupMX', 'lookupTXT',+…) is deliberately similar to @dns@; the differences are+concentrated in the typed-data layer and the configuration+surface.++== Extending the library++Applications can extend the library with any /missing/ RRTYPEs,+EDNS(0) options, or SVCB and HTTPS service parameter values.+Application-specified data types take precedence over any existing+or later added built-in implementations.++Extensions are registered by constructing a pure resolver+configuration value, rather than via IO actions on mutable+global state.  Adding custom data types to the library does not+require a source-code fork.  See+[Adding a custom RR type]("Net.DNSBase.Extensible#customRRtype")+and+[Adding a custom EDNS option]("Net.DNSBase.Extensible#customEDNS")+for detailed examples.++== Concurrency++Like its @dns@ ancestor, @dnsbase@ scales well to thousands of+@forkIO@ threads, with throughput of around ten thousand+distinct queries (not even cache hits) per second observed when+given sufficient concurrency, a high file descriptor limit and+a cooperative upstream iterative resolver.++A single 'ResolvSeed' configuration can be used to derive+per-thread 'Resolver' instances via 'withResolver'.  As in+@dns@, concurrent use of the same 'Resolver' in multiple+threads is not supported.++== A minimal example++> import Net.DNSBase+> import Control.Exception (throwIO)+> import System.IO (stdout)+>+> main :: IO ()+> main = makeResolvSeed defaultResolvConf >>= \ case+>   Left  e    -> throwIO e+>   Right seed -> withResolver seed \ r ->+>     lookupMX r $$(dnLit8 "ietf.org") >>= \ case+>       Left  e   -> throwIO e+>       Right mxs -> hPutBuilder stdout $ foldr presentLn mempty mxs++'makeResolvSeed' builds a 'ResolvSeed' from a 'ResolverConf'; the+default reads @\/etc\/resolv.conf@.  The setters:++* 'setResolverConfTimeout'+* 'setResolverConfRetries'+* 'setResolverConfSource'+* 'setResolverConfQueryControls'++compose with 'defaultResolvConf' to override individual fields.++Inside a 'withResolver' block the per-RRtype lookup combinators,+such as:++* 'lookupA'+* 'lookupAAAA'+* 'lookupMX'+* 'lookupTXT'+* 'lookupNS'+* 'lookupDS'++each return a list of matching records.  Applications that want+to process the full 'DNSMessage' response can use 'lookupRaw'+or 'lookupRawCtl'.++The 'dnLit' and 'dnLit8' Template-Haskell splices make it+possible to validate a literal domain name at compile time.+The @idna2008@ package provides compatible parsers for Unicode+internationalised domain names (IDNs).++== Module tour++This all-in-one module re-exports almost the entire public API.+Specific topics are covered in:++* Resolver setup and queries — "Net.DNSBase.Resolver",+  "Net.DNSBase.Lookup".+* Domain names — "Net.DNSBase.Domain".+* Resource-record types and the 'RData' wrapper —+  "Net.DNSBase.RR", "Net.DNSBase.RData",+  "Net.DNSBase.RRTYPE", "Net.DNSBase.RRCLASS".+* Address records — "Net.DNSBase.RData.A".+* Name-valued records (CNAME, NS, PTR, etc.) —+  "Net.DNSBase.RData.XNAME".+* Mail and service records (SOA, RP, MX, SRV, NAPTR, etc.) —+  "Net.DNSBase.RData.SOA", "Net.DNSBase.RData.SRV".+* Service-binding records (SVCB, HTTPS) —+  "Net.DNSBase.RData.SVCB".+* DNSSEC (DS, DNSKEY, RRSIG, etc.) and denial of existence+  (NSEC, NSEC3, …) — "Net.DNSBase.RData.Dnssec",+  "Net.DNSBase.RData.NSEC".+* DANE certificate bindings (TLSA, SMIMEA, SSHFP, OPENPGPKEY)+  — "Net.DNSBase.RData.TLSA".+* Other RR types (TXT, CAA, CSYNC, etc.) — the corresponding+  @Net.DNSBase.RData.*@ submodules.+* EDNS options —+  "Net.DNSBase.EDNS", "Net.DNSBase.EDNS.Option" and the+  per-option submodules.+* DNS message structure — "Net.DNSBase.Message".+* Extending the library at runtime —+  "Net.DNSBase.Extensible" (long-form guide),+  "Net.DNSBase.Resolver" (the @register@ and @extend@+  combinators).++-}++module Net.DNSBase+    ( -- * Resolver setup+      -- ** Static resolver configuration+       ResolverConf+     , defaultResolvConf+     , NameserverConf(..)+     , NameserverSpec(..)+      -- ** Resolver seeds+     , ResolvSeed+     , makeResolvSeed+     -- ** Derived resolver objects+     , Resolver(..)+     , withResolver+      -- * Queries+    , Lookup+    , extractAnswers+    , lookupRaw+    , lookupRawCtl+    , lookupAnswers+    , lookupA+    , lookupAAAA+    , lookupMX+    , lookupNS+    , lookupCNAME+    , lookupPTR+    , lookupTXT+    , lookupSOA+    , lookupSRV+    , lookupTLSA+    , lookupHTTPS+      -- * Domain names+    , Domain(..)+    , dnLit+    , decodePresentationDomain+    , dnLit8+    , makeDomain8+    , makeDomain8Str+    , shortBytes+    , wireToDomain+      -- * Resource records, RData, and messages+    , RR(..)+    , DnsTriple(..)+    , RData+    , fromRData+    , RRTYPE+    , RRCLASS+    , DNSMessage+    , DNSError(..)+      -- * Common resource record types+    , T_a(..)+    , T_aaaa(..)+    , T_mx(..)+    , T_srv(..)+    , T_txt(..)+    , T_ptr+    , pattern T_PTR+    , T_https+    , pattern T_HTTPS+      -- * Query and EDNS controls+    , QueryControls(QctlFlags, EdnsEnabled, EdnsDisabled, EdnsUdpSize, EdnsOptionCtl)+    , pattern RDflag+    , pattern ADflag+    , pattern CDflag+    , pattern DOflag+    , setFlagBits+    , clearFlagBits+      -- * Extending the library+    , KnownRData+    , registerRRtype+    , extendRRwithType+    , extendRRwithValue+    , KnownEdnsOption+    , registerEdnsOption+    , extendEdnsOptionWithType+    , extendEdnsOptionWithValue+    , KnownSVCParamValue+    , TypeExtensible(..)+    , ValueExtensible(..)+      -- * Chained-composition opt-in+    , DNSIO+    , runDNSIO+    , liftDNS+      -- * Reference: all re-exported modules+    , module Net.DNSBase.Domain+    , module Net.DNSBase.EDNS+    , module Net.DNSBase.EDNS.OptNum+    , module Net.DNSBase.EDNS.Option+    , module Net.DNSBase.EDNS.Option.ECS+    , module Net.DNSBase.EDNS.Option.EDE+    , module Net.DNSBase.EDNS.Option.NSID+    , module Net.DNSBase.EDNS.Option.Opaque+    , module Net.DNSBase.EDNS.Option.Secalgs+    , module Net.DNSBase.Error+    , module Net.DNSBase.Flags+    , module Net.DNSBase.Lookup+    , module Net.DNSBase.Message+    , module Net.DNSBase.NonEmpty+    , module Net.DNSBase.Opcode+    , module Net.DNSBase.RCODE+    , module Net.DNSBase.RData+    , module Net.DNSBase.RData.A+    , module Net.DNSBase.RData.CAA+    , module Net.DNSBase.RData.CSYNC+    , module Net.DNSBase.Bytes+    , module Net.DNSBase.Present+    , module Net.DNSBase.RData.Dnssec+    , module Net.DNSBase.RData.NSEC+    , module Net.DNSBase.RData.SOA+    , module Net.DNSBase.RData.SRV+    , module Net.DNSBase.RData.SVCB+    , module Net.DNSBase.RData.TLSA+    , module Net.DNSBase.RData.TXT+    , module Net.DNSBase.RData.XNAME+    , module Net.DNSBase.Resolver+    , module Net.DNSBase.RR+    , module Net.DNSBase.RRCLASS+    , module Net.DNSBase.RRTYPE+    , module Net.DNSBase.Secalgs+    , module Net.DNSBase.Text+    ) where++import Net.DNSBase.Bytes+import Net.DNSBase.Domain+import Net.DNSBase.EDNS+import Net.DNSBase.EDNS.OptNum+import Net.DNSBase.EDNS.Option+import Net.DNSBase.EDNS.Option.ECS+import Net.DNSBase.EDNS.Option.EDE+import Net.DNSBase.EDNS.Option.NSID+import Net.DNSBase.EDNS.Option.Opaque+import Net.DNSBase.EDNS.Option.Secalgs+import Net.DNSBase.Error+import Net.DNSBase.Extensible+import Net.DNSBase.Flags+import Net.DNSBase.Lookup+import Net.DNSBase.Message+import Net.DNSBase.NonEmpty+import Net.DNSBase.Opcode+import Net.DNSBase.Present+import Net.DNSBase.RCODE+import Net.DNSBase.RData+import Net.DNSBase.RData.A+import Net.DNSBase.RData.CAA+import Net.DNSBase.RData.CSYNC+import Net.DNSBase.RData.Dnssec+import Net.DNSBase.RData.NSEC+import Net.DNSBase.RData.SOA+import Net.DNSBase.RData.SRV+import Net.DNSBase.RData.SVCB+import Net.DNSBase.RData.TLSA+import Net.DNSBase.RData.TXT+import Net.DNSBase.RData.XNAME+import Net.DNSBase.Resolver+import Net.DNSBase.RR+import Net.DNSBase.RRCLASS+import Net.DNSBase.RRTYPE+import Net.DNSBase.Secalgs+import Net.DNSBase.Text
+ src/Net/DNSBase/Bytes.hs view
@@ -0,0 +1,25 @@+{-|+Module      : Net.DNSBase.Bytes+Description : Newtype wrappers tagging byte strings with a presentation encoding+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++Three identical 'ShortByteString' wrappers that differ only in+their 'Net.DNSBase.Present.Presentable' instance: 'Bytes16'+renders as hex, 'Bytes32' as base32, 'Bytes64' as base64.  Used+inside RR data types to tag a field with the encoding the+zone-file syntax expects, so that a single+'Net.DNSBase.Present.present' call produces the conventional+representation without each call site having to pick the encoder.+-}++module Net.DNSBase.Bytes+    ( -- * Short ByteStrings elements that are presented encoded+      Bytes16(..)+    , Bytes32(..)+    , Bytes64(..)+    ) where++import Net.DNSBase.Internal.Bytes
+ src/Net/DNSBase/Decode/Domain.hs view
@@ -0,0 +1,24 @@+{-|+Module      : Net.DNSBase.Decode.Domain+Description : Wire-form domain decoders (compression-aware and compression-free)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++Two 'Net.DNSBase.Decode.State.SGet' actions for reading a+'Net.DNSBase.Domain.Domain' from wire form: 'getDomain' follows+DNS name-compression pointers ([RFC 1035 section+4.1.4](https://datatracker.ietf.org/doc/html/rfc1035#section-4.1.4))+for RR types that allow compressed names on input; 'getDomainNC'+rejects compression pointers, for RR types that forbid them (such+as RRSIG's signer name and the SVCB target).+-}++module Net.DNSBase.Decode.Domain+    ( -- * Read domain names from wire messages+      getDomain+    , getDomainNC+    ) where++import Net.DNSBase.Decode.Internal.Domain
+ src/Net/DNSBase/Decode/State.hs view
@@ -0,0 +1,62 @@+{-|+Module      : Net.DNSBase.Decode.State+Description : Wire-form decoder monad and primitive byte/sequence decoders+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 'SGet' decoder monad for parsing DNS wire-form data, plus the+primitive readers ('get8', 'get16', 'get32', ...), DNS-style+helpers ('getDnsTime', 'getIPv4', 'getIPv6'), length-prefixed+byte-string readers, and the sequence and sandboxing combinators+('getVarWidthSequence', 'fitSGet', 'seekSGet').  Used by authors+of 'Net.DNSBase.RData.KnownRData' and+'Net.DNSBase.EDNS.Option.KnownEdnsOption' instances to implement the+value-side decoding; most applications will not use this module+directly.+-}++module Net.DNSBase.Decode.State+    (+    -- * DNS message element parser+      SGet+    -- * Internal state accessors+    , getPosition+    , getChrono+    -- * Generic low-level decoders+    , get8+    , get16+    , get32+    , get64+    , getInt8+    , getInt16+    -- * DNS-specific low-level decoders+    , getIPv4+    , getIPv4Net+    , getIPv6+    , getIPv6Net+    , getDnsTime+    -- * Octet-string decoders+    , skipNBytes+    , getNBytes+    , getShortByteString+    , getShortNByteString+    , getShortByteStringLen8+    , getShortByteStringLen16+    , getUtf8Text+    , getUtf8TextLen8+    , getUtf8TextLen16+    -- * Sequence decoders+    , getVarWidthSequence+    , getFixedWidthSequence+    -- * Decoder sandboxing+    , seekSGet+    , fitSGet+    -- * Decoder failure+    , failSGet+    -- * Decoder driver+    , decodeAtWith+    ) where++import Net.DNSBase.Decode.Internal.State
+ src/Net/DNSBase/Domain.hs view
@@ -0,0 +1,600 @@+{-|+Module      : Net.DNSBase.Domain+Description : Domain/mailbox name data-type+Copyright   : (c) Viktor Dukhovni, 2020-2026+              (c) Peter Duchovni, 2020+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 'Domain' data type represents the /wire form/ of DNS domain+names or mailbox names.  The internal representation is not+exposed, but is basically a 'ShortByteString' containing a+sequence of length-prefixed A-labels, including a terminal empty+label.  The labels must not be longer than 63 octets, and the+total length of the /wire form/ must not exceed 255 bytes.++The distinction between domain names and mailbox names exists only+at the level of /presentation form/, and they are otherwise the+same.  The standard /presentation form/ of a 'Domain' uses @\'.\'@+as a label separator, escaping any (rare) literal @\'.\'@+characters that happen to be part of the label content, and a+terminal dot is appended to the last label.  As a matter of+convenience, this module introduces an ad hoc /mailbox+presentation form/ of a multi-label 'Domain', which uses @\'\@\'@+as the separator between the first and second labels, and any+literal @\'.\'@ characters in the first label are not escaped.  In+the mailbox presentation form, no terminal @\'.\'@ is appended to+the address.++As 'ShortByteString' values, labels are composed of arbitrary+'Word8' elements.  The only constraint is that each label is at+most 63 bytes.++This module implements Template Haskell /splices/ for literal+domain names in application source files.  Literal strings are+validated and converted to /wire form/ at compile-time.  The+IDN-aware splice (RFC 5890+, Punycode encoding of U-labels) is the+canonical 'dnLit'; the byte-level splice that accepts arbitrary+8-bit labels is available as 'dnLit8':++> let d = $$(dnLit mkDomain "m\x00fc\&nchen.example.com") :: Domain  -- IDN-aware+> let d = $$(dnLit8 "haskell.example.com") :: Domain   -- byte-level+> let m = $$(mbLit8 "some.user@example.com") :: Domain++'dnLit' takes the presentation-form parser as its first argument:+the @mkDomain@ used above comes from the companion @idna2008@+package, which is the usual choice when IDN labels are expected.+For names known to be 8-bit clean (typically just ASCII), the+'dnLit8' and 'mbLit8' splices skip IDN processing entirely.++The runtime equivalents are 'makeDomain8' and 'makeMbox8' (and+the matching 'makeDomain8Str' / 'makeMbox8Str' for 'String'+input).  They accept the RFC 1035 master-file syntax described+below and return either a 'Domain' or a 'Domain8Err' describing+why the input was rejected.++Escape handling matches RFC 1035 master-file syntax:++  * @\\C@ for any byte @C@ appends @C@ as a single byte (the byte+    after the backslash is taken literally, with one exception: a+    trailing backslash is rejected with 'D8BadEscape').+  * @\\DDD@ for three ASCII decimal digits with @DDD <= 255@+    appends the byte with that decimal value.++Validation:++  * Each label is 1..63 bytes (empty non-final labels are rejected+    as 'D8EmptyLabel'; a sole @\'.\'@ or empty input both denote+    the root domain).+  * The wire form (all labels plus the terminator) is at most 255+    bytes; an overflow is reported as 'D8WireTooLong'.+-}+{-# LANGUAGE TemplateHaskell #-}++module Net.DNSBase.Domain+    ( -- ** Domain data type+      Domain(RootDomain)+    , DnsTriple(..)+    , Host+    , fromHost+    , toHost+    , Mbox+    , fromMbox+    , toMbox+    -- ** Domain and mailbox name literals+    , dnLit+    , mbLit+    , dnLit8+    , mbLit8+    -- ** Conversions+    -- *** Validating import from wire form+    , wireToDomain+    -- *** From presentation form with pluggable parsers+    , decodePresentationDomain+    , decodePresentationMbox+    -- *** Decoders for 8-bit presentation forms+    , Domain8Err(..)+    , makeDomain8+    , makeDomain8Str+    , makeMbox8+    , makeMbox8Str+    -- *** Canonicalisation to lower case+    , canonicalise+    -- *** Working with labels+    , appendDomain+    , consDomain+    , unconsDomain+    , labelCount+    , fromLabels+    , toLabels+    , revLabels+    , commonSuffix+    -- ** Binary serialization functions+    , mbWireForm+    , shortBytes+    , wireBytes+    -- ** Predicates+    , isLDHName+    , isLDHLabel+    -- ** Sorting and comparison+    , compareWireHost+    , equalWireHost+    , canonicalNameOrder+    , sortDomains+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Unsafe as BU+import qualified Data.Char as Ch+import qualified Language.Haskell.TH.Syntax as TH+import Control.Monad.ST (ST, runST)+import Data.Primitive.ByteArray+    ( MutableByteArray+    , copyMutableByteArray+    , newByteArray+    , unsafeFreezeByteArray+    , writeByteArray+    )++import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.Util++----------------------------------------------------------------------+-- Error type+----------------------------------------------------------------------++-- | Failure modes for the byte-level 8-bit presentation-form parser.+-- Intentionally coarse and position-free.  Callers that need richer+-- diagnostics should use the @idna2008@ parser.+data Domain8Err+    = D8LabelTooLong  -- ^ A label exceeds 63 bytes.+    | D8WireTooLong   -- ^ The wire form exceeds 255 bytes.+    | D8BadEscape     -- ^ A backslash escape is malformed: a trailing+                      --   @\\@, a truncated @\\DDD@, a non-digit in+                      --   @\\DDD@, or @\\DDD@ with value greater+                      --   than 255.+    | D8EmptyLabel    -- ^ An empty interior label (consecutive dots,+                      --   a leading dot followed by more input, or an+                      --   empty mailbox localpart with a non-empty+                      --   remainder after the unescaped @\@@).+    | D8Non8Bit       -- ^ ('String' input only) Source contained a+                      --   'Char' with codepoint above @0xFF@; the+                      --   8-bit path cannot encode it.+    | D8Non7Bit       -- ^ When parsing a mailbox presentation form, the+                      --   first label contained a non-ASCII byte.+    deriving (Eq, Show)++----------------------------------------------------------------------+-- Buffer sizes+----------------------------------------------------------------------++-- | Maximum wire form length, RFC 1035 section 3.1.+maxWireLen :: Int+maxWireLen = 255++-- | Maximum wire octets in a single label.+maxLabelLen :: Int+maxLabelLen = 63++-- | Output buffer capacity (one extra byte over 'maxWireLen' so that+-- a transient @oPos == maxWireLen@ during dot-handling does not need+-- a guard before the next iteration's read picks up the overflow).+outBufSize :: Int+outBufSize = maxWireLen + 1++----------------------------------------------------------------------+-- Public entry points+----------------------------------------------------------------------++-- | Construct a 'Domain' object directly from a /presentation form/+-- 'ByteString'.+--+-- The bytes are not treated as UTF-8 content, and IDNA processing does not+-- apply.  Backslash-escape encoding aside, each 8-bit byte in the input is+-- copied verbatim into the wire-form domain.  For Unicode IDN domain support,+-- see the parsers in the @idna2008@ package.+--+-- ==== __Example__+-- >>> import qualified Data.ByteString.Char8 as BC+-- >>> dn = makeDomain8 $ BC.pack "www.corp.acme.example"+-- >>> dn+-- Right "www.corp.acme.example."+-- >>> toLabels <$> dn+-- Right ["www","corp","acme","example"]+--+makeDomain8 :: ByteString -> Either Domain8Err Domain+makeDomain8 = fmap Domain_ . parseDomain8Wire++-- | Construct a 'Domain' object directly from a /presentation+-- form/ 'ByteString' representing a mailbox.  As a convenience to+-- users, the separator between the first and remaining labels is+-- optionally the first unescaped @\'\@\'@ character, in which+-- case prior @\'.\'@ characters in the first label do not need to+-- be escaped.+--+-- The first label must not contain any non-ASCII bytes (above 127),+-- or an error ('Left') is returned.+--+-- The 'toMbox' function can be used to coerce the resulting+-- 'Domain' to an 'Mbox' object whose presentation form uses an+-- @\'\@\'@ between the first and remaining labels and does not+-- escape dots in the first label.+--+-- ==== __Example__+-- >>> import qualified Data.ByteString.Char8 as BC+-- >>> dn = makeMbox8 $ BC.pack "john.smith@acme.example"+-- >>> dn+-- Right "john\\.smith.acme.example."+-- >>> toLabels <$> dn+-- Right ["john.smith","acme","example"]+-- >>> toMbox <$> dn+-- Right "john.smith@acme.example"+--+makeMbox8 :: ByteString -> Either Domain8Err Domain+makeMbox8 = fmap Domain_ . parseMbox8Wire++-- | Same as 'makeDomain8', but the input is a 'String', and+-- an error ('Left') is also returned if any of the input+-- string's characters are outside the 8-bit range.+--+-- Note that UTF-8 encoding of names in the Latin-1 alphabet might+-- still produce surprising results.  For parsing IDN domain names,+-- see the @idna2008@ package.+--+-- ==== __Example__+-- >>> dn = makeDomain8Str "www.corp.acme.example"+-- >>> dn+-- Right "www.corp.acme.example."+-- >>> toLabels <$> dn+-- Right ["www","corp","acme","example"]+--+makeDomain8Str :: String -> Either Domain8Err Domain+makeDomain8Str = safePack >=> fmap Domain_ . parseDomain8Wire++-- | Same as 'makeMbox8', but the input is a 'String, and+-- an error ('Left why') is also returned if any of the input+-- string's characters are outside the 8-bit range.+--+-- The first label must not contain any non-ASCII bytes (above 127),+-- or an error ('Left') is returned.+--+-- Note that UTF-8 encoding of domain names in the Latin-1 alphabet+-- might still produce surprising results.  For parsing IDN domain+-- names, see the @idna2008@ package.+--+-- ==== __Example__+-- >>> dn = makeMbox8Str "john.smith@acme.example"+-- >>> dn+-- Right "john\\.smith.acme.example."+-- >>> toLabels <$> dn+-- Right ["john.smith","acme","example"]+-- >>> toMbox <$> dn+-- Right "john.smith@acme.example"+--+makeMbox8Str :: String -> Either Domain8Err Domain+makeMbox8Str = safePack >=> fmap Domain_ . parseMbox8Wire++----------------------------------------------------------------------+-- Wire-bytes parsers (internal byte-input variants)+----------------------------------------------------------------------++-- | Shared backbone: parse a 'ByteString' in /presentation form/ and+-- return the wire-form bytes (or a 'Domain8Err').+parseDomain8Wire :: ByteString -> Either Domain8Err ShortByteString+parseDomain8Wire !bs = runST do+    outBuf <- newByteArray outBufSize+    let !inEnd = B.length bs+    res <- domainDriver bs inEnd outBuf 0 0 1+    finalise outBuf res++-- | Mailbox-form analogue of 'parseDomain8Wire'.+parseMbox8Wire :: ByteString -> Either Domain8Err ShortByteString+parseMbox8Wire !bs =+    let !inEnd = B.length bs+    in case findAt8 bs 0 inEnd of+         Nothing    -> parseDomain8Wire bs+         Just sepAt -> runST do+            outBuf <- newByteArray outBufSize+            res <- mboxDriver bs inEnd outBuf sepAt+            finalise outBuf res++----------------------------------------------------------------------+-- Template-Haskell splices for compile-time literals+----------------------------------------------------------------------++-- | Template-Haskell splice for literal 'Domain' names that are+-- validated and converted from /presentation form/ to /wire form/+-- at compile-time.  Example:+--+-- > domain :: Domain+-- > domain = $$(dnLit8 "example.org")+--+-- This is the byte-level path: it accepts any 8-bit master-file+-- text but performs no IDN processing.  For IDN-aware literals (RFC+-- 5890+, Punycode A-label encoding) use 'dnLit' with a parser from+-- the companion @idna2008@ package.+dnLit8 :: forall m. (TH.Quote m, MonadFail m) => String -> TH.Code m Domain+dnLit8 s = TH.joinCode case makeDomain8Str s of+    Left why -> fail $ "Invalid literal domain " ++ show s ++ ": " ++ show why+    Right dn -> pure (TH.liftTyped dn)++-- | Template-Haskell splice for literal mailbox names.  Example:+--+-- > mbox :: Domain+-- > mbox = $$(mbLit8 "hostmaster@example.org")+--+-- Byte-level all the way through: the localpart and the domain+-- portion are both parsed by 'makeMbox8Str', which treats the+-- input as opaque 8-bit master-file text.  For EAI/UTF-8 localpart+-- semantics use 'mbLit' with an @idna2008@-style 'Text' parser.+mbLit8 :: forall m. (TH.Quote m, MonadFail m) => String -> TH.Code m Domain+mbLit8 s = TH.joinCode case makeMbox8Str s of+    Left why -> fail $ "Invalid mailbox literal " ++ show s ++ ": " ++ show why+    Right dn -> pure (TH.liftTyped dn)++----------------------------------------------------------------------+-- Domain driver+----------------------------------------------------------------------++-- | Walk a slice of @bs@ as a presentation-form domain, writing the+-- wire form into @outBuf@ starting at length-byte position+-- @startLStart@ (so the first label's length byte goes to+-- @outBuf[startLStart]@ and its first content byte to+-- @outBuf[startLStart + 1]@).+--+-- On success returns @Right outLen@ where the terminator goes at+-- @outBuf[outLen]@ (and @finalLen = outLen + 1@); on any error+-- returns @Left e@ for the appropriate 'Domain8Err'.+--+-- The driver tracks two boundary cases via @startLStart@: a sole+-- @\'.\'@ representing the root domain, and an empty post-localpart+-- domain part in the mailbox case (e.g. @\"a\@.\"@).+domainDriver+    :: forall s+    .  ByteString+    -> Int                              -- ^ inEnd+    -> MutableByteArray s+    -> Int                              -- ^ startLStart+    -> Int                              -- ^ iPos+    -> Int                              -- ^ initial oPos == startLStart + 1+    -> ST s (Either Domain8Err Int)+domainDriver !bs !inEnd !outBuf !startLStart = go startLStart+  where+    go :: Int -> Int -> Int -> ST s (Either Domain8Err Int)+    go !lStart !iPos !oPos+      | iPos >= inEnd = endOfInput lStart oPos+      | otherwise =+          let !b = BU.unsafeIndex bs iPos+          in if | b == 0x5C -> handleEsc lStart iPos oPos+                | b == 0x2E -> handleDot lStart iPos oPos+                | otherwise -> appendByte b lStart (iPos + 1) oPos++    appendByte :: Word8 -> Int -> Int -> Int -> ST s (Either Domain8Err Int)+    appendByte !b !lStart !iPos !oPos+      | oPos - lStart > maxLabelLen = pure (Left D8LabelTooLong)+      | oPos >= maxWireLen          = pure (Left D8WireTooLong)+      | otherwise = do+          writeByteArray outBuf oPos b+          go lStart iPos (oPos + 1)++    handleEsc :: Int -> Int -> Int -> ST s (Either Domain8Err Int)+    handleEsc !lStart !iPos !oPos+      | iPos + 1 >= inEnd = pure (Left D8BadEscape)+      | otherwise =+          let !b1 = BU.unsafeIndex bs (iPos + 1)+          in case asciiDigit b1 of+               Nothing -> appendByte b1 lStart (iPos + 2) oPos+               Just !v1+                 | iPos + 4 > inEnd -> pure (Left D8BadEscape)+                 | otherwise ->+                     let !b2 = BU.unsafeIndex bs (iPos + 2)+                         !b3 = BU.unsafeIndex bs (iPos + 3)+                     in case (asciiDigit b2, asciiDigit b3) of+                          (Just v2, Just v3)+                            | n <= 0xFF ->+                                appendByte (fromIntegral n) lStart+                                           (iPos + 4) oPos+                            | otherwise -> pure (Left D8BadEscape)+                            where+                              !n =   100 * fromIntegral v1+                                  +   10 * fromIntegral v2+                                  +        fromIntegral v3 :: Int+                          _ -> pure (Left D8BadEscape)++    handleDot :: Int -> Int -> Int -> ST s (Either Domain8Err Int)+    handleDot !lStart !iPos !oPos+      | oPos == lStart + 1 =+          -- Empty label.  Acceptable only as the root domain indicator+          -- at the very start of this driver call (no label has been+          -- emitted by us yet) and only when the dot is the last+          -- input byte.  Trailing dots after a real label hit the+          -- non-empty branch on the dot itself, then the+          -- end-of-input branch on the byte after.+          if lStart == startLStart && iPos + 1 == inEnd+            then go lStart (iPos + 1) oPos+            else pure (Left D8EmptyLabel)+      | otherwise = do+          let !labelLen = oPos - lStart - 1+          writeByteArray outBuf lStart (fromIntegral labelLen :: Word8)+          let !lStart' = oPos+              !oPos'   = lStart' + 1+          go lStart' (iPos + 1) oPos'++    endOfInput :: Int -> Int -> ST s (Either Domain8Err Int)+    endOfInput !lStart !oPos+      | oPos == lStart + 1 =+          -- Either no labels at all (lStart == startLStart) or a+          -- trailing dot just consumed (lStart > startLStart).  In+          -- both cases the terminator goes at outBuf[lStart].+          pure (Right lStart)+      | otherwise = do+          let !labelLen = oPos - lStart - 1+          writeByteArray outBuf lStart (fromIntegral labelLen :: Word8)+          pure (Right oPos)++----------------------------------------------------------------------+-- Localpart driver+----------------------------------------------------------------------++-- | Walk a slice of @bs@ in @[lpStart..lpEnd)@ as a mailbox+-- localpart, writing the localpart wire bytes into+-- @outBuf[1..]@.  Returns the number of bytes written (i.e. the+-- localpart length) on success.+--+-- Localpart parsing differs from domain parsing: there is exactly+-- one label (no @\'.\'@ separators), and the byte @\'.\'@ is+-- therefore literal.  Backslash escapes work the same way (@\\C@+-- and @\\DDD@).  Non-ASCII bytes (> 127) are rejected as invalid.+--+localpartDriver+    :: forall s.  ByteString+    -> Int -- ^ lpEnd+    -> MutableByteArray s+    -> ST s (Either Domain8Err Int)+localpartDriver !bs !lpEnd !outBuf = go 0 1+  where+    go :: Int -> Int -> ST s (Either Domain8Err Int)+    go !iPos !oPos+      | iPos >= lpEnd = pure (Right (oPos - 1))+      | otherwise =+          let !b = BU.unsafeIndex bs iPos+          in if | b == 0x5C -> handleEsc iPos oPos+                | otherwise -> appendByte b (iPos + 1) oPos++    appendByte :: Word8 -> Int -> Int -> ST s (Either Domain8Err Int)+    appendByte !b !iPos !oPos+      | b > 0x7F = pure (Left D8Non7Bit)+      | oPos > maxLabelLen = pure (Left D8LabelTooLong)+      | otherwise = do+          writeByteArray outBuf oPos b+          go iPos (oPos + 1)++    handleEsc :: Int -> Int -> ST s (Either Domain8Err Int)+    handleEsc !iPos !oPos+      | iPos + 1 >= lpEnd = pure (Left D8BadEscape)+      | b1 <- BU.unsafeIndex bs (iPos + 1)+      , v1 <- b1 - 0x30+      = if | v1 > 9 -> appendByte b1 (iPos + 2) oPos+           | iPos + 4 > lpEnd -> pure (Left D8BadEscape)+           | v2 <- BU.unsafeIndex bs (iPos + 2) - 0x30+           , v2 <= 9+           , v3 <- BU.unsafeIndex bs (iPos + 3) - 0x30+           , v3 <= 9+           , !n <- (v1 * 100 + v2 * 10 + v3)+           -> if | n <= 0xFF -> appendByte (fromIntegral n) (iPos + 4) oPos+                 | otherwise -> pure (Left D8BadEscape)+           | otherwise -> pure (Left D8BadEscape)++----------------------------------------------------------------------+-- Mailbox driver+----------------------------------------------------------------------++-- | Parse a mailbox in presentation form.  @sepAt@ is the byte+-- offset of the first unescaped @\'\@\'@ (already located by+-- 'findAt8').  Walks the localpart bytes @[0..sepAt)@, then+-- dispatches @[sepAt+1..inEnd)@ to 'domainDriver' for the+-- domain-side labels.+mboxDriver+    :: forall s+    .  ByteString+    -> Int                              -- ^ inEnd+    -> MutableByteArray s+    -> Int                              -- ^ sepAt+    -> ST s (Either Domain8Err Int)+mboxDriver !bs !inEnd !outBuf !sepAt = do+    res <- localpartDriver bs sepAt outBuf+    case res of+      Left e -> pure (Left e)+      Right lpLen+        | lpLen == 0 ->+            -- Empty localpart.  Accepted only as a sole "@" denoting+            -- the root domain (matches the historical behaviour of+            -- the Builder-based parser); rejected when followed by+            -- anything else (the empty first label has no business+            -- next to additional content).+            if sepAt + 1 >= inEnd+              then pure (Right 0)+              else pure (Left D8EmptyLabel)+        | lpLen <= maxLabelLen -> do+            writeByteArray @Word8 outBuf 0 (fromIntegral lpLen)+            let !lpEnd = fromIntegral $ lpLen + 1+            if sepAt + 1 >= inEnd+              then pure (Right lpEnd)+              else domainDriver bs inEnd outBuf+                                lpEnd (sepAt + 1) (lpEnd + 1)+        | otherwise -> pure (Left D8LabelTooLong)++-- | Single-pass scan for the first unescaped @\'\@\'@.  Returns the+-- byte offset of that @\'\@\'@, or 'Nothing' if none is present.+--+-- Backslash escapes are skipped in the same shape as the localpart+-- parser uses on input: @\\<digit>@ is the start of a 4-byte+-- @\\DDD@ form; @\\<other>@ is the 2-byte @\\C@ form.  A+-- structurally invalid escape (truncated) leaves the scan in+-- "no @ found" state, and the actual parse failure is reported by+-- 'parseDomain8Wire' (which the mailbox parser falls back to in the+-- no-@ case).+findAt8 :: ByteString -> Int -> Int -> Maybe Int+findAt8 !bs !p0 !inEnd = go p0+  where+    go !p+      | p >= inEnd = Nothing+      | otherwise =+          let !b = BU.unsafeIndex bs p+          in if | b == 0x40 -> Just p+                | b == 0x5C -> skipEsc p+                | otherwise -> go (p + 1)++    skipEsc !p+      | p + 1 >= inEnd = Nothing+      | otherwise =+          let !b1 = BU.unsafeIndex bs (p + 1)+          in case asciiDigit b1 of+               Just _  -> go (p + 4)+               Nothing -> go (p + 2)++----------------------------------------------------------------------+-- Buffer finalisation+----------------------------------------------------------------------++-- | Common tail: append a terminator to @outBuf@ at @outLen@,+-- length-check, and freeze into the wire-form 'ShortByteString'.+finalise+    :: forall s+    .  MutableByteArray s+    -> Either Domain8Err Int+    -> ST s (Either Domain8Err ShortByteString)+finalise !_ (Left e) = pure (Left e)+finalise !outBuf (Right outLen) =+    let !finalLen = outLen + 1+    in if finalLen > maxWireLen+         then pure (Left D8WireTooLong)+         else do+           writeByteArray outBuf outLen (0 :: Word8)+           resBA <- newByteArray finalLen+           copyMutableByteArray resBA 0 outBuf 0 finalLen+           frozen <- unsafeFreezeByteArray resBA+           pure (Right (baToShortByteString frozen))++----------------------------------------------------------------------+-- Tiny utilities+----------------------------------------------------------------------++-- | If @w@ is an ASCII decimal digit, return its numeric value+-- (0..9); otherwise 'Nothing'.+asciiDigit :: Word8 -> Maybe Word8+asciiDigit !w+    | d <= 9    = Just d+    | otherwise = Nothing+  where+    !d = w - 0x30+{-# INLINE asciiDigit #-}++-- | Pack a 'String' into a 'ByteString', failing with 'D8Non8Bit' if+-- any character has codepoint above @0xFF@.+safePack :: String -> Either Domain8Err ByteString+safePack s+    | all ((<= 0xFF) . Ch.ord) s = Right (C8.pack s)+    | otherwise                  = Left D8Non8Bit
+ src/Net/DNSBase/EDNS.hs view
@@ -0,0 +1,26 @@+{-|+Module      : Net.DNSBase.EDNS+Description : Fixed part of the EDNS(0) OPT pseudo-RR+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++'EDNS' carries the non-option parts of the OPT pseudo-RR+([RFC 6891 section 6.1.3](https://datatracker.ietf.org/doc/html/rfc6891#section-6.1.3)):+the advertised UDP payload size, EDNS version, extended-RCODE+bits, and the DO (DNSSEC-OK) flag, along with the option list+itself.  'defaultEDNS' is the resolver's default configuration;+'minUdpSize' and 'maxUdpSize' are the clamps applied when a+caller overrides the payload size via 'Net.DNSBase.Resolver.EdnsUdpSize'.+-}++module Net.DNSBase.EDNS+    ( -- * Fixed portion of EDNS(0) OPT pseudo-RR+      EDNS(..)+    , defaultEDNS+    , maxUdpSize+    , minUdpSize+    ) where++import Net.DNSBase.Internal.EDNS
+ src/Net/DNSBase/EDNS/OptNum.hs view
@@ -0,0 +1,24 @@+{-|+Module      : Net.DNSBase.EDNS.OptNum+Description : EDNS(0) option codepoints (RFC 6891)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 16-bit @OPTION-CODE@ field used by EDNS(0) options inside+the OPT pseudo-RR+([RFC 6891 section 6.1.2](https://datatracker.ietf.org/doc/html/rfc6891#section-6.1.2)).+Pattern synonyms cover the standardised options (NSID, ECS,+EDE, ...); unknown codes round-trip as 'Net.DNSBase.EDNS.Option.OpaqueOption' values.+See the+[IANA DNS EDNS0 Option Codes registry](https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-11)+for the full list.+-}++module Net.DNSBase.EDNS.OptNum+    ( -- * EDNS(0) option numbers+      OptNum(..)+    ) where++import Net.DNSBase.EDNS.Internal.OptNum
+ src/Net/DNSBase/EDNS/Option.hs view
@@ -0,0 +1,45 @@+{-|+Module      : Net.DNSBase.EDNS.Option+Description : EDNS option typeclass, existential wrapper, and resolver controls+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 'KnownEdnsOption' typeclass binds a concrete option type to its+16-bit code; the existential 'EdnsOption' wrapper lets an+option list hold a heterogeneous mix.  Unknown option codes+decode as 'Net.DNSBase.EDNS.Option.Opaque.OpaqueOption' from+"Net.DNSBase.EDNS.Option.Opaque", preserving the raw bytes for+inspection or pass-through.  Applications register new typed+options at runtime via 'Net.DNSBase.Resolver.registerEdnsOption';+options whose codec admits typed or value-driven extensions+(e.g. 'Net.DNSBase.EDNS.Option.EDE.O_ede') also accept+'Net.DNSBase.Resolver.extendEdnsOptionWithType' /+'Net.DNSBase.Resolver.extendEdnsOptionWithValue'.  See+"Net.DNSBase.Extensible" for the full guide.++The 'OptionCtl' machinery, with 'optCtlSet' / 'optCtlAdd', is+the building block 'Net.DNSBase.Resolver.QueryControls' uses for per-call EDNS+option list tweaks — see 'Net.DNSBase.Resolver.EdnsOptionCtl'.+-}++module Net.DNSBase.EDNS.Option+    ( -- * Generic EDNS option class+     KnownEdnsOption(..)+    , EdnsOption(..)+    , fromOption+    , monoOption+    , optionCode+    , putOption+    -- * Extensibility+    , OptionCodec+    -- * Resolver EDNS option controls+    , OptionCtl+    , optCtlSet+    , optCtlAdd+    , emptyOptionCtl+    , applyOptionCtl+    ) where++import Net.DNSBase.EDNS.Internal.Option
+ src/Net/DNSBase/EDNS/Option/ECS.hs view
@@ -0,0 +1,126 @@+{-|+Module      : Net.DNSBase.EDNS.Option.ECS+Description : EDNS Client Subnet option (RFC 7871)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The Client Subnet EDNS option lets a recursive resolver forward+a prefix of the original client's address to an authoritative+server, so that authority-side answers (CDNs and similar) can+be tailored to the client's network location.  The+specification, including privacy considerations, is+[RFC 7871](https://datatracker.ietf.org/doc/html/rfc7871).+-}++module Net.DNSBase.EDNS.Option.ECS+    ( O_ecs(..)+    ) where++import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.EDNS.Internal.OptNum+import Net.DNSBase.EDNS.Internal.Option+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Encode.Internal.Metric+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util++-- | The Client Subnet EDNS option+-- ([RFC 7871 section 6](https://tools.ietf.org/html/rfc7871#section-6))+-- — three fields: a source prefix length, a scope prefix length,+-- and a (possibly truncated) IP address whose 16-bit @FAMILY@+-- field is implicit in the constructor's 'IP' value (@1@ for+-- 'IPv4', @2@ for 'IPv6').+--+-- >            +0 (MSB)                            +1 (LSB)+-- >  +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++-- >  |                          OPTION-CODE                          |+-- >  +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++-- >  |                         OPTION-LENGTH                         |+-- >  +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++-- >  |                            FAMILY                             |+-- >  +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++-- >  |     SOURCE PREFIX-LENGTH      |     SCOPE PREFIX-LENGTH       |+-- >  +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++-- >  |                           ADDRESS...                          /+-- >  +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---++--+-- The address is masked and truncated to the source prefix length+-- on encode and zero-padded on decode.  A @FAMILY@ value other+-- than 1 or 2 fails the decoder (a future revision may decode+-- such values as an opaque option instead).+data O_ecs = O_ECS Word8 Word8 IP deriving (Eq, Show)++instance Presentable O_ecs where+    present (O_ECS srcbits scopebits ip) =+        present srcbits+        . presentSp scopebits+        . presentSp ip++instance KnownEdnsOption O_ecs where+    optNum _ = ECS+    {-# INLINE optNum #-}+    optEncode (O_ECS srcbits scopebits ip) = case ip of+        IPv4 ip4 -> do+                    -- XXX: More precise error?+                    when (srcbits < 0 || srcbits > 32) $+                        failWith CantEncode+                    let (!q, !r) = (srcbits + 7) `quotRem` 8+                        !w = fromIPv4w ip4+                    putSizedBuilder $+                        mbWord16 1+                        <> mbWord8 srcbits+                        <> mbWord8 scopebits+                        <> encWord w q r+        IPv6 ip6 -> do+                    -- XXX: More precise error?+                    when (srcbits < 0 || srcbits > 128) $+                        failWith CantEncode+                    let (!q, !r) = (srcbits + 7) `quotRem` 8+                        (!w0, !w1, !w2, !w3) = fromIPv6w ip6+                    putSizedBuilder $+                        mbWord16 2+                        <> mbWord8 srcbits+                        <> mbWord8 scopebits+                        <> encWord w0 q r+                        <> encWord w1 (q - 4) r+                        <> encWord w2 (q - 8) r+                        <> encWord w3 (q - 12) r+    optDecode _ _ = getECS++encWord :: Word32 -> Word8 -> Word8 -> SizedBuilder+encWord !w !q !r = case min 4 q of+    4 -> mbWord32 (w .&. mask)+    3 -> (mbWord16 . fromIntegral) (w `unsafeShiftR` 16) <>+         (mbWord8  . fromIntegral) ((w `unsafeShiftR` 8) .&. mask)+    2 -> (mbWord16 . fromIntegral) ((w `unsafeShiftR` 16) .&. mask)+    1 -> (mbWord8  . fromIntegral) ((w `unsafeShiftR` 24) .&. mask)+    _ -> mempty+  where+    mask | q <= 4+         , s <- fromEnum $ 7 - r+         , s > 0    = (0xffff_ffff `unsafeShiftR` s) `unsafeShiftL` s+         | otherwise = 0xffff_ffff++-- | Decode an EDNS Client Subnet (ECS) option according to the provided+-- OPTION-LENGTH Parameter to determine how many bytes the address has been+-- truncated to.+--+-- Values of the FAMILY field other than 1 (IPv4) or 2 (IPv6) are rejected+-- and cause the decoder to fail.+getECS :: Int -- ^ OPTION-LENGTH field+       -> SGet EdnsOption+getECS n = do+    ecs_family <- get16+    ecs_source <- get8+    ecs_scope  <- get8+    case ecs_family of+        1 -> do+            ecs_addr <- getIPv4Net (n - 4)+            return $ EdnsOption $ O_ECS ecs_source ecs_scope (IPv4 ecs_addr)+        2 -> do+            ecs_addr <- getIPv6Net (n - 4)+            return $ EdnsOption $ O_ECS ecs_source ecs_scope (IPv6 ecs_addr)+        f -> failSGet $ "unsupported ECS family " ++ show f+        -- XXX : consider using alternate constructor instead of failure
+ src/Net/DNSBase/EDNS/Option/EDE.hs view
@@ -0,0 +1,141 @@+-- |+-- Module      : Net.DNSBase.EDNS.Option.EDE+-- Description : Extended DNS Errors (RFC 8914)+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+-- Maintainer  : ietf-dane@dukhovni.org+-- Stability   : unstable+{-# LANGUAGE OverloadedStrings #-}++module Net.DNSBase.EDNS.Option.EDE+    ( O_ede(..)+    ) where++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Short as SB+import qualified Data.IntMap.Strict as IM++import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.EDNS.Internal.Option+import Net.DNSBase.EDNS.Internal.OptNum+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Extensible+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Text+import Net.DNSBase.Internal.Util++-- | [Extended DNS Error](https://www.rfc-editor.org/rfc/rfc8914.html#section-2)+--+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |          INFO-CODE            |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > / EXTRA-TEXT ...                /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- The decoded value carries the wire-format info-code and extra+-- text alongside an /optional/ friendly name ('edeName') looked+-- up from the resolver's EDE name table.  An empty 'edeName'+-- denotes "no entry in the table": the 'Presentable' instance+-- falls back to a bare numeric code in that case.+--+-- The 'Net.DNSBase.EDNS.Option.OptionExtensionVal' for 'O_ede' is the name registry —+-- an 'IM.IntMap' from info-code to user-facing name.+-- Applications can register new names or override standard+-- ones via 'Net.DNSBase.Resolver.extendEdnsOptionWithValue' on+-- 'O_ede', passing the @(code, name)@ pair to add.+data O_ede = O_EDE+    { edeInfoCode :: !Word16+        -- ^ EDE info-code (RFC 8914, section 4).+    , edeName     :: !ShortByteString+        -- ^ Friendly name looked up at decode time, or 'mempty'+        --   when the table has no matching entry.+    , edeText     :: !ShortByteString+        -- ^ Extra-text payload (UTF-8).  May be empty.+    } deriving (Eq, Show)++-- | Presentation form modelled after BIND @dig@:+--+-- > 9 (DNSKEY Missing): "no SEP matching the DS found for dnssec-failed.org."+--+-- The numeric code is always shown.  The friendly name (parenthesised,+-- raw — registry tags don't need quoting) and trailing colon+text+-- (DNS text quoting applied — the EXTRA-TEXT is free-form payload)+-- appear when present; an unregistered code with no extra text+-- renders as just the bare number.+instance Presentable O_ede where+    present (O_EDE code name text) =+        present code . namePart . textPart+      where+        namePart+            | SB.null name = id+            | otherwise    = present @String " ("+                           . (B.shortByteString name <>)+                           . present @String ")"+        textPart+            | SB.null text = id+            | otherwise    = present @String ": "+                           . coerce (present @DnsText) text++instance KnownEdnsOption O_ede where+    type OptionExtensionVal O_ede = IM.IntMap ShortByteString+    optionExtensionVal _ = baseEdeNames++    optNum _ = EDE+    {-# INLINE optNum #-}+    optEncode (O_EDE c _ t) = do+        put16 c+        putShortByteString t+    optDecode _ namesMap len = do+        code <- get16+        text <- getShortNByteString (len - 2)+        pure $! EdnsOption $! O_EDE code+            (IM.findWithDefault mempty (fromIntegral code) namesMap)+            text++instance ValueExtensible O_ede (IM.IntMap ShortByteString) where+    -- A caller registers a @(code, name)@ pair; later+    -- registrations win over earlier entries at the same code.+    type ValueExtensionArg O_ede b = (b ~ (Word16, ShortByteString))+    extendByValue _ (code, name) m = IM.insert (fromIntegral code) name m++-- | Built-in friendly names for the EDE info-codes registered by+-- [IANA](https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#extended-dns-error-codes)+-- through RFC 8914 section 4 and subsequent assignments.+-- Applications can extend or override this map via+-- 'Net.DNSBase.Resolver.extendEdnsOptionWithValue' on 'O_ede'.+baseEdeNames :: IM.IntMap ShortByteString+baseEdeNames = IM.fromList+    [ ( 0, "Other Error")+    , ( 1, "Unsupported DNSKEY Algorithm")+    , ( 2, "Unsupported DS Digest Type")+    , ( 3, "Stale Answer")+    , ( 4, "Forged Answer")+    , ( 5, "DNSSEC Indeterminate")+    , ( 6, "DNSSEC Bogus")+    , ( 7, "Signature Expired")+    , ( 8, "Signature Not Yet Valid")+    , ( 9, "DNSKEY Missing")+    , (10, "RRSIGs Missing")+    , (11, "No Zone Key Bit Set")+    , (12, "NSEC Missing")+    , (13, "Cached Error")+    , (14, "Not Ready")+    , (15, "Blocked")+    , (16, "Censored")+    , (17, "Filtered")+    , (18, "Prohibited")+    , (19, "Stale NXDOMAIN Answer")+    , (20, "Not Authoritative")+    , (21, "Not Supported")+    , (22, "No Reachable Authority")+    , (23, "Network Error")+    , (24, "Invalid Data")+    , (25, "Signature Expired before Valid")+    , (26, "Too Early")+    , (27, "Unsupported NSEC3 Iterations Value")+    , (28, "Unable to conform to policy")+    , (29, "Synthesized")+    , (30, "Invalid Query Type")+    , (31, "Rate Limited")+    , (32, "Over Quota")+    ]
+ src/Net/DNSBase/EDNS/Option/NSID.hs view
@@ -0,0 +1,50 @@+{-|+Module      : Net.DNSBase.EDNS.Option.NSID+Description : EDNS Name Server Identifier option (RFC 5001)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The NSID EDNS option lets a server identify itself in a reply+— useful for distinguishing between members of an anycast set.+The client sends an empty NSID option to request identification;+the server's reply carries an opaque byte string chosen by the+operator (typically a host name or short tag).+-}++module Net.DNSBase.EDNS.Option.NSID+    ( O_nsid(..)+    ) where++import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.EDNS.Internal.OptNum+import Net.DNSBase.EDNS.Internal.Option+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Text+import Net.DNSBase.Internal.Util++-- | The NSID EDNS option+-- ([RFC 5001](https://datatracker.ietf.org/doc/html/rfc5001))+-- — opaque server-chosen bytes identifying the responder.+-- The same option code is used in both directions: a client sends+-- an empty value to ask for identification, the server replies+-- with its identifier (which may contain arbitrary bytes,+-- including non-printable ones).+--+-- The 'Presentable' instance renders the bytes through 'DnsText',+-- producing a quoted character-string when the content is+-- printable and escapes for any non-printable bytes.+newtype O_nsid = O_NSID ShortByteString deriving (Eq, Show)++instance Presentable O_nsid where+    -- | Though NSID is an opaque 'ShortByteString', we attempt to present+    -- it as a character string.+    present (O_NSID val) = coerce (present @DnsText) val++instance KnownEdnsOption O_nsid where+    optNum _ = NSID+    {-# INLINE optNum #-}+    optEncode (O_NSID bs) = putShortByteString bs+    optDecode _ _ = EdnsOption . O_NSID <.> getShortNByteString
+ src/Net/DNSBase/EDNS/Option/Opaque.hs view
@@ -0,0 +1,26 @@+{-|+Module      : Net.DNSBase.EDNS.Option.Opaque+Description : Fallback wrapper for unrecognised EDNS options+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++'OpaqueOption' is the carrier the decoder falls back to when it+sees an EDNS option code that no+'Net.DNSBase.EDNS.Option.KnownEdnsOption' instance in the resolver's+option map handles.  The option's contents are left as raw bytes+and presented in the generic [RFC+3597](https://datatracker.ietf.org/doc/html/rfc3597) form, so+applications can still inspect and round-trip the value.  The+option code is carried as a type-level natural, so+'OpaqueOption' values with different codes have distinct types.+-}++module Net.DNSBase.EDNS.Option.Opaque+    ( OpaqueOption(..)+    , opaqueEdnsOption+    )+    where++import Net.DNSBase.EDNS.Internal.Option.Opaque
+ src/Net/DNSBase/EDNS/Option/Secalgs.hs view
@@ -0,0 +1,123 @@+{-|+Module      : Net.DNSBase.EDNS.Option.Secalgs+Description : EDNS signalling of DNSSEC algorithms understood by the client+Copyright   : (c) Viktor Dukhovni, 2020+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : experimental++RFC 6975 specifies a way for validating end-system resolvers to signal+to a server which digital signature and hash algorithms they support.+This signalling does not alter server behaviour, rather it just provides+a means to server operators to collect data on client algorithm support+to assist in planning future algorithm selection.++The format of the associated EDNS options is defined in+[RFC6975, Section 3](https://tools.ietf.org/html/rfc6975#section-3)+as follows:++>  0                       8                      16+>  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++>  |                  OPTION-CODE                  |+>  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++>  |                  LIST-LENGTH                  |+>  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++>  |       ALG-CODE        |        ...            /+>  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+++i.e. a 16-bit count, followed by a sequence of 8-bit algorithm numbers.++The use of SHA-1 in NSEC3 is essentially light-weight obfuscation to+discourage casual zone walking. Implementation and adoption of successor+algorithms seems unlikely, and would in also be most counter-productive.+Therefore, while the N3U option is defined here, it is best left unused.+As of February 2020, the IANA registry of+[NSEC3 hash algorithms](https://www.iana.org/assignments/dnssec-nsec3-parameters/dnssec-nsec3-parameters.xhtml#dnssec-nsec3-parameters-3)+lists just SHA-1:++ +---------+---------------+-----------++ | Value   | Description   | Reference |+ +=========+===============+===========++ | 0       | Reserved      | [RFC5155] |+ +---------+---------------+-----------++ | 1       | SHA-1         | [RFC5155] |+ +---------+---------------+-----------++ | 2-255   | Unassigned    |           |+ +---------+---------------+-----------+++This is not expected to change.+-}++module Net.DNSBase.EDNS.Option.Secalgs+    ( O_dau(..)+    , O_dhu(..)+    , O_n3u(..)+    ) where++import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.EDNS.Internal.OptNum+import Net.DNSBase.EDNS.Internal.Option+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Encode.Internal.Metric+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util++import Net.DNSBase.Secalgs++-- | DNSSEC Algorithm Understood (RFC6975).+newtype O_dau = O_DAU [DNSKEYAlg] deriving (Eq, Show)+-- | DS Hash Understood (RFC6975).+newtype O_dhu = O_DHU [DSHashAlg] deriving (Eq, Show)+-- | NSEC3 Hash Understood (RFC6975).+newtype O_n3u = O_N3U [NSEC3HashAlg] deriving (Eq, Show)++instance Presentable O_dau where+    present (O_DAU val) = case val of+        []     -> present '-'+        (v:vs) -> present v . flip (foldr presentSp) vs++instance Presentable O_dhu where+    present (O_DHU val) = case val of+        []     -> present '-'+        (v:vs) -> present v . flip (foldr presentSp) vs++instance Presentable O_n3u where+    present (O_N3U val) = case val of+        []     -> present '-'+        (v:vs) -> present v . flip (foldr presentSp) vs++instance KnownEdnsOption O_dau where+    optNum _ = DAU+    {-# INLINE optNum #-}+    optEncode  = putSizedBuilder . coerce foldDAU+      where+        foldDAU :: [DNSKEYAlg] -> SizedBuilder+        foldDAU = foldMap mbDAU+        mbDAU :: DNSKEYAlg -> SizedBuilder+        mbDAU = coerce mbWord8+    optDecode _ _ len =+        EdnsOption . O_DAU <$> getFixedWidthSequence 1 (coerce <$> get8) len++instance KnownEdnsOption O_dhu where+    optNum _ = DHU+    {-# INLINE optNum #-}+    optEncode  = putSizedBuilder . coerce foldDHU+      where+        foldDHU :: [DSHashAlg] -> SizedBuilder+        foldDHU = foldMap mbDHU+        mbDHU :: DSHashAlg -> SizedBuilder+        mbDHU = coerce mbWord8+    optDecode _ _ len =+        EdnsOption . O_DHU <$> getFixedWidthSequence 1 (coerce <$> get8) len++instance KnownEdnsOption O_n3u where+    optNum _ = N3U+    {-# INLINE optNum #-}+    optEncode  = putSizedBuilder . coerce foldN3U+      where+        foldN3U :: [NSEC3HashAlg] -> SizedBuilder+        foldN3U = foldMap mbN3U+        mbN3U :: NSEC3HashAlg -> SizedBuilder+        mbN3U = coerce mbWord8+    optDecode _ _ len =+        EdnsOption . O_N3U <$> getFixedWidthSequence 1 (coerce <$> get8) len
+ src/Net/DNSBase/Encode/Metric.hs view
@@ -0,0 +1,39 @@+{-|+Module      : Net.DNSBase.Encode.Metric+Description : Length-tracking Builder for wire-form encoding+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++'SizedBuilder' is a 'Data.ByteString.Builder' paired with its+byte length, accumulated as the builder is assembled.  Used+inside RR-data encoders when an outer length-prefixed field+needs the encoded value's length up front (RDLENGTH and the+16-bit length prefixes that introduce SVCB option values, EDNS+option values, and similar).  The @mb*@ converters wrap the+corresponding low-level builders so their byte-cost is+tracked.+-}++module Net.DNSBase.Encode.Metric+    ( SizedBuilder+    -- exported pattern+    , pattern SizedBuilder+    -- exported converters+    , mbErr+    , mbWord8+    , mbWord16+    , mbWord32+    , mbWord64+    , mbByteString+    , mbByteStringLen8+    , mbByteStringLen16+    , mbShortByteString+    , mbShortByteStringLen8+    , mbShortByteStringLen16+    , mbIPv4+    , mbIPv6+    ) where++import Net.DNSBase.Encode.Internal.Metric
+ src/Net/DNSBase/Encode/State.hs view
@@ -0,0 +1,58 @@+{-|+Module      : Net.DNSBase.Encode.State+Description : Wire-form encoder monad and primitive byte/sequence encoders+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 'SPut' encoder monad for serialising DNS wire-form data,+plus primitive writers ('put8', 'put16', ...), DNS-style+helpers ('putDomain', 'putWireForm'), length-prefixed+byte-string writers, and the high-level driver functions+'encodeCompressed' / 'encodeVerbatim'.  Used by authors of+'Net.DNSBase.RData.KnownRData' and 'Net.DNSBase.EDNS.Option.KnownEdnsOption' instances to implement value-side+encoding; most applications will not use this module directly.++'putDomain' applies DNS name compression+([RFC 1035 section 4.1.4](https://datatracker.ietf.org/doc/html/rfc1035#section-4.1.4))+when the surrounding driver permits it; 'putWireForm' is the+compression-free counterpart for RR types whose target domains+forbid compression on encode.+-}++module Net.DNSBase.Encode.State+    ( -- * Low level DNS data encoding primitives+      EncodeErr(..)+    , ErrorContext+    , SPut, SPutM, localSPut+    , buildCompressed+    , encodeCompressed+    , buildVerbatim+    , encodeVerbatim+    , putDomain+    , putWireForm+    , put8+    , put16+    , put32+    , put64+    , putIPv4+    , putIPv6+    , putByteString+    , putByteStringLen8+    , putByteStringLen16+    , putShortByteString+    , putShortByteStringLen8+    , putShortByteStringLen16+    , putUtf8Text+    , putUtf8TextLen8+    , putUtf8TextLen16+    , putSizedBuilder+    , putReplicate+    -- * Encoder state mutation+    , passLen+    , failWith+    , setContext+    ) where++import Net.DNSBase.Encode.Internal.State
+ src/Net/DNSBase/Error.hs view
@@ -0,0 +1,31 @@+{-|+Module      : Net.DNSBase.Error+Description : Resolver, protocol, and encoder error types+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++'DNSError' is the sum type returned by all failed lookups in+"Net.DNSBase.Lookup".  Its constructors split by source: network+problems ('NetworkError'), protocol-level decode or response-code+failures ('ProtocolError'), API misuse errors ('UserError'), and+so on.  Information about the context in which the error occured+is included when available.  'EncodeErr' is the analogous sum+returned by failures of the wire-form encoder.+-}++module Net.DNSBase.Error+    ( DNSError(..)+    , DnsXprt(..)+    , EncodeErr(..)+    , NetworkContext(..)+    , ProtocolContext(..)+    , UserContext(..)+    , DecodeContext(..)+    , EncodeContext(..)+    , DnsSection(..)+    , MessageSource(..)+    ) where++import Net.DNSBase.Internal.Error
+ src/Net/DNSBase/Extensible.hs view
@@ -0,0 +1,544 @@+{-|+Module      : Net.DNSBase.Extensible+Description : Extension classes plus a guide to adding RR types and EDNS options+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The two classes 'TypeExtensible' and 'ValueExtensible' are the+hooks that an already-extensible RR-data or EDNS-option codec+uses to admit user-supplied additions at conf-build time.+'TypeExtensible' admits a new Haskell type as the extension;+'ValueExtensible' admits a runtime value.  Most callers never+write an instance of either: the common cases are+/registering/ a brand-new RR type or EDNS option that doesn't+itself need an extension hook, or /supplying/ an extension to+an already extensible codec.  The sections below walk through+each of these in turn, and finish with the steps for defining+a new extensible codec of your own.+-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Net.DNSBase.Extensible+    ( -- * Extension classes+      TypeExtensible(..)+    , ValueExtensible(..)++      -- * Extending the library+      -- $overview++      -- ** Adding a custom RR type+      -- $customRRtype++      -- ** Adding a custom EDNS option+      -- $customEDNS++      -- ** Adding a type-driven extension+      -- $typeExt++      -- ** Adding a value-driven extension+      -- $valueExt++      -- ** Writing a type-driven extensible codec+      -- $newTypeExt++      -- ** Writing a value-driven extensible codec+      -- $newValueExt+    ) where++import Data.Kind (Constraint, Type)++-- | RR-data or EDNS-option types whose codec admits a+-- /type/-driven extension.  See+-- [Adding a custom RR type]("Net.DNSBase.Extensible#typeExt")+-- for an example of this mechanism in use, and+-- [Writing a type-driven extensible codec]("Net.DNSBase.Extensible#newTypeExt")+-- for the steps to implement a type-driven extensible codec+-- of your own.+--+type TypeExtensible :: Type -> Type -> Constraint+class TypeExtensible a v where+    -- | Constraint a caller's extension type @b@ must satisfy.+    type TypeExtensionArg a b :: Constraint++    -- | Fold a caller's extension type @b@ into the existing+    -- codec context value of type @v@.+    extendByType :: forall t b -> (t ~ a, TypeExtensionArg t b)+                 => v -> v++-- | RR-data or EDNS-option types whose codec admits a+-- /value/-driven extension.  See+-- [Adding a valud-driven extension]("Net.DNSBase.Extensible#valueExt")+-- for an example of this mechanism in use, and+-- [Writing a value-driven extensible codec]("Net.DNSBase.Extensible#newValueExt")+-- for the steps to implement a value-driven extensible codec of+-- your own.+--+type ValueExtensible :: Type -> Type -> Constraint+class ValueExtensible a v where+    -- | Constraint a caller's extension value type @b@ must+    -- satisfy.+    type ValueExtensionArg a b :: Constraint++    -- | Fold a caller-supplied value of type @b@ into the+    -- existing codec context value of type @v@.+    extendByValue :: forall t -> (t ~ a)+                  => forall b. (ValueExtensionArg t b)+                  => b -> v -> v++-- $overview+--+-- The sections below detail the available extension mechanisms,+-- showing workable code fragments, and even complete programs.+--+-- $customRRtype+-- #customRRtype#+--+-- The library decodes recognised RR types into matching+-- 'Net.DNSBase.RData.KnownRData' values and falls back to+-- 'Net.DNSBase.RData.OpaqueRData' for unrecognised codepoints.+--+-- To teach the resolver about an RR type the library does not+-- natively handle, declare a new 'Net.DNSBase.RData.KnownRData'+-- instance for your data type and pass the type to+-- 'Net.DNSBase.Resolver.registerRRtype' when building a+-- 'Net.DNSBase.Resolver.ResolverConf'.+--+-- /1.  Declare the RRTYPE and the associated data type./+--+-- The example below adds an alternative defintion of the usual+-- DNS @A@ RRtype.  Stored as 'Data.Word.Word32' value, and presented in+-- hexadecimal.  First define the required 'Net.DNSBase.RRTYPE.RRTYPE':+--+-- > pattern EXT_HEXA :: RRTYPE+-- > pattern EXT_HEXA = RRTYPE 1+--+-- Next a type to carry the decoded form:+--+-- > data T_ext_hexa = T_EXT_HEXA Word32 deriving (Eq, Ord, Show)+--+-- /2.  Give it a presentation form./+--+-- 'Net.DNSBase.Present.Presentable' objects print values in DNS (zone file)+-- presentation form.+--+-- > -- | CPS Presentation form is 8 hex nibbles+-- > instance Presentable T_ext_hexa where+-- >     present (T_EXT_HEXA w) = \k -> B.word32HexFixed w <> k+--+-- /3.  Implement the 'Net.DNSBase.RData.KnownRData' instance./+--+-- The instance carries the RR-type code, an optional presentation override for+-- the type name, the wire encoder, and the wire decoder.  Plain RR types —+-- those with no per-type extension state — leave+-- 'Net.DNSBase.RData.RDataExtensionVal' at its @()@ default; the three leading+-- @_@ patterns on 'Net.DNSBase.RData.rdDecode' discard the /required type/+-- argument, the (trivial) extension value and the fixed data length.  The+-- @get32@ parser checks that at least 4 bytes are available, and the message+-- decoder calling @rdDecode@ checks that the entire payload was consumed.+--+-- > instance KnownRData T_ext_hexa where+-- >     rdType _ = EXT_HEXA+-- >     -- Specify the RRTYPE name+-- >     rdTypePres _ = present @String "HEXA"+-- >     -- Implement the fixed size encoder+-- >     rdEncode (T_EXT_HEXA w) = putSizedBuilder $! mbWord32 w+-- >     -- The decoder wraps the payload inside 'Net.DNSBase.RData.RData'+-- >     rdDecode _ _ _ = RData . T_EXT_HEXA <$> get32+--+-- /4.  Plug it into the resolver./+--+-- 'Net.DNSBase.Resolver.registerRRtype' installs the new+-- 'Net.DNSBase.RData.RData' type.  Application-registed RR types take+-- precedence over any built-in types with the same+-- 'Net.DNSBase.RRTYPE.RRTYPE', except for a small set of RFC-reserved slots+-- (e.g., the OPT pseudo-RR) where the library entry always wins.+--+-- > withHEXA :: ResolverConf -> ResolverConf+-- > withHEXA = registerRRtype T_ext_hexa+--+-- Applying the above to 'Net.DNSBase.Resolver.defaultResolvConf'+-- you get a configuration that associates the custom data type+-- with its 'Net.DNSBase.RRTYPE.RRTYPE'.  This can be passed to+-- 'Net.DNSBase.Resolver.makeResolvSeed', whose output can in+-- turn be used to spawn one or more resolver instances via+-- 'Net.DNSBase.Resolver.withResolver'.+--+-- You can find a complete+-- [demo program](https://github.com/dnsbase/dnsbase/blob/main/demos/demoextrr.hs)+-- on Github. The expected output with @google.com@ as the command-line argument, should be+-- similar to:+--+-- > www.google.com. 208 IN HEXA 8efb9977+-- > www.google.com. 208 IN HEXA 8efb9c77+-- > www.google.com. 208 IN HEXA 8efb9677+-- > www.google.com. 208 IN HEXA 8efb9a77+-- > www.google.com. 208 IN HEXA 8efb9d77+-- > www.google.com. 208 IN HEXA 8efb9b77+-- > www.google.com. 208 IN HEXA 8efb9777+-- > www.google.com. 208 IN HEXA 8efb9877+--+-- $customEDNS+-- #customEDNS#+--+-- The library decodes recognised EDNS options into matching+-- 'Net.DNSBase.RData.KnownEdnsOption' values and falls back to+-- 'Net.DNSBase.RData.OpaqueOption' for unrecognised codepoints.+--+-- To teach the resolver about an EDNS option the library does+-- not natively handle, declare a 'Net.DNSBase.RData.KnownEdnsOption'+-- instance for your data type and pass the type to+-- 'Net.DNSBase.Resolver.registerEdnsOption' when building a+-- 'Net.DNSBase.Resolver.ResolverConf'.+--+-- /1.  Declare the 'OptNum' and the associated data type./+--+-- The example below adds support for sending and receiving the+-- DNS @COOKIE@ option (applications would need to decide when+-- to send cookies, what to put in them, and what to do with+-- cookies received from servers).+--+-- > pattern EXT_COOKIE :: OptNum+-- > pattern EXT_COOKIE = OptNum 10+--+-- Next a type to carry the decoded form:+--+-- > import Data.ByteString.Builder as BS+-- > import Data.ByteString.Short as SBS+-- >+-- > data T_ext_cookie = T_EXT_COOKIE+-- >     { clientCookie :: Word64              -- ^ Fixed length+-- >     , serverCookie :: SBS.ShortByteString -- ^ Possibly empty+-- >     } deriving (Eq, Ord, Show)+--+-- /2.  Give it a presentation form./+--+-- 'Net.DNSBase.Present.Presentable' prints DNS object values in ASCII+-- text presentation form.+--+-- > instance Presentable T_ext_cookie where+-- >     present T_EXT_COOKIE {..} k =+-- >          B.word64HexFixed clientCookie+-- >          <> present @Bytes16 (coerce serverCookie) k+--+-- /3.  Implement the 'Net.DNSBase.RData.KnownEdnsOption' instance./+--+-- The instance carries the EDNS option code, an optional presentation override+-- for the type name, the wire encoder, and the wire decoder.  Plain EDNS+-- option types — those with no per-type extension state — leave+-- 'Net.DNSBase.RData.RDataExtensionVal' at its @()@ default; the three leading+-- @_@ patterns on 'Net.DNSBase.RData.optDecode' discard the /required type/+-- argument, the (trivial) extension value and the fixed data length.  The+-- @get64@ parser checks that at least 8 bytes are available, and the message+-- decoder calling @optDecode@ checks that the entire payload was consumed.+--+-- > instance KnownEdnsOption T_ext_cookie where+-- >     optNum _ = EXT_COOKIE+-- >+-- >     optPres _ = present @String "COOKIE"+-- >+-- >     optEncode T_EXT_COOKIE {..} = putSizedBuilder $!+-- >         mbWord64 clientCookie+-- >         <> mbShortByteString serverCookie+-- >+-- >     optDecode _ _ len = do+-- >          clientCookie <- get64+-- >          serverCookie <-+-- >              if | len == 8 -> pure mempty+-- >                 | len > 40 -> failSGet "Server cookie too long"+-- >                 | len < 16 -> failSGet "Server cookie too short"+-- >                 | otherwise -> getShortNByteString (len - 8)+-- >          pure $ EdnsOption $ T_EXT_COOKIE {..}+--+-- /4.  Plug it into the resolver./+--+-- 'Net.DNSBase.Resolver.registerEdnsOption' installs the new+-- 'Net.DNSBase.EDNS.KnownEdnsOption' type.  Application-registed EDNS+-- option types take precedence over any built-in types with the+-- same 'Net.DNSBase.EDNS.OptNum'.+--+-- > withCookie :: ResolverConf -> ResolverConf+-- > withCookie = registerEdnsOption T_ext_cookie+--+-- Applying the above to 'Net.DNSBase.Resolver.defaultResolvConf'+-- you get a configuration that associates the custom data type+-- with its 'Net.DNSBase.EDNS.OptNum'.  This can be passed to+-- 'Net.DNSBase.Resolver.makeResolvSeed', whose output can in+-- turn be used to spawn one or more resolver instances via+-- 'Net.DNSBase.Resolver.withResolver'.+--+-- Below is a complete program with more detailed comments,+-- if compiled and executed it prints a cookie obtained from+-- the (current at time of writing) authoritative name server+-- for the @isc.org@ domain.+--+-- You can find a complete+-- [demo program](https://github.com/dnsbase/dnsbase/blob/main/demos/demoextopt.hs)+-- on Github.  The expected output should be similar to:+--+-- > -- ; COOKIE:  <16 client hex nibbles + 32 server hex nibbles>+-- > -- isc.org. 7200 IN NS ns1.isc.org.+-- > -- isc.org. 7200 IN NS ns2.isc.org.+-- > -- isc.org. 7200 IN NS ns3.isc.org.+-- > -- isc.org. 7200 IN NS ns.isc.afilias-nst.info.+-- > -- isc.org. 7200 IN NS nsp.dnsnode.net.+--+-- $typeExt+-- #typeExt#+--+-- Type-driven extensions let a caller extend an already+-- implemented codec by supplying a new Haskell /type/ that+-- meets the codec's extension configuration constraint+-- ('TypeExtensionArg').  The built-in data types that support+-- this extensionn mechanism are 'Net.DNSBase.RData.SVCB.T_svcb'+-- and 'Net.DNSBase.RData.SVCB.T_https'.+--+-- Each 'Net.DNSBase.RData.SVCB.SVCParamValue' is decoded by a+-- 'Net.DNSBase.RData.SVCB.KnownSVCParamValue' instance registered+-- in the codec's set of known types.  Unknown keys fall through+-- to decoding via 'Net.DNSBase.RData.SVCB.OpaqueSPV'.+--+-- To add or override a parameter value, implement a+-- 'Net.DNSBase.RData.SVCB.KnownSVCParamValue' instance for your+-- data type and configure it in either or both ot+-- 'Net.DNSBase.RData.SVCB.T_svcb' and 'Net.DNSBase.RData.SVCB.T_https'+-- by calling 'Net.DNSBase.Resolver.extendRRwithType'.+--+-- An EDNS-option codec that supports type-driven extension+-- would be customised analogously via+-- 'Net.DNSBase.Resolver.extendEdnsOptionWithType'.+--+-- The example below adds the boolean @ohttp@ parameter (RFC 9540,+-- key 8), which carries no payload — its presence or absence in a+-- 'Net.DNSBase.RRTYPE.SVCB' or 'Net.DNSBase.RRTYPE.HTTPS' record+-- is the entire signal.  If the type were missing from the library,+-- this would introduce it, otherwise replaces the underlying @SVCB@+-- key slot with the specified type.+--+-- > pattern EXT_OHTTP :: SVCParamKey+-- > pattern EXT_OHTTP = SVCParamKey 8+-- >+-- > data SPV_EXT_ohttp = SPV_EXT_OHTTP deriving (Eq, Ord, Show)+-- >+-- > instance Presentable SPV_EXT_ohttp where+-- >     present _ = present "ohttp" -- key[=value], no value to add+-- >+-- > instance KnownSVCParamValue SPV_EXT_ohttp where+-- >     spvKey _    = EXT_OHTTP+-- >     spvKeyPres _ = present "ohttp" -- For key-only contexts+-- >     encodeSPV _ = pure ()+-- >     decodeSPV _ _ = pure $ SVCParamValue SPV_EXT_OHTTP+--+-- 'Net.DNSBase.Resolver.extendRRwithType' takes an existing+-- type to be extended and the new extension type.  It adds+-- the extension type to the set of types known to the extended+-- type.  Next, once again build a custom resolver configuration+-- that supports or prefers the new 'Net.DNSBase.RData.SVCB.SVCParamValue':+--+-- > withOHTTP :: ResolverConf -> ResolverConf+-- > withOHTTP = extendRRwithType T_svcb  SPV_EXT_ohttp+-- >           . extendRRwithType T_https SPV_EXT_ohttp+--+-- And with the associated resolver seed you're ready to+-- spin up resolvers that use the new data type for this+-- SVCB/HTTPS key value.+--+-- > makeResolvSeed $ withOHTTP defaultResolvConf >>= \case+-- >     Left why -> ... handle error ...+-- >     Right seed -> withResolver seed \rslv -> ...+--+-- As with custom 'Net.DNSBase.RRTYPE.RRTYPE' registrations,+-- application-registered 'Net.DNSBase.RData.SVCB.SVCParamValue'+-- types take precedence over any built-in type for the same+-- SVCB key with the exception of the reserved @mandatory@ key+-- (codepoint 0, RFC 9460 -- section 8), for which the library's+-- implementation is always used.+--+-- You can find a complete+-- [demo program](https://github.com/dnsbase/dnsbase/blob/main/demos/demoextspv.hs)+-- on Github.  Rather than the value-less @ohttp@ key shown above,+-- the demo shadows the standard @ipv4hint@ key (codepoint 4) with+-- a representation that holds each hint as a raw 'Data.Word.Word32'+-- and presents each address as eight hexadecimal nibbles under a+-- made-up name @IPV4HEX@, so that the override is visible in the+-- output of an @HTTPS@ lookup against a domain whose records carry+-- @ipv4hint@ values (e.g. @cloudflare.com@).  Other SvcParam entries+-- in the same answer continue to use their built-in decoders.+--+-- $valueExt+-- #valueExt#+--+-- Value-driven extensions let a caller extend an already+-- implemented codec by supplying a runtime /value/ rather than+-- a Haskell /type/.  An example of is the data type that models+-- EDNS Extended DNS Errors: 'Net.DNSBase.EDNS.Option.EDE.O_ede'+-- which on the wire carries a numeric code with an optional+-- text string.+--+-- Each EDE numeric code is associated with a descriptive name+-- as part of IANA registration.  New codes that are not known+-- to the library can be registered at runtime, and are stored+-- as part of any received EDE options when a message is decoded+-- by the resolver.+--+-- 'Net.DNSBase.Resolver.extendEdnsOptionWithValue' can be used+-- to register an new EDE code to name association, or to+-- override a built-in name, by passing a @(code, name)@ pair.+-- For a given info-code a new registration takes precedence+-- over the library's built-in value (if any).+--+-- In this case, no new Haskell type need be defined — the+-- registration is just data, because decoding of just needs+-- to map each number to a string, without any additional+-- custom behaviours.+--+-- Any @RData@ codec that supported value-driven extensions+-- would be customised analogously with the use of+-- 'Net.DNSBase.Resolver.extendRRwithValue'.+--+-- ==== __Code outline__+--+-- > withCustomEdeNames :: ResolverConf -> ResolverConf+-- > withCustomEdeNames =+-- >     extendEdnsOptionWithValue O_ede (33, "Frobnicated")+-- >   . extendEdnsOptionWithValue O_ede (34, "Bogosity")+-- >+-- > let customConf :: ResolverConf+-- >     customConf = withCustomEdeNames defaultResolverConf+-- > ... seed <- makeResolvSeed customConf ...+-- > ... withResolver seed ...+--+-- $newTypeExt+-- #newTypeExt#+--+-- For library authors designing an RR-data or EDNS-option+-- codec that needs to accept user-supplied typed extensions,+-- the steps below wire up 'TypeExtensible' for use with the+-- existing 'Net.DNSBase.Resolver.extendRRwithType' /+-- 'Net.DNSBase.Resolver.extendEdnsOptionWithType' API.+--+-- The 'Net.DNSBase.RData.SVCB.X_svcb' data type illustrates+-- the approach.  Its extension state is an 'Data.IntMap' table+-- mapping key numbers to 'Net.DNSBase.RData.SVCB.SVCParamValue' decoders.  Its+-- 'TypeExtensible' instance inserts new entries at their declared+-- 'Net.DNSBase.RData.SVCB.spvKey' slots.+--+-- The recipe is analogous on the RData and EDNS-option sides;+-- they differ only in the type class constraints on the extended+-- types:+--+-- * 'Net.DNSBase.RData.KnownRData', vs.+-- * 'Net.DNSBase.EDNS.Option.KnownEdnsOption'+--+-- and the names of the associated extension value types, and their+-- default (initial) value fields:+--+-- * Extension state types:+--     * 'Net.DNSBase.RData.RDataExtensionVal', vs.+--     * 'Net.DNSBase.EDNS.Option.OptionExtensionVal'+--+-- * Extension state default values:+--     * 'Net.DNSBase.RData.rdataExtensionVal'+--     * 'Net.DNSBase.EDNS.Option.optionExtensionVal'+--+-- /1.  Choose the codec's extension value type./+--+-- This is the state the decoder needs to make sense of known and+-- new DNS data and what the 'TypeExtensible' instance folds new+-- entries into.  For @SVCB@ it is a map from a+-- 'Net.DNSBase.RData.SVCB.SVCParamKey' codepoint to a decoder for+-- the associated 'Net.DNSBase.RData.SVCB.KnownSVCParamValue'+-- type.+--+-- /2.  Declare the state as part of the type class instance./+--+-- Override the associated extension-value type and its+-- default.  On the @RData@ side:+--+-- > instance ... => KnownRData MyType where+-- >     type RDataExtensionVal MyType = SomeState+-- >     rdataExtensionVal _ = baselineState -- the initial value+-- >     ...+-- >     rdDecode _ state len = ... decode using state + len ...+--+-- On the EDNS option side:+--+-- > instance ... => KnownEdnsOption MyType where+-- >     type OptionExtensionVal MyType = SomeState+-- >     optionExtensionVal _ = baselineState -- the initial value+-- >     ...+-- >     optDecode _ state len = ... decode using state + len ...+--+-- Plugins are only needed for decoding, with a typed value already+-- in hand the encoder can just use the value's encode method.+--+-- /3.  Define the 'TypeExtensible' instance./+--+-- Since the application provided type is not fixed in advance,+-- to be usable it must satisfy some superclass constraint that+-- makes it possible for the extension to provide actual input+-- to the customised decoder.  Therefore, the 'TypeExtensible'+-- instance needs to define a 'Data.Kind.Constraint' that+-- ensures that the newly registered type supports the requisite+-- methods.+--+-- The 'extendByType' method defined as part of the instance is+-- responsible for extracting from the provided type all the+-- information needed to extend its decoder to support the+-- novel type.  In the case of @SVCB@ the type is added to+-- the key codepoint number to decoder function map.+--+-- > instance TypeExtensible MyType SomeState where+-- >     type TypeExtensionArg MyType b = (MyExtensionClass b)+-- >     extendByType _ b state = ... -- update state with b+--+-- 'Net.DNSBase.Resolver.extendRRwithType' (or+-- 'Net.DNSBase.Resolver.extendEdnsOptionWithType' for an EDNS+-- option) passes each caller-supplied extension to+-- 'extendByType', which uses to update the state using the+-- methods of @MyExtensionClass@.+--+-- $newValueExt+-- #newValueExt#+--+-- For library authors designing an RR-data or EDNS-option+-- codec that needs to accept user-supplied value-driven+-- extensions, the recipe parallels the+-- [Type extensible case](#newTypeExt), with 'ValueExtensible'+-- in place of 'TypeExtensible' doing the work:+--+-- * 'Net.DNSBase.Resolver.extendRRwithValue'+-- * 'Net.DNSBase.Resolver.extendEdnsOptionWithValue'+--+-- The reference built-in example is+-- 'Net.DNSBase.EDNS.Option.EDE.O_ede', whose extension state is+-- an @IntMap@ of info-code to friendly-name entries and whose+-- 'ValueExtensible' instance inserts new entries into that map.+--+-- /1.  Choose the codec's extension state type/, and+--+-- /2.  Adjust the parent-class instance accordinly/.+--+-- For the EDE EDNS option, this is:+--+-- > instance KnownEdnsOption O_ede where+-- >     type OptionExtensionVal O_ede = IntMap ShortByteString+-- >     optionExtensionVal _ = baseEdeNames -- initial table+-- >     ...+-- >     optDecode _ state len = ... decode using @state@+--+-- /3.  Implement the 'ValueExtensible' instance./  In this case,+--+-- the constraint 'ValueExtensionArg' fixes the caller's value+-- type, and 'extendByValue' folds the value in.+--+-- > instance ValueExtensible O_ede (IntMap ShortByteString) where+-- >     type ValueExtensionArg O_ede b = b ~ (Word16, ShortByteString)+-- >     extendByValue _ (code, name) m =+-- >         IM.insert (fromIntegral code) name m+--+-- 'Net.DNSBase.Resolver.extendEdnsOptionWithValue' (or+-- 'Net.DNSBase.Resolver.extendRRwithValue' for an RR type)+-- passes each caller-supplied value to 'extendByValue'.
+ src/Net/DNSBase/Flags.hs view
@@ -0,0 +1,49 @@+{-|+Module      : Net.DNSBase.Flags+Description : DNS message header flags and resolver flag-control building blocks+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 'DNSFlags' field of a 'Net.DNSBase.Message.DNSMessage' carries the genuine+/flag/ bits from the basic DNS header+([RFC 1035 section 4.1.1](https://datatracker.ietf.org/doc/html/rfc1035#section-4.1.1))+— QR, AA, TC, RD, RA, Z, AD, CD: eight bits in total, of which+Z must be zero per the protocol, leaving seven in practical+use — plus the extended flag bits that arrive in the OPT+pseudo-RR+([RFC 6891 section 6.1.4](https://datatracker.ietf.org/doc/html/rfc6891#section-6.1.4)),+chiefly the DO bit.  The OPCODE and RCODE fields of the header+are masked out of 'DNSFlags' and carried separately in the+'Net.DNSBase.Message.DNSMessage' record.++The 'FlagOps' machinery is the building block resolver+'Net.DNSBase.Resolver.QueryControls' uses for per-call flag tweaks: 'setFlagBits' /+'clearFlagBits' / 'resetFlagBits' build endomorphisms that the+resolver applies to its default outgoing flags, so callers+specify only the bits they want to change rather than the+whole flag word.+-}++module Net.DNSBase.Flags+    ( -- * DNS Message basic and extended flags+      DNSFlags(..)+    -- * DNS flag construction and inspection+    , basicFlags+    , extendFlags+    , extendedFlags+    , hasAllFlags+    , hasAnyFlags+    , makeDNSFlags+    , maskDNSFlags+    -- * Resolver flag control building blocks+    , FlagOps+    , setFlagBits+    , clearFlagBits+    , resetFlagBits+    , emptyFlagOps+    , applyFlagOps+    ) where++import Net.DNSBase.Internal.Flags
+ src/Net/DNSBase/Lookup.hs view
@@ -0,0 +1,333 @@+{-|+Module      : Net.DNSBase.Lookup+Description : Per-RRtype lookup functions over a 'Resolver'+Copyright   : (c) IIJ Innovation Institute Inc., 2009+              (c) Viktor Dukhovni, 2020-2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable+-}+{-# LANGUAGE RecordWildCards #-}+module Net.DNSBase.Lookup+    ( Lookup+    , extractAnswers+    , lookupRawCtl+    , lookupRaw+    , lookupAnswers+    , lookupM+    , lookupM_+    , lookupX+    , lookupA+    , lookupAAAA+    , lookupAFSDB+    , lookupCAA+    , lookupCDNSKEY+    , lookupCDS+    , lookupCNAME+    , lookupDNAME+    , lookupDNSKEY+    , lookupDS+    , lookupHINFO+    , lookupHTTPS+    , lookupMX+    , lookupNS+    , lookupNSEC+    , lookupNSEC3PARAM+    , lookupNULL+    , lookupPTR+    , lookupRP+    , lookupSOA+    , lookupSRV+    , lookupSSHFP+    , lookupSVCB+    , lookupTLSA+    , lookupTXT+    , lookupZONEMD+    ) where+import qualified Data.Map.Strict as M+import Data.Foldable (foldlM)+import Data.Map.Strict (Map)+import Data.Maybe (mapMaybe)++import Net.DNSBase.Internal.Bytes+import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.Error+import Net.DNSBase.Internal.Message+import Net.DNSBase.Internal.RCODE+import Net.DNSBase.Internal.RData+import Net.DNSBase.Internal.RR+import Net.DNSBase.Internal.Transport+import Net.DNSBase.Internal.Util+import Net.DNSBase.Resolver.Internal.Types++import Net.DNSBase.RData.A+import Net.DNSBase.RData.CAA+import Net.DNSBase.RData.Dnssec+import Net.DNSBase.RData.SOA+import Net.DNSBase.RData.SRV+import Net.DNSBase.RData.SVCB+import Net.DNSBase.RData.TLSA+import Net.DNSBase.RData.TXT+import Net.DNSBase.RData.XNAME+import Net.DNSBase.RRCLASS+import Net.DNSBase.RRSet+import Net.DNSBase.RRTYPE++-- | Shape of a typed lookup: a 'Resolver' and a query 'Domain' produce+-- either a list of answers, or a 'DNSError'.  An empty list means that+-- either the name exists and has no records of the queried type+-- (@NODATA@), or the name does not exist (@NXDOMAIN@). Both are+-- non-error outcomes.+--+type Lookup a = Resolver -> Domain -> IO (Either DNSError [a])++-- | Generic answer-RData lookup, applying a function to each+-- result.  If the the function's first argument is polymorphic, a+-- type application at the call site may be needed to make it+-- possible to determine the type of its argument.+--+lookupX :: KnownRData a => RRTYPE -> (a -> b) -> Lookup b+lookupX typ f rslv dom =+    fmap (fmap getOnly) (lookupAnswers rslv mempty IN typ dom)+  where+    getOnly = mapMaybe (f <.> rrDataCast)++-- | Apply an IO action to each lookup value and collect the+-- results. If the the action's first argument is polymorphic,+-- a type application at the call site may be needed to make it+-- possible to determine the type of its argument.+--+lookupM :: forall a b. KnownRData a => (a -> IO b) -> Lookup b+lookupM f rslv = lookupAnswers rslv mempty IN (rdType a) >=> \ case+   Left why -> pure $ Left why+   Right rrs -> Right <$> foldlM go [] rrs+ where+    go acc rr = case rrDataCast rr of+        Just rd -> do+            !b <- f rd+            pure $ b : acc+        Nothing -> pure acc++-- | Apply an IO action to each lookup value and discard the+-- results. If the the action's first argument is polymorphic, a+-- type application at the call site may be needed to make it+-- possible to determine the type of its argument.+--+lookupM_ :: forall a b. KnownRData a+         => (a -> IO b) -> Resolver -> Domain -> IO (Either DNSError ())+lookupM_ f rslv = lookupAnswers rslv mempty IN (rdType a) >=> \ case+   Left why -> pure $ Left why+   Right rrs -> Right <$> go rrs+ where+    go (rr : rest) = case rrDataCast rr of+        Just rd -> f rd >> go rest+        Nothing -> go rest+    go [] = pure ()++-- | Perform a raw lookup returning the full 'DNSMessage' or a+-- 'DNSError'.  See 'lookupRawCtl' for the variant that takes+-- per-call query controls.+--+lookupRaw :: Resolver -> Domain -> RRCLASS -> RRTYPE+          -> IO (Either DNSError DNSMessage)+lookupRaw rslv = lookupRawCtl rslv mempty++-- | Perform a raw lookup with per-call 'QueryControls' overrides,+-- returning the full 'DNSMessage' or a 'DNSError'.  The supplied+-- controls are merged into the resolver's ambient query controls:+-- only the flag and EDNS bits specified in the controls affect the+-- outgoing query, the rest are inherited from the resolver+-- configuration.  Use 'lookupAnswers' (or the per-RRtype 'Lookup'+-- functions) when you want only the answer RRs for the requested+-- name and type, rather than the entire response 'DNSMessage'.+--+lookupRawCtl :: Resolver -> QueryControls -> Domain -> RRCLASS+             -> RRTYPE -> IO (Either DNSError DNSMessage)+lookupRawCtl rslv ctls dom qclass qtype =+    runDNSIO (lookupRawCtl_ rslv ctls dom qclass qtype)++-- | Find the RRs that answer the query, following any CNAMEs+-- found when there's no exact match for the qname and qtype.+-- Also returns any associated covering DNSSEC RRSIGs.+filterRelevant :: [RR] -> RRCLASS -> RRTYPE -> Domain -> [RR]+filterRelevant rrs qclass qtype =+    [ rr | rr <- rrs+    , rrClass rr == qclass+    , rrType rr == qtype || rrType rr == CNAME ]+    & rrSetsFromList+    & map (\s -> ((rrSetType s, rrSetOwner s), rrSetRecs s))+    & M.fromList+    & loop+  where+    -- Cycles are avoided by deleting traversed CNAMEs.+    loop :: Map (RRTYPE, Domain) [RR] -> Domain -> [RR]+    loop sm (canonicalise -> qname)+          | Just found <- M.lookup (qtype, qname) sm = found+          | (Just found, sm') <- M.alterF (, Just []) (CNAME, qname) sm+          , [t] <- [t | T_CNAME t <- monoRData $ map rrData found] = loop sm' t+          | otherwise = []++-------++-- | Perform the requested query and return the answer RRs from the+-- response, or a 'DNSError' carrying the RCODE for error responses.+-- The 'QueryControls' argument carries per-call tweaks; it is+-- merged onto the resolver's ambient query controls, so callers only+-- need to specify the flag and EDNS bits they want to change, the+-- rest are inherited from the resolver configuration.+--+-- Note that @NXDOMAIN@ is /not/ a lookup error.  An empty list of+-- RRs is returned for both @NODATA@ and @NXDOMAIN@.+--+-- If the nameserver's response does not include any RRs matching+-- query name and type, but does include a @CNAME@ record for the+-- requested name, the response is (recursively) rescanned for+-- records matching that name and type instead.  Note, no+-- additional queries are issued if the final CNAME found does+-- not lead to any record of the desired record type.+--+-- The returned RRs may include covering @DNSSEC@ signatures when the+-- 'Net.DNSBase.Flags.DOflag' is set as part of the 'QueryControls', and+-- the response was signed.+--+-- The presence of @RRSIG@ records does not however imply that the+-- response was /validated/ by the resolver.  For that one would+-- typically use a trusted DNSSEC-validating local (loopback)+-- resolver, to which the network path is immune to potential+-- active attacks, and inspect the 'Net.DNSBase.Flags.ADflag' in+-- the response message.+--+-- The full response 'DNSMessage' can be obtained via 'lookupRawCtl'.+--+lookupAnswers :: Resolver -> QueryControls -> RRCLASS -> RRTYPE -> Domain+              -> IO (Either DNSError [RR])+lookupAnswers rslv ctls cls typ dom = runDNSIO do+    msg <- lookupRawCtl_ rslv ctls dom cls typ+    extractAnswers_ msg++-- | Given a 'DNSMessage' return answer RRs that match its question,+-- possibly after /chasing/ @CNAME@ aliases within the answer+-- section of the message.+extractAnswers :: DNSMessage -> IO (Either DNSError [RR])+extractAnswers msg = runDNSIO (extractAnswers_ msg)++-- | Extract the answer RRs matching the question from a 'DNSMessage'+-- when the RCODE is non-error.+extractAnswers_ :: Monad m => DNSMessage -> ExceptT DNSError m [RR]+extractAnswers_ m@(dnsMsgQu -> [q])+    | NOERROR  <- dnsMsgRC m = pure $ filterRelevant (dnsMsgAn m) cls typ dom+    | NXDOMAIN <- dnsMsgRC m = pure []+    | YXDOMAIN <- dnsMsgRC m = pure []+    | otherwise              = throwE $ ResponseError $ dnsMsgRC m+  where+    dom = dnsTripleName q+    cls = dnsTripleClass q+    typ = dnsTripleType q+extractAnswers_ m =+    throwE $ UserError $ BadResponseQuestionCount $ length $ dnsMsgQu m+++-- | @IPv4@ addresses of query domain.+lookupA     :: Lookup IPv4+lookupA = lookupX A $ \(T_A ip) -> ip++-- | @IPv6@ addresses of query domain.+lookupAAAA  :: Lookup IPv6+lookupAAAA = lookupX AAAA $ \(T_AAAA ip) -> ip++-- | @CNAME@s of query domain (should be at most one).+lookupCNAME :: Lookup Domain+lookupCNAME = lookupX CNAME $ \(T_CNAME dom) -> dom++-- | @CAA@s @RData@ of query domain+lookupCAA :: Lookup T_caa+lookupCAA = lookupX CAA id++-- | @DNAME@s of query domain (should be at most one).+lookupDNAME :: Lookup Domain+lookupDNAME = lookupX DNAME $ \(T_DNAME dom) -> dom++-- | @PTR@ names of query domain.+lookupPTR   :: Lookup Domain+lookupPTR = lookupX PTR $ \(T_PTR dom) -> dom++-- | Nameservers of query domain.+lookupNS :: Lookup Domain+lookupNS = lookupX NS $ \(T_NS dom) -> dom++-- | @NULL@ RR payload of query domain.+lookupNULL  :: Lookup ShortByteString+lookupNULL = lookupX NULL $ \ (T_NULL b16) -> getShort16 b16++-- | @AFSDB@ RData of query domain.+lookupAFSDB  :: Lookup T_afsdb+lookupAFSDB = lookupX AFSDB id++-- | @CDNSKEY@ RData of query domain.+lookupCDNSKEY  :: Lookup T_cdnskey+lookupCDNSKEY = lookupX CDNSKEY id++-- | @CDS@ RData of query domain.+lookupCDS  :: Lookup T_cds+lookupCDS = lookupX CDS id++-- | @DNSKEY@ RData of query domain.+lookupDNSKEY  :: Lookup T_dnskey+lookupDNSKEY = lookupX DNSKEY id++-- | @DS@ RData of query domain.+lookupDS  :: Lookup T_ds+lookupDS = lookupX DS id++-- | @HINFO@ RData of query domain.+lookupHINFO  :: Lookup T_hinfo+lookupHINFO = lookupX HINFO id++-- | @HTTPS@ RData of query domain.+lookupHTTPS  :: Lookup T_https+lookupHTTPS = lookupX HTTPS id++-- | @MX@ RData of query domain.+lookupMX  :: Lookup T_mx+lookupMX = lookupX MX id++-- | @NSEC@ RData of query domain.+lookupNSEC  :: Lookup T_nsec+lookupNSEC = lookupX NSEC id++-- | @NSEC3PARAM@ RData of query domain.+lookupNSEC3PARAM  :: Lookup T_nsec3param+lookupNSEC3PARAM = lookupX NSEC3PARAM id++-- | @SOA@ RData of query domain.+lookupSOA  :: Lookup T_soa+lookupSOA = lookupX SOA id++-- | @RP@ RData of query domain.+lookupRP :: Lookup T_rp+lookupRP = lookupX RP id++-- | @SRV@ RData of query domain.+lookupSRV  :: Lookup T_srv+lookupSRV = lookupX SRV id++-- | @SSHFP@ RData of query domain.+lookupSSHFP  :: Lookup T_sshfp+lookupSSHFP = lookupX SSHFP id++-- | @SVCB@ RData of query domain.+lookupSVCB  :: Lookup T_svcb+lookupSVCB = lookupX SVCB id++-- | @TLSA@ RData of query domain.+lookupTLSA  :: Lookup T_tlsa+lookupTLSA = lookupX TLSA id++-- | @TXT@ RData of query domain.  Applications typically concatenate each list+-- of character strings into a single combined value.+lookupTXT  :: Lookup (NonEmpty ShortByteString)+lookupTXT = lookupX TXT \(T_TXT chunks) -> chunks++-- | @ZONEMD@ RData of query domain.+lookupZONEMD  :: Lookup T_zonemd+lookupZONEMD = lookupX ZONEMD id
+ src/Net/DNSBase/Message.hs view
@@ -0,0 +1,33 @@+{-|+Module      : Net.DNSBase.Message+Description : The DNS message container type and wire-form encoders+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++A 'DNSMessage' is the full DNS-protocol packet+([RFC 1035 section 4.1](https://datatracker.ietf.org/doc/html/rfc1035#section-4.1)):+a 16-bit query identifier, the flag word, and four sections+(question, answer, authority, additional) carrying the associated+'Net.DNSBase.RR.RR' lists.  The lookup functions return either a+whole 'DNSMessage' (via 'Net.DNSBase.Lookup.lookupRaw' /+'Net.DNSBase.Lookup.lookupRawCtl') or just the filtered answer+'Net.DNSBase.RR.RR' list (via 'Net.DNSBase.Lookup.lookupAnswers'+and the per-RR-type lookups).++'putMessage' and 'putRequest' are the wire-format encoders.+Applications building responses use 'putMessage' directly;+'putRequest' is the stub-resolver path used by+"Net.DNSBase.Internal.Transport".+-}++module Net.DNSBase.Message+    ( -- * DNS Message data type+      DNSMessage(..)+    , QueryID+    , putMessage+    , putRequest+    ) where++import Net.DNSBase.Internal.Message
+ src/Net/DNSBase/Nat16.hs view
@@ -0,0 +1,33 @@+{-|+Module      : Net.DNSBase.Nat16+Description : 16-bit type-level naturals indexing opaque RData+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++A 16-bit-constrained variant of 'Nat': the 'Nat16' constraint+carries enough type-level evidence to retrieve the numeric+codepoint at runtime via 'natToWord16'.  Used to index the+fallback 'Net.DNSBase.RData.OpaqueRData' /+'Net.DNSBase.EDNS.Option.OpaqueOption' /+'Net.DNSBase.RData.SVCB.OpaqueSPV' carriers+so that values for different RR / option / SVCB-parameter+codepoints inhabit distinct types even though they share a+single underlying representation.  'withNat16' brings a runtime+'Data.Word.Word16' value into scope as a 'Nat16'-instantiated type+variable.+-}+{-# LANGUAGE ExplicitNamespaces #-}++module Net.DNSBase.Nat16+    ( -- * 16-bit type-level naturals for Opaque RData+      type Nat+    , type Nat16+    , Typeable+    , natToWord16+    , withNat16+    )+    where++import Net.DNSBase.Internal.Nat16
+ src/Net/DNSBase/NonEmpty.hs view
@@ -0,0 +1,36 @@+{-|+Module      : Net.DNSBase.NonEmpty+Description : Non-empty-list interface for collection-shaped RR data+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 'NonEmpty' type from "Data.List.NonEmpty" plus a typeclass+'IsNonEmptyList' modelled on 'GHC.IsList.IsList': types like+'Net.DNSBase.RData.SVCB.SPV_mandatory' that hold a non-empty+collection can derive a conversion through this class without+having to provide the @[a]@-typed 'GHC.IsList.IsList' interface+that would tempt callers into supplying empty lists.+-}++module Net.DNSBase.NonEmpty+    ( IsNonEmptyList(..)+    , NonEmpty(..)+    ) where++import Data.List.NonEmpty (NonEmpty(..))+import Data.Kind (Type)++-- | Structures that can be converted to non-empty lists.  Note that+-- 'toNonEmptyList' and 'fromNonEmptyList' aren't necessarily inverses.+-- The result may, for example, be reordered or deduplicated.+class IsNonEmptyList a where+    type Item1 a      :: Type+    toNonEmptyList   :: a -> NonEmpty (Item1 a)+    fromNonEmptyList :: NonEmpty (Item1 a) -> a++instance IsNonEmptyList (NonEmpty a) where+    type Item1 (NonEmpty a) = a+    toNonEmptyList = id+    fromNonEmptyList = id
+ src/Net/DNSBase/NsecTypes.hs view
@@ -0,0 +1,389 @@+{-|+Module      : Net.DNSBase.NsecTypes+Description : Type-bitmap structures for NSEC, NSEC3, CSYNC, and legacy NXT+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The packed bitmap used to list which RR types are present at+(or relevant to) the owner name.  'NsecTypes' is the+window-based encoding from+[RFC 4034 section 4.1.2](https://datatracker.ietf.org/doc/html/rfc4034#section-4.1.2),+used by 'Net.DNSBase.RData.NSEC.T_nsec',+'Net.DNSBase.RData.NSEC.T_nsec3', and+'Net.DNSBase.RData.CSYNC.T_csync' to carry an arbitrary set of+'RRTYPE' codepoints in a compact form.  'NxtTypes' is the legacy+single-window encoding used by the obsolete @NXT@ record, which+restricts types to the first 128 codepoints.++'NsecTypes' is an instance of 'IsList' with @'Item' 'NsecTypes' =+'RRTYPE'@, so construction is via @'fromList' xs@ from+"GHC.IsList" (or @['A', 'AAAA', ...]@ under @OverloadedLists@,+via the associated 'RRTYPE' pattern synonyms) and enumeration+is via 'toList'.  The input list is deduplicated and reordered+into wire-form canonical order; an empty input produces the empty+bitmap.  'hasRRtype' is the efficient membership predicate used by+DNSSEC validators.++==== __Example__++> ghci> import qualified GHC.IsList as IL (fromList, toList)+> ghci> tys = IL.fromList @NsecTypes [MX, A, AAAA, A]+> ghci> tys+> fromList @NsecTypes [1,15,28]+> ghci> IL.toList tys+> [1,15,28]+> ghci> hasRRtype AAAA tys+> True+> ghci> hasRRtype NS tys+> False+-}+{-# LANGUAGE NegativeLiterals #-}++module Net.DNSBase.NsecTypes+    ( -- * NSEC/NSEC3/CSYNC Type Bitmap structure+      NsecTypes+    , nsecTypesFromList+    , nsecTypesToList+    , getNsecTypes+    , putNsecTypes+    , hasRRtype+    -- * Legacy type bitmap in NXT records+    , NxtTypes(..)+    , NxtRRtype+    , toNxtTypes+    , nxtTypesFromNE+    , nxtTypesToNE+    , getNxtTypes+    , hasNxtRRtype+    --+    , module Net.DNSBase.NonEmpty+    ) where++import qualified Data.Primitive.ByteArray as A+import qualified Data.ByteString.Short as SB+import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS+import GHC.IsList(IsList(..))++import Net.DNSBase.Internal.Util++import Net.DNSBase.Decode.State+import Net.DNSBase.Encode.State+import Net.DNSBase.NonEmpty+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RRTYPE+import Net.DNSBase.Text++-----------------++-- | Abstract representation of a set of 'RRTYPE' codepoints,+-- stored as the window-based wire-format bitmap from RFC 4034+-- section 4.1.2.  Used by 'Net.DNSBase.RData.NSEC.T_nsec',+-- 'Net.DNSBase.RData.NSEC.T_nsec3', and+-- 'Net.DNSBase.RData.CSYNC.T_csync' to carry the set of types+-- present at the owner name.+--+-- An 'NsecTypes' may legitimately be empty -- this is the+-- expected encoding for an NSEC3 empty-non-terminal.  With NSEC,+-- the type bitmap is expected to include at least the 'NSEC' type+-- itself; that invariant is not enforced by the type.+--+-- Construction and enumeration go through 'IsList':+--+-- * @'fromList' tys :: 'NsecTypes'@ builds the bitmap from a list+--   of 'RRTYPE' values; duplicates are merged and the wire-form+--   ordering is canonical regardless of input order.  Under+--   @OverloadedLists@ the same input shape is just @[A, AAAA, MX]@.+-- * @'toList' bm :: ['RRTYPE']@ enumerates the contained types in+--   ascending wire-form order.+-- * @('<>')@ unions two bitmaps; 'mempty' is the empty bitmap.+--+-- For membership without enumerating the whole set, use+-- 'hasRRtype', which goes directly to the relevant window, block+-- and bit offset.+newtype NsecTypes = NsecTypes (IM.IntMap ShortByteString) deriving Eq++-- | The 'Ord' instance matches wire-form canonical order.+instance Ord NsecTypes where+    a `compare` b = asDnsTextMap a `compare` asDnsTextMap b+      where+        asDnsTextMap :: NsecTypes -> IM.IntMap DnsText+        asDnsTextMap = coerce++-- | Construction is via 'fromList' (from any list of 'RRTYPE's,+-- order and duplicates immaterial), and enumeration is via+-- 'toList' (yielding types in canonical wire-form order).+instance IsList NsecTypes where+    type Item NsecTypes = RRTYPE++    -- | Return the contained types in ascending wire-form order.+    toList   = nsecTypesToList++    -- | Build the bitmap from a list of types, deduplicating and+    -- ordering as needed.  An empty input produces the empty+    -- bitmap.+    fromList = nsecTypesFromList++instance Show NsecTypes where+    showsPrec p (toList -> tys) = showsP p $+        showString "fromList @NsecTypes "+        . shows' tys++-- | Presentation form: contained types in canonical wire-form+-- order, space-separated, with no leading separator.  The empty+-- bitmap renders as the empty string.  When the bitmap follows+-- another field in an RR's presentation form, compose with+-- 'presentSp' or 'presentLn' to prefix the appropriate separator.+instance Presentable NsecTypes where+    present ts k = case toList ts of+        t : rest -> present t $ foldr presentSp k rest+        []       -> k++-- | The @('<>')@ operator unions the two bitmaps; duplicate+-- types are merged.+instance Semigroup NsecTypes where+    a <> b = coerce $ IM.unionWith mergeBitmaps (coerce a) (coerce b)++-- | Combine two "window" bitmaps by folding the shorter bitmap into a new copy+-- of the longer.+mergeBitmaps :: ShortByteString -> ShortByteString -> ShortByteString+mergeBitmaps win1 win2+    | SB.length win1 >= SB.length win2 = merge win1 win2+    | otherwise                        = merge win2 win1+  where+    merge sb1 sb2@(SB.length -> len2) = baToShortByteString $ A.runByteArray do+        muta <- sbsToMutableByteArray sb1+        let a = sbsToByteArray sb2+        sequence_ [ modifyArray muta i (.|. A.indexByteArray a i)+                  | i <- [0..len2 - 1] ]+        pure muta++-- | Unpack map to list of (window, blocks) pairs+toBitmaps :: NsecTypes -> [(Int, ShortByteString)]+toBitmaps = IM.toList . coerce++-- | Efficient NSEC/NSEC3 type bitmap membership predicate.+hasRRtype :: RRTYPE -> NsecTypes -> Bool+hasRRtype (splitRRtype -> (window, block, bitpos)) (coerce -> im)+    | Just sb <- IM.lookup window im+    , Just byte <- SB.indexMaybe sb block+      = testBit byte bitpos+    | otherwise = False++-- | Convert 'NsecTypes' bitmap to an 'RRTYPE' list+nsecTypesToList :: NsecTypes -> [RRTYPE]+nsecTypesToList = foldr (uncurry windowTypes) [] . toBitmaps+  where+    windowTypes :: Int -> ShortByteString -> [RRTYPE] -> [RRTYPE]+    windowTypes (fromIntegral -> window) = go 0 . SB.unpack+      where+        go :: Word16 -> [Word8] -> [RRTYPE] -> [RRTYPE]+        go !block (w : ws) r+            | z <- countLeadingZeros w+            , z < 8+            , ty <- window .|. block .|. fromIntegral z+              = RRTYPE ty : go block (w `clearBit` (7-z) : ws) r+            | otherwise = go (block + 8) ws r+        go _ _ r = r++-- | Construct the per-window bitmaps from a list of types.+--+nsecTypesFromList :: [RRTYPE] -> NsecTypes+nsecTypesFromList (IS.fromList . map fromIntegral -> tys) =+    -- The list is initially sorted and deduplicated by building a temporary+    -- set, The ordered types from the set are folded into words, which are+    -- then folded into a bitmap by via a mutable unboxed 'Word8' array, whose+    -- underlying storage is finally repackaged as a 'SB.ShortByteString'.+    NsecTypes $ IM.fromAscList $ go Nothing tys+  where+    go bit0 (IS.null -> True)+        | Just off <- bit0 = (off, SB.singleton 0x80) : []+        | otherwise        = []+    go bit0 s@((.&. 0xff00) . IS.findMin -> winbot)+        | bit0 == Just winbot+        , sb <- newSB top (winbot : IS.toList this)+        , slice <- (winbot, sb)+          = slice : go next0 rest+        | sb <- newSB top (IS.toList this)+        , out <- (winbot, sb) : go next0 rest+          = maybe id loner bit0 out+      where+        loner zero = (:) (zero, SB.singleton 0x80)+        winnxt = winbot + 256+        (this, full, rest) = IS.splitMember winnxt s+        top = (IS.findMax this `shiftR` 3) .&. 0x001f+        next0 = bool Nothing (Just winnxt) full++    newSB top = baToShortByteString . mkArray+      where+        mkArray :: [Int] -> ByteArray+        mkArray ts = A.runByteArray do+            a <- A.newByteArray $ top + 1+            A.fillByteArray a 0 (top + 1) 0+            sequence_+                [ modifyArray a byte (`setBit` bitpos)+                | t <- ts+                , let byte = fromIntegral $ (t `shiftR` 3) .&. 0x1f+                , let bitpos = 7 - fromIntegral (t .&. 0x7) ]+            pure a++-- <https://tools.ietf.org/html/rfc4034#section-4.1>+-- Parse a list of NSEC type bitmaps.  The windows are required to be in+-- strictly ascending order.+--+getNsecTypes :: Int -> SGet NsecTypes+getNsecTypes !len = do+    pos0 <- getPosition+    loop (pos0 + len) -1 pos0 $ IM.empty+  where+    loop :: Int -> Int -> Int -> IM.IntMap ShortByteString -> SGet NsecTypes+    loop !end = go+      where+        go :: Int -> Int -> IM.IntMap ShortByteString -> SGet NsecTypes+        go _     !pos0 !m | pos0 == end = pure $ coerce m+        go !off0 !_    !m = do+            off1 <- getOffset+            when (off1 <= off0) do+                failSGet "Non-monotone NSEC window offsets"+            blks <- getBlocks+            pos1 <- getPosition+            go off1 pos1 $ IM.insert off1 blks m++    getOffset = (`shiftL` 8) <$> getInt8++    getBlocks = do+        nblk <- fromIntegral <$> getInt8+        when (nblk > 32) do+           failSGet "Bad NSEC bitmap block count"+        !blks <- getShortNByteString nblk+        case SB.indexMaybe blks (nblk - 1)  of+            Nothing -> failSGet "Empty NSEC bitmap window"+            Just 0  -> failSGet "Empty NSEC bitmap tail block"+            _       -> pure blks++-- | Output the bitmaps.+--+putNsecTypes :: NsecTypes -> SPut s RData+putNsecTypes = mapM_ (uncurry putBitmap) . toBitmaps+  where+    putBitmap offset sb = do+        put8 $ fromIntegral $ offset `shiftR` 8+        putShortByteStringLen8 sb++-- | Split rrtype as window offset, block and bit position.+splitRRtype :: RRTYPE -> (Int, Int, Int)+splitRRtype (fromIntegral -> ty) = (window, block, bitpos)+  where+    !window = ty .&. 0xff00+    !winrel = ty .&. 0x00ff+    !block  = winrel `shiftR` 3+    !bitpos = complement winrel .&. 0x07++-----------------++-- | An RRtype representable in an @NXT@ RR bitmap.+newtype NxtRRtype = RT7 Word16 deriving (Eq, Ord)++instance Bounded NxtRRtype where+    minBound = RT7 0+    maxBound = RT7 127++instance Enum NxtRRtype where+    fromEnum (RT7 t) = fromIntegral t+    toEnum i | i >= 0 && i < 128 = RT7 $ fromIntegral i+             | otherwise = errorWithoutStackTrace "NxtRRtype.toEnum: bad argument"+    pred (RT7 t) | t > 0 = RT7 (t - 1)+                 | otherwise = errorWithoutStackTrace "NxtRRtype.pred: bad argument"+    succ (RT7 t) | t < 127 = RT7 (t + 1)+                 | otherwise = errorWithoutStackTrace "NxtRRtype.succ: bad argument"++instance Show NxtRRtype where+    showsPrec p = showsPrec @RRTYPE p . coerce++instance Presentable NxtRRtype where+    present = present @RRTYPE . coerce++newtype NxtTypes = NxtTypes ShortByteString deriving Eq++-- | The 'Ord' instance matches wire-form canonical order.+instance Ord NxtTypes where+    (NxtTypes a) `compare` (NxtTypes b) = a `compare` b++instance IsNonEmptyList NxtTypes where+    type Item1 NxtTypes = NxtRRtype+    toNonEmptyList   = nxtTypesToNE+    fromNonEmptyList = nxtTypesFromNE++instance Presentable NxtTypes where+    present (toNonEmptyList -> (ty :| tys)) =+        present          ty+        . flip (foldr presentSp) tys++instance Show NxtTypes where+    showsPrec p (toNonEmptyList -> tys) = showsP p $+        showString "fromNonEmptyList @NxtTypes " . shows' tys++-- | Concatentation va @('<>')@ operator merges the two bitmaps.+instance Semigroup NxtTypes where+    a <> b = coerce $ mergeBitmaps (coerce a) (coerce b)++-- | An error if any of input RRtypes are above 127.+toNxtTypes :: NonEmpty RRTYPE -> NxtTypes+toNxtTypes = fromNonEmptyList . fmap (toEnum . fromIntegral)++-- | Reconstruct RRTYPE list from bitmap.+nxtTypesToNE :: NxtTypes -> NonEmpty NxtRRtype+nxtTypesToNE = fromList . go 0 . SB.unpack . coerce+  where+    go :: Word16 -> [Word8] -> [NxtRRtype]+    go !block (w : ws)+        | z <- countLeadingZeros w+        , z < 8+        , ty <- block .|. fromIntegral z+          = RT7 ty : go block (w `clearBit` (7-z) : ws)+        | otherwise = go (block + 8) ws+    go _ _ = []++forceNxt :: NonEmpty NxtRRtype -> [Int]+forceNxt (ty :| tys) =+    fromIntegral NXT : fromEnum ty : map fromEnum tys++-- | Construct the bitmap from a non-empty list of types.+nxtTypesFromNE :: NonEmpty NxtRRtype -> NxtTypes+nxtTypesFromNE (IS.fromList . forceNxt -> s) =+    NxtTypes $ newSB (IS.toList s)+  where+    top = (IS.findMax s `shiftR` 3) .&. 0x001f+    newSB = baToShortByteString . mkArray+      where+        mkArray :: [Int] -> ByteArray+        mkArray ts = A.runByteArray do+            a <- A.newByteArray $ top + 1+            A.fillByteArray a 0 (top + 1) 0+            sequence_+                [ modifyArray a byte (`setBit` bitpos)+                | t <- ts+                , let byte = fromIntegral $ (t `shiftR` 3) .&. 0x1f+                , let bitpos = 7 - fromIntegral (t .&. 0x7) ]+            pure a++-- | Efficient NXT type bitmap membership predicate.+hasNxtRRtype :: RRTYPE -> NxtTypes -> Bool+hasNxtRRtype (splitRRtype -> (window, block, bitpos)) (coerce -> sb)+    | window == 0+    , Just byte <- SB.indexMaybe sb block+      = testBit byte bitpos+    | otherwise = False++getNxtTypes :: Int -> SGet NxtTypes+getNxtTypes !len = do+    when (len < 4 || len > 16) do+       failSGet "Bad NXT bitmap size"+    !blks <- getShortNByteString len+    case SB.indexMaybe blks (len - 1)  of+        Nothing -> failSGet "Empty NXT bitmap" -- not possible+        Just 0  -> failSGet "Empty NSEC bitmap last byte"+        _       -> pure $ coerce blks
+ src/Net/DNSBase/Opcode.hs view
@@ -0,0 +1,21 @@+{-|+Module      : Net.DNSBase.Opcode+Description : DNS message OPCODE values (RFC 1035 section 4.1.1)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 4-bit @OPCODE@ field of a DNS message header — usually+@QUERY@ for ordinary lookups, with @IQUERY@, @STATUS@,+@NOTIFY@, and @UPDATE@ for less common message kinds.  See the+[IANA DNS Operation Codes registry](https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-5)+for the full list.+-}++module Net.DNSBase.Opcode+    ( -- * DNS request and reply OPCODE numbers+      Opcode(..)+    ) where++import Net.DNSBase.Internal.Opcode
+ src/Net/DNSBase/Present.hs view
@@ -0,0 +1,47 @@+{-|+Module      : Net.DNSBase.Present+Description : Zone-file presentation form: the 'Presentable' class and helpers+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 'Presentable' typeclass renders DNS data into the conventional zone-file+textual form+([RFC 1035 section 5](https://datatracker.ietf.org/doc/html/rfc1035#section-5),+with later refinements).  Instances produce 'Data.ByteString.Builder.Builder'+fragments, which are stitched together by the small combinator set+('presentSp', 'presentCharSep', 'presentLn', and friends) for separators and+line breaks.  'presentString' and 'presentStrict' run the builder to a 'String'+or strict 'Data.ByteString.ByteString' for final output; 'putBuilder' writes a+builder to stdout.++The 'Epoch64' newtype renders a 64-bit absolute time as the+RFC 4034 14-digit @YYYYMMDDHHmmSS@ string used in RRSIG+timestamps.+-}++module Net.DNSBase.Present+    ( Presentable(..)+    -- ** Builder combinators+    , presentByte+    , presentCharSep+    , presentCharSepLn+    , presentLn+    , presentSep+    , presentSepLn+    , presentSp+    , presentSpLn+    -- *** Newtype to present 64-bit epoch times.+    , Epoch64(..)+    -- ** Build directly to a 'String' or 'Data.ByteString.ByteString'+    , presentString+    , presentStrict+    -- ** Re-exported from "Data.ByteString.Builder"+    , Builder+    , hPutBuilder+    -- *** 'hPutBuilder' specialised to @stdout@+    , putBuilder+    ) where++import Net.DNSBase.Internal.Present
+ src/Net/DNSBase/RCODE.hs view
@@ -0,0 +1,25 @@+{-|+Module      : Net.DNSBase.RCODE+Description : DNS message response codes (RFC 1035, RFC 6891)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The RCODE that the server returns in a DNS response.  The+original RCODE was a 4-bit field in the DNS header+([RFC 1035 section 4.1.1](https://datatracker.ietf.org/doc/html/rfc1035#section-4.1.1));+EDNS extends it to 12 bits via the @EXTENDED-RCODE@ field of+the OPT pseudo-RR+([RFC 6891 section 6.1.3](https://datatracker.ietf.org/doc/html/rfc6891#section-6.1.3)).+See the+[IANA DNS RCODEs registry](https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-6)+for the full list.+-}++module Net.DNSBase.RCODE+    ( -- * DNS Message response codes+      RCODE(..)+    ) where++import Net.DNSBase.Internal.RCODE
+ src/Net/DNSBase/RData.hs view
@@ -0,0 +1,64 @@+{-|+Module      : Net.DNSBase.RData+Description : Existential wrapper and extensibility hooks for RR-data payloads+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The existential 'RData' wrapper holds any 'KnownRData'+instance, so a heterogeneous list of records — an answer+section, a zone — can share a single Haskell type.+'fromRData' and 'rdataType' recover the underlying value or+its type code; 'monoRData' is the bulk form, filtering a list+of 'RData' values by type.++Unrecognised RR types decode into 'OpaqueRData', which+preserves the raw wire bytes under a type-level codepoint and+presents in the generic+[RFC 3597](https://datatracker.ietf.org/doc/html/rfc3597)+@\#@-prefixed form.++Advanced applications can add support for any missing RR types,+not yet supported by the library, by implementing a corresponding+'KnownRData' instance and exposing it to the resolver via+'Net.DNSBase.Resolver.registerRRtype' (see+"Net.DNSBase.Resolver").  'KnownRData' carries any per-type+extension value ('RDataExtensionVal') the codec consumes.+RR types that admit type-driven extension (presently, just SVCB+and HTTPS) /also/ implement a 'TypeExtensible' instance whose+'extendByType' method is invoked by+'Net.DNSBase.Resolver.extendRRwithType'.++The encoder and decoder combinator modules are re-exported for+the benefit of authors of new 'KnownRData' instances; ordinary+callers do not need them.+-}++module Net.DNSBase.RData+    ( -- * Basic RData API+      RData(..)+    , fromRData+    , monoRData+    , rdataType+      -- * Opaque RData+    , OpaqueRData(..)+    , opaqueRData+    , toOpaqueRData+    , fromOpaqueRData+      -- * Extensibility+    , KnownRData(..)+    , TypeExtensible(..)+    , RDataCodec+      -- * Encoder and Decoder combinators+    , module Net.DNSBase.Decode.State+    , module Net.DNSBase.Encode.Metric+    , module Net.DNSBase.Encode.State+    ) where++import Net.DNSBase.Decode.Internal.RData+import Net.DNSBase.Decode.State+import Net.DNSBase.Encode.Metric+import Net.DNSBase.Encode.State+import Net.DNSBase.Extensible+import Net.DNSBase.Internal.RData
+ src/Net/DNSBase/RData/A.hs view
@@ -0,0 +1,93 @@+{-|+Module      : Net.DNSBase.RData.A+Description : Address records (A and AAAA)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The two address RR types parallel the variants of 'Data.IP.IP':+'T_a' wraps the @A@ RR's 'IPv4' payload, 'T_aaaa' wraps the+@AAAA@ RR's 'IPv6' payload.  Construct or destructure via the+@T_A@ / @T_AAAA@ pattern constructors.  When working with a+polymorphic 'RData' value that may be either, 'evalIP'+dispatches on whichever applies and lifts the address into the+common 'Data.IP.IP' sum.+-}++module Net.DNSBase.RData.A+    ( T_a(..)+    , T_aaaa(..)+    , evalIP+    ) where+import Data.IP (IP(..), IPv4, IPv6)++import Net.DNSBase.Decode.State+import Net.DNSBase.Encode.State+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RRTYPE+import Net.DNSBase.Internal.Util (showsP)++-- | The @A@ resource record+-- ([RFC 1035 section 3.4.1](https://tools.ietf.org/html/rfc1035#section-3.4.1))+-- — a 32-bit IPv4 address transmitted as four bytes in network+-- order.  The derived 'Ord' is numeric 'IPv4' order, which agrees+-- with canonical RR-content ordering+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+--+-- See 'T_aaaa' for the IPv6-family parallel, and 'evalIP' for a+-- helper that handles either uniformly.+newtype T_a = T_A IPv4 -- ^ 'IPv4' address+    deriving (Eq, Ord, Enum)++instance Show T_a where+    showsPrec p (T_A a) = showsP p $+        showString "T_A \"" . shows a . showChar '"'++instance Presentable T_a where+    present (T_A a) = present a++instance KnownRData T_a where+    rdType _ = A+    {-# INLINE rdType #-}+    rdEncode (T_A ip4) = putIPv4 ip4+    rdDecode _ _ = const do RData . T_A <$> getIPv4+++-- | The @AAAA@ resource record+-- ([RFC 3596 section 2.1](https://tools.ietf.org/html/rfc3596#section-2.1))+-- — a 128-bit IPv6 address transmitted as sixteen bytes in network+-- order.  The derived 'Ord' is numeric 'IPv6' order, which agrees+-- with canonical RR-content ordering+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+--+-- See 'T_a' for the IPv4-family parallel, and 'evalIP' for a+-- helper that handles either uniformly.+newtype T_aaaa = T_AAAA IPv6 -- ^ 'IPv6' address+    deriving (Eq, Ord)++instance Show T_aaaa where+    showsPrec p (T_AAAA a) = showsP p $+        showString "T_AAAA \"" . shows a . showChar '"'++instance Presentable T_aaaa where+    present (T_AAAA a) = present a++instance KnownRData T_aaaa where+    rdType _ = AAAA+    {-# INLINE rdType #-}+    rdEncode (T_AAAA ip6) = putIPv6 ip6+    rdDecode _ _ = const do RData . T_AAAA <$> getIPv6+++-- | Apply the supplied function to whichever IP address an 'RData'+-- carries, lifting the 'T_a' or 'T_aaaa' payload into the unified+-- 'Data.IP.IP' sum.  Returns 'Nothing' for 'RData' of any other type.+--+-- > evalIP id (RData (T_A    ip)) == Just (IPv4 ip)+-- > evalIP id (RData (T_AAAA ip)) == Just (IPv6 ip)+evalIP :: (IP -> a) -> RData -> Maybe a+evalIP f (fromRData -> Just (T_A ip))    = Just $! f (IPv4 ip)+evalIP f (fromRData -> Just (T_AAAA ip)) = Just $! f (IPv6 ip)+evalIP _ _                               = Nothing
+ src/Net/DNSBase/RData/CAA.hs view
@@ -0,0 +1,86 @@+{-|+Module      : Net.DNSBase.RData.CAA+Description : Certification Authority Authorization (CAA)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable+-}+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.RData.CAA+    ( -- * Certification Authority Authorisation+      T_caa(..)+    , validCaaTag+    ) where++import qualified Data.ByteString.Short as SB++import Net.DNSBase.Internal.Util++import Net.DNSBase.Decode.State+import Net.DNSBase.Encode.Metric+import Net.DNSBase.Encode.State+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RRTYPE+import Net.DNSBase.Text++-- | The @CAA@ resource record+-- ([RFC 8659 section 4.1](https://www.rfc-editor.org/rfc/rfc8659.html#section-4.1))+-- — three fields: an 8-bit flag byte, an ASCII-alphanumeric property+-- /tag/ (1..255 bytes), and the property's value (free-form bytes).+--+-- Tags are compared case-sensitively when comparing 'T_caa'+-- 'RData' objects.  CAs are required by RFC 8659 to handle tags+-- case-insensitively; that's a check for application-layer code,+-- not for the wire-format codec.  Use 'validCaaTag' to verify a+-- tag's syntactic constraints before encoding.+--+-- The 'Ord' instance compares the flag byte, then tag length,+-- then tag bytes, then value bytes — wire-encoding order, so it+-- agrees with the canonical RR-content ordering of+-- [RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2).+data T_caa = T_CAA+    { caaFlags :: Word8+    , caaTag   :: ShortByteString+    , caaValue :: ShortByteString }+    deriving (Eq, Show)++instance Ord T_caa where+    a `compare` b = caaFlags  a `compare` caaFlags  b+                 <> tagLength a `compare` tagLength b+                 <> caaTag    a `compare` caaTag    b+                 <> caaValue  a `compare` caaValue  b+      where+        tagLength = SB.length . caaTag++instance Presentable T_caa where+    present T_CAA{..}+        = present caaFlags+          . presentSp caaTag+          . presentSp @DnsText (coerce caaValue)++instance KnownRData T_caa where+    rdType _ = CAA+    rdEncode T_CAA{..}+        | validCaaTag caaTag = putSizedBuilder $+                                   mbWord8 caaFlags+                                <> mbShortByteStringLen8 caaTag+                                <> mbShortByteString caaValue+        | otherwise         = failWith CantEncode+    rdDecode _ _ = const do+        caaFlags <- get8+        caaTag   <- getShortByteStringLen8+        when (not $ validCaaTag caaTag) $ failSGet "CAA tag not alphanumeric"+        caaValue <- getShortByteString+        pure $ RData T_CAA{..}++-- | Verify a CAA tag's syntactic constraints: non-empty and made+-- entirely of ASCII alphanumeric bytes (RFC 8659 section 4.2).  Required+-- before encoding; the decoder applies the same check and rejects+-- a wire-form 'T_caa' whose tag fails it.+validCaaTag :: ShortByteString -> Bool+validCaaTag = (&&) <$> not . SB.null <*> SB.all isalnum+  where+    isalnum w = w - 0x30 < 10 || (w .&. 0xdf) - 0x41 < 26
+ src/Net/DNSBase/RData/CSYNC.hs view
@@ -0,0 +1,166 @@+{-|+Module      : Net.DNSBase.RData.CSYNC+Description : Child-to-parent signalling records (CSYNC and DSYNC)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++Two unrelated child-to-parent signalling RR types live here.+'T_csync' (RFC 7477) tells the parent zone which delegation+records the child wishes to have synchronized; 'T_dsync'+(generalised DNS notifications, draft-ietf-dnsop-generalized-notify)+advertises the per-RR-type endpoints a child operator wishes+the parent to send notifications to.  They share neither wire+format nor purpose beyond the broad child-to-parent direction.+-}+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.RData.CSYNC+    ( -- * CSYNC RData+      T_csync(..)+    , NsecTypes+    , nsecTypesFromList+    , nsecTypesToList+    , hasRRtype+      -- * DSYNC RData+    , T_dsync(..)+    , Dscheme(.., NOTIFY)+    ) where++import Net.DNSBase.Internal.Util++import Net.DNSBase.Decode.Domain+import Net.DNSBase.Decode.State+import Net.DNSBase.Domain+import Net.DNSBase.Encode.State+import Net.DNSBase.NsecTypes+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RRTYPE++-----------------++-- | The @CSYNC@ resource record+-- ([RFC 7477 section 2.1.1](https://www.rfc-editor.org/rfc/rfc7477.html#section-2.1.1))+-- — the child zone's request to its parent to synchronise NS / A /+-- AAAA records from the child to the parent.  Three fields: the+-- child's current SOA serial, processing flags, and an 'NsecTypes'+-- bitmap naming the RR types to be synchronised.+--+-- >                      1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3+-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |                          SOA Serial                           |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |       Flags                   |            Type Bit Map       /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > /                     Type Bit Map (continued)                  /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- See 'T_dsync' for the other child-to-parent signalling RR type+-- defined in this module.+data T_csync = T_CSYNC+    { csyncSerial :: Word32    -- ^ Zone serial number+    , csyncFlags  :: Word16    -- ^ flag Bits+    , csyncTypes  :: NsecTypes -- ^ Type Bitmap+    } deriving (Eq, Show)++instance Ord T_csync where+    a `compare` b = csyncSerial a `compare` csyncSerial b+                 <> csyncFlags  a `compare` csyncFlags  b+                 <> csyncTypes  a `compare` csyncTypes  b++instance Presentable T_csync where+    present T_CSYNC{..} =+        present     csyncSerial+        . presentSp csyncFlags+        . presentSp csyncTypes++instance KnownRData T_csync where+    rdType _ = CSYNC+    {-# INLINE rdType #-}+    rdEncode T_CSYNC{..} = do+        putSizedBuilder $+           mbWord32 csyncSerial+           <> mbWord16 csyncFlags+        putNsecTypes csyncTypes+    rdDecode _ _ len = do+        csyncSerial <- get32+        csyncFlags  <- get16+        csyncTypes <- getNsecTypes (len - 6)+        pure $ RData T_CSYNC{..}++-----------------++-- | DSYNC scheme numbers.  The 'Presentable' instance displays the registered+-- mnemonic of the scheme name for known types, or else just the decimal value.+-- See the+-- [IANA registry](https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dsync-location-of-synchronization-endpoints)+-- for the known mnemonics.+--+newtype Dscheme = DSCHEME Word8+    deriving newtype ( Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read )++-- | [NOTIFY scheme](https://datatracker.ietf.org/doc/html/rfc9859#section-6.2).+pattern NOTIFY      :: Dscheme;     pattern NOTIFY         = DSCHEME 1++instance Presentable Dscheme where+    present NOTIFY       = present @String "NOTIFY"+    present (DSCHEME n)  = present n+++-- | The @DSYNC@ resource record+-- ([RFC 9859](https://datatracker.ietf.org/doc/html/rfc9859#section-2.1))+-- — a child zone's published endpoint for generalised DNS+-- notifications: for a given child-side 'RRTYPE', it names the+-- 'Dscheme' (contact method, e.g.\ 'NOTIFY'), the contact 'Word16'+-- port number, and the 'Domain' to address the notification to.+--+-- >                      1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3+-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > | RRtype                        | Scheme        | Port+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- >                 | Target ...  /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-/+--+-- See 'T_csync' for the other child-to-parent signalling RR type+-- defined in this module.+--+-- Target comparison and equality are case-sensitive.+-- The 'Ord' instance is canonical.+data T_dsync = T_DSYNC+    { dsyncRRtype :: RRTYPE    -- ^ Supported notification type+    , dsyncScheme :: Dscheme   -- ^ Contact mode+    , dsyncPort   :: Word16    -- ^ Contact port+    , dsyncTarget :: Domain    -- ^ Server hostname+    } deriving (Eq, Show)++instance Ord T_dsync where+    a `compare` b = dsyncRRtype a `compare` dsyncRRtype b+                 <> dsyncScheme a `compare` dsyncScheme b+                 <> dsyncPort   a `compare` dsyncPort   b+                 <> dsyncTarget a `compare` dsyncTarget b++instance Presentable T_dsync where+    present T_DSYNC{..} =+        present     dsyncRRtype+        . presentSp dsyncScheme+        . presentSp dsyncPort+        . presentSp dsyncTarget++instance KnownRData T_dsync where+    rdType _ = DSYNC+    {-# INLINE rdType #-}+    rdEncode T_DSYNC{..} = putSizedBuilder $+        mbWord16 (coerce dsyncRRtype)+        <> mbWord8 (coerce dsyncScheme)+        <> mbWord16 dsyncPort+        <> mbWireForm dsyncTarget+    rdDecode _ _ _ = do+        dsyncRRtype <- RRTYPE <$> get16+        dsyncScheme <- DSCHEME <$> get8+        dsyncPort   <- get16+        dsyncTarget <- getDomainNC+        pure $ RData T_DSYNC{..}
+ src/Net/DNSBase/RData/Dnssec.hs view
@@ -0,0 +1,865 @@+{-|+Module      : Net.DNSBase.RData.Dnssec+Description : DNSSEC chain-of-trust records (DS, DNSKEY, RRSIG, plus IPSECKEY and ZONEMD)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The DNSSEC chain-of-trust RR types from RFC 4034 — 'T_ds',+'T_dnskey', 'T_rrsig' — plus their parent\/child mirror+announcements: 'T_cds' and 'T_cdnskey' (RFC 7344) carry the+child-side signalling of which DS and DNSKEY records the parent+should publish.  The legacy 'T_key' and 'T_sig' records, still+used by SIG(0) transaction authentication (RFC 2535, RFC 2931),+share a codec with their DNSSEC successors.++The three groups DS\/CDS, DNSKEY\/CDNSKEY\/KEY, and SIG\/RRSIG+each have a single underlying data type ('X_ds', 'X_key',+'X_sig') with the RR type carried at the type level.  DS and+KEY have the @phantom@ type role on @n@, so values are+mutually coercible; the SIG family has @nominal@, since SIG(0)+signs a single transaction while RRSIG signs an RRSet, and+conflating them at the type level would be unsafe.++'T_ipseckey' (RFC 4025) and 'T_zonemd' (RFC 8976) live here+too, alongside the re-export of "Net.DNSBase.RData.NSEC" for+the denial-of-existence records.+-}+{-# LANGUAGE+    MagicHash+  , RecordWildCards+  , UndecidableInstances+  #-}+module Net.DNSBase.RData.Dnssec+    ( -- * DS and DNSKEY+      -- ** DS resource records+      X_ds(.., T_DS, T_CDS)+    , type XdsConName, T_ds, T_cds+      -- *** DS fields+    , dsKtag, dsKalg, dsHalg, dsHval+      -- *** CDS fields+    , cdsKtag, cdsKalg, cdsHalg, cdsHval+      -- ** DNSKEY resource records+    , X_key(.., T_KEY, T_DNSKEY, T_CDNSKEY)+    , type XkeyConName, T_key, T_dnskey, T_cdnskey+      -- *** KEY fields+    , keyFlags, keyProto, keyAlgor, keyValue+      -- *** DNSKEY fields+    , dnskeyFlags, dnskeyProto, dnskeyAlgor, dnskeyValue+      -- *** CDNSKEY fields+    , cdnskeyFlags, cdnskeyProto, cdnskeyAlgor, cdnskeyValue+    , keytag+      -- * RRSIGs+    , X_sig(.., T_SIG, T_RRSIG)+    , type XsigConName, T_rrsig, T_sig+      -- ** RRSIG fields+    , rrsigType, rrsigKeyAlg, rrsigNumLabels, rrsigTTL+    , rrsigExpiration, rrsigInception, rrsigKeyTag, rrsigZone, rrsigValue+      -- ** SIG fields+    , sigType, sigKeyAlg, sigNumLabels, sigTTL+    , sigExpiration, sigInception, sigKeyTag, sigZone, sigValue+      -- * IPSECKEY resource records+    , T_ipseckey(IPSecKey), IPSecKeyGateway(..)+      -- * Zone digest+    , T_zonemd(..)+    , module Net.DNSBase.RData.NSEC+    ) where++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Short as SB+import GHC.Exts (proxy#)+import GHC.TypeLits as TL (TypeError, ErrorMessage(..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal')++import Net.DNSBase.Internal.Util++import Net.DNSBase.Bytes+import Net.DNSBase.Decode.Domain+import Net.DNSBase.Decode.State+import Net.DNSBase.Domain+import Net.DNSBase.Encode.Metric+import Net.DNSBase.Encode.State+import Net.DNSBase.Nat16+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RData.NSEC+import Net.DNSBase.RRTYPE+import Net.DNSBase.Secalgs++type XdsConName :: Nat -> Symbol+type family XdsConName n where+    XdsConName N_ds  = "T_DS"+    XdsConName N_cds = "T_CDS"+    XdsConName n     = TypeError+                     ( ShowType n+                       :<>: TL.Text " is not a DS or CDS RRTYPE" )++type XkeyConName :: Nat -> Symbol+type family XkeyConName n where+    XkeyConName N_dnskey  = "T_DNSKEY"+    XkeyConName N_cdnskey = "T_CDNSKEY"+    XkeyConName N_key     = "T_KEY"+    XkeyConName n         = TypeError+                            ( ShowType n+                              :<>: TL.Text " is not a DNSSEC key RRTYPE" )++type XsigConName :: Nat -> Symbol+type family XsigConName n where+    XsigConName N_rrsig  = "T_RRSIG"+    XsigConName N_sig    = "T_SIG"+    XsigConName n        = TypeError+                           ( ShowType n+                             :<>: TL.Text " is not a SIG or RRSIG RRTYPE" )++-- | X_ds specialised to @DS@ records.+type T_ds      = X_ds N_ds+-- | X_ds specialised to @CDS@ records.+type T_cds     = X_ds N_cds++-- | Record pattern synonym viewing the shared 'X_ds' record as a+-- parent-side @DS@ record (RFC 4034, section 5).  Fields: 'dsKtag',+-- 'dsKalg', 'dsHalg', 'dsHval'.  Coercible to/from 'T_CDS'.+pattern T_DS :: Word16 -- ^ Key Tag+             -> DNSKEYAlg -- ^ Algorithm+             -> DSHashAlg -- ^ Digest-algorithm /selector/ (a 'DSHashAlg' code), distinct from the digest bytes below+             -> ShortByteString -- ^ Digest+             -> T_ds+pattern T_DS { dsKtag, dsKalg, dsHalg, dsHval }+      = (X_DS dsKtag dsKalg dsHalg dsHval :: T_ds)+{-# COMPLETE T_DS #-}++-- | Record pattern synonym viewing the shared 'X_ds' record as a+-- child-side @CDS@ announcement (RFC 7344).  Fields: 'cdsKtag',+-- 'cdsKalg', 'cdsHalg', 'cdsHval'.  Coercible to/from 'T_DS'.+pattern T_CDS :: Word16 -- ^ Key Tag+              -> DNSKEYAlg -- ^ Algorithm+              -> DSHashAlg -- ^ Digest-algorithm /selector/ (a 'DSHashAlg' code), distinct from the digest bytes below+              -> ShortByteString -- ^ Digest+              -> T_cds+pattern T_CDS { cdsKtag, cdsKalg, cdsHalg, cdsHval }+      = (X_DS cdsKtag cdsKalg cdsHalg cdsHval :: T_cds)+{-# COMPLETE T_CDS #-}++-- | X_key specialised to @KEY@ records.+type T_key     = X_key N_key+-- | X_key specialised to @DNSKEY@ records.+type T_dnskey  = X_key N_dnskey+-- | X_key specialised to @CDNSKEY@ records.+type T_cdnskey = X_key N_cdnskey++-- | Record pattern synonym viewing the shared 'X_key' record as a+-- legacy @KEY@ record (RFC 2535, section 3), still used by SIG(0)+-- transaction authentication.  Fields: 'keyFlags', 'keyProto',+-- 'keyAlgor', 'keyValue'.  Coercible to/from 'T_dnskey' and+-- 'T_cdnskey'.+pattern T_KEY :: Word16 -- ^ Flags+              -> Word8 -- ^ Protocol selector; for DNSKEY the only valid value is 3 (RFC 4034 section 2.1.2), other values appear in legacy KEY records+              -> DNSKEYAlg -- ^ Algorithm+              -> ShortByteString -- ^ Public Key+              -> T_key+pattern T_KEY { keyFlags, keyProto, keyAlgor, keyValue }+      = (X_KEY keyFlags keyProto keyAlgor keyValue :: T_key)+{-# COMPLETE T_KEY #-}++-- | Record pattern synonym viewing the shared 'X_key' record as a+-- DNSSEC @DNSKEY@ (RFC 4034, section 2).  Fields: 'dnskeyFlags',+-- 'dnskeyProto', 'dnskeyAlgor', 'dnskeyValue'.  Coercible to/from+-- 'T_cdnskey'; CDNSKEY is the child-side announcement of which DNSKEY+-- KSKs the parent should reference as sources for future DS records.+pattern T_DNSKEY :: Word16 -- ^ Flags+                 -> Word8 -- ^ Protocol selector; MUST be 3 for DNSKEY (RFC 4034 section 2.1.2)+                 -> DNSKEYAlg -- ^ Algorithm+                 -> ShortByteString -- ^ Public Key+                 -> T_dnskey+pattern T_DNSKEY { dnskeyFlags, dnskeyProto, dnskeyAlgor, dnskeyValue }+      = (X_KEY dnskeyFlags dnskeyProto dnskeyAlgor dnskeyValue :: T_dnskey)+{-# COMPLETE T_DNSKEY #-}++-- | Record pattern synonym viewing the shared 'X_key' record as a+-- child-side @CDNSKEY@ announcement (RFC 7344).  Fields:+-- 'cdnskeyFlags', 'cdnskeyProto', 'cdnskeyAlgor', 'cdnskeyValue'.+-- Coercible to/from 'T_dnskey'.+pattern T_CDNSKEY :: Word16 -- ^ Flags+                  -> Word8 -- ^ Protocol selector; MUST be 3 for CDNSKEY (RFC 4034 section 2.1.2, via RFC 7344)+                  -> DNSKEYAlg -- ^ Algorithm+                  -> ShortByteString -- ^ Public Key+                  -> T_cdnskey+pattern T_CDNSKEY { cdnskeyFlags, cdnskeyProto, cdnskeyAlgor, cdnskeyValue }+      = (X_KEY cdnskeyFlags cdnskeyProto cdnskeyAlgor cdnskeyValue :: T_cdnskey)+{-# COMPLETE T_CDNSKEY #-}++-- | X_sig specialised to @SIG@ / @SIG(0)@ records.+type T_sig   = X_sig N_sig+-- | X_sig specialised to @RRSIG@ records.+type T_rrsig = X_sig N_rrsig++-- | Record pattern synonym viewing the shared 'X_sig' record as a+-- legacy @SIG@ record (RFC 2535, section 4.1) or @SIG(0)@+-- transaction authenticator (RFC 2931).  Fields: 'sigType',+-- 'sigKeyAlg', 'sigNumLabels', 'sigTTL', 'sigExpiration',+-- 'sigInception', 'sigKeyTag', 'sigZone', 'sigValue'.  'Eq' and+-- 'Ord' compare the signer name in canonical wire form+-- (via 'equalWireHost' / 'compareWireHost'); see 'X_sig' for why+-- 'T_sig' and 'T_rrsig' are not coercible.+pattern T_SIG :: RRTYPE -- ^ Type Covered+              -> DNSKEYAlg -- ^ Algorithm+              -> Word8 -- ^ Number of labels in the signed owner name, excluding any leading wildcard ('*') and the trailing root (RFC 4034 section 3.1.3)+              -> Word32 -- ^ Original TTL+              -> Int64 -- ^ Signature expiration as absolute 'Int64' time; 32-bit serial-number arithmetic on the wire (see 'X_sig' for the conversion)+              -> Int64 -- ^ Signature inception as absolute 'Int64' time; same serial-number caveat as 'sigExpiration'+              -> Word16 -- ^ Key Tag+              -> Domain -- ^ Signer's Name+              -> ShortByteString -- ^ Signature+              -> T_sig+pattern T_SIG+    { sigType, sigKeyAlg, sigNumLabels, sigTTL+    , sigExpiration, sigInception, sigKeyTag, sigZone, sigValue+    } = ( X_SIG sigType sigKeyAlg sigNumLabels sigTTL+                sigExpiration sigInception sigKeyTag sigZone sigValue+        :: T_sig )+{-# COMPLETE T_SIG #-}++-- | Record pattern synonym viewing the shared 'X_sig' record as a+-- DNSSEC @RRSIG@ (RFC 4034, section 3).  Fields: 'rrsigType',+-- 'rrsigKeyAlg', 'rrsigNumLabels', 'rrsigTTL', 'rrsigExpiration',+-- 'rrsigInception', 'rrsigKeyTag', 'rrsigZone', 'rrsigValue'.+-- 'Eq' and 'Ord' compare the signer name in canonical wire form+-- (via 'equalWireHost' / 'compareWireHost'); canonical RR+-- ordering does not meaningfully apply to RRSIG (see 'X_sig').+pattern T_RRSIG :: RRTYPE -- ^ Type Covered+                -> DNSKEYAlg -- ^ Algorithm+                -> Word8 -- ^ Number of labels in the signed owner name, excluding any leading wildcard ('*') and the trailing root (RFC 4034 section 3.1.3)+                -> Word32 -- ^ Original TTL+                -> Int64 -- ^ Signature expiration as absolute 'Int64' time; 32-bit serial-number arithmetic on the wire (see 'X_sig' for the conversion)+                -> Int64 -- ^ Signature inception as absolute 'Int64' time; same serial-number caveat as 'rrsigExpiration'+                -> Word16 -- ^ Key Tag+                -> Domain -- ^ Signer's Name+                -> ShortByteString -- ^ Signature+                -> T_rrsig+pattern T_RRSIG+    { rrsigType, rrsigKeyAlg, rrsigNumLabels, rrsigTTL+    , rrsigExpiration, rrsigInception, rrsigKeyTag, rrsigZone, rrsigValue+    } = ( X_SIG rrsigType rrsigKeyAlg rrsigNumLabels rrsigTTL+                rrsigExpiration rrsigInception rrsigKeyTag rrsigZone rrsigValue+        :: T_rrsig )+{-# COMPLETE T_RRSIG #-}++-------------------+-- RData structure Definitions++-- | Shared wire-format representation for DNSSEC delegation-signer+-- records: the parent-side @DS@ record+-- ([RFC 4034 section 5.1](https://datatracker.ietf.org/doc/html/rfc4034#section-5.1))+-- and the child-side @CDS@ announcement+-- ([RFC 7344 section 3.1](https://www.rfc-editor.org/rfc/rfc7344.html#section-3.1)).+-- The type parameter @n@ (either 'N_ds' or 'N_cds') determines+-- the RR type.  Each has its own type synonym ('T_ds', 'T_cds')+-- and matching record pattern synonym ('T_DS', 'T_CDS') with the+-- corresponding field-name prefix (@ds@, @cds@).  The wire format+-- is identical and the type role of @n@ is @phantom@, so 'T_ds'+-- and 'T_cds' are mutually coercible — useful for promoting a+-- child-side CDS announcement into a parent-side DS without+-- rebuilding the value.+--+-- >                      1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3+-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |           Key Tag             |  Algorithm    |  Digest Type  |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > /                                                               /+-- > /                            Digest                             /+-- > /                                                               /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- No embedded domain field, so derived 'Ord' agrees with the+-- canonical wire-form octet ordering+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+--+-- The record pattern synonyms 'T_DS' and 'T_CDS' build the+-- corresponding 'T_ds' or 'T_cds' value directly, with their own+-- field-name prefixes (@ds@ and @cds@):+--+-- > :set -XOverloadedStrings+-- > let ds  = T_DS  { dsKtag  = 12345+-- >                 , dsKalg  = 13+-- >                 , dsHalg  = 2+-- >                 , dsHval  = coerce @Bytes16 "0001...1e1f" }+-- >     cds = T_CDS { cdsKtag = 12345+-- >                 , cdsKalg = 13+-- >                 , cdsHalg = 2+-- >                 , cdsHval = coerce @Bytes16 "0001...1e1f" }+-- >  in RData ds : RData cds : []+--+-- Functions that work on either RR type can use the+-- underscore-prefixed selectors on the shared 'X_ds' record:+--+-- > hashTypeVal :: forall n. X_ds n -> (Word8, ShortByteString)+-- > hashTypeVal = (,) <$> _dsHalg <*> _dsHval+type X_ds :: Nat -> Type+data X_ds n = X_DS+    { _dsKtag :: Word16 -- ^ Key Tag+    , _dsKalg :: DNSKEYAlg -- ^ Algorithm+    , _dsHalg :: DSHashAlg -- ^ Digest Type+    , _dsHval :: ShortByteString -- ^ Digest+    }+deriving instance (KnownSymbol (XdsConName n)) => Eq (X_ds n)+deriving instance (KnownSymbol (XdsConName n)) => Ord (X_ds n)++instance (Nat16 n, KnownSymbol (XdsConName n)) => Show (X_ds n) where+    showsPrec p X_DS{..} = showsP p $+        showString (symbolVal' (proxy# @(XdsConName n))) . showChar ' '+        . shows' _dsKtag     . showChar ' '+        . shows' _dsKalg     . showChar ' '+        . shows' _dsHalg     . showChar ' '+        . showHv _dsHval+      where+        showHv = shows @Bytes16 . coerce++instance (KnownSymbol (XdsConName n)) => Presentable (X_ds n) where+    present X_DS{..} =+        present     _dsKtag+        . presentSp _dsKalg+        . presentSp _dsHalg+        . presentHv _dsHval+      where+        presentHv = presentSp @Bytes16 . coerce++instance (Nat16 n, KnownSymbol (XdsConName n)) => KnownRData (X_ds n) where+    rdType _ = RRTYPE $ natToWord16 n+    {-# INLINE rdType #-}+    rdEncode X_DS{..} = putSizedBuilder $!+           mbWord16       _dsKtag+        <> coerce mbWord8 _dsKalg+        <> coerce mbWord8 _dsHalg+        <> mbShortByteString _dsHval+    rdDecode _ _ = const do+        _dsKtag <- get16+        _dsKalg <- DNSKEYAlg <$> get8+        _dsHalg <- DSHashAlg <$> get8+        _dsHval <- getShortByteString+        pure $ RData (X_DS{..} :: X_ds n)++-- | Shared wire-format representation for DNSSEC signing-key+-- records: the @DNSKEY@ record+-- ([RFC 4034 section 2](https://datatracker.ietf.org/doc/html/rfc4034#section-2))+-- published at the child zone apex, the @CDNSKEY@ child-side+-- announcement+-- ([RFC 7344 section 3.2](https://www.rfc-editor.org/rfc/rfc7344.html#section-3.2))+-- of which KSKs the parent should reference, and the legacy+-- @KEY@ record+-- ([RFC 2535 section 3.1](https://datatracker.ietf.org/doc/html/rfc2535#section-3.1))+-- still used by SIG(0) transaction authentication and otherwise+-- effectively unused in modern deployments.  The type parameter+-- @n@ (one of 'N_key', 'N_dnskey', 'N_cdnskey') determines the+-- RR type.  Each has its own type synonym ('T_key', 'T_dnskey',+-- 'T_cdnskey') and matching record pattern synonym ('T_KEY',+-- 'T_DNSKEY', 'T_CDNSKEY') with the corresponding field-name+-- prefix (@key@, @dnskey@, @cdnskey@).  The wire format is+-- identical across all three and the type role of @n@ is+-- @phantom@, so the types are mutually coercible; the practical+-- pairing is DNSKEY \<-\> CDNSKEY (mirroring DS \<-\> CDS).+--+-- >                       1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3+-- >   0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- >  |              Flags            |    Protocol   |   Algorithm   |+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- >  /                                                               /+-- >  /                            Public Key                         /+-- >  /                                                               /+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- No embedded domain field, so derived 'Ord' agrees with the+-- canonical wire-form octet ordering+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+--+-- The record pattern synonyms build the corresponding type+-- directly, with their own field-name prefixes:+--+-- > :set -XOverloadedStrings+-- > let dk  = T_DNSKEY  { dnskeyFlags  = 257+-- >                     , dnskeyProto  = 3+-- >                     , dnskeyAlgor  = 13+-- >                     , dnskeyValue  = coerce @Bytes64 "3FOs...Kw==" }+-- >     cdk = T_CDNSKEY { cdnskeyFlags = 257+-- >                     , cdnskeyProto = 3+-- >                     , cdnskeyAlgor = 13+-- >                     , cdnskeyValue = coerce @Bytes64 "3FOs...Kw==" }+-- >  in RData dk : RData cdk : []+--+-- Functions that work on any of the three RR types can use the+-- underscore-prefixed selectors on the shared 'X_key' record:+--+-- > keyAlgVal :: forall n. X_key n -> (DNSKEYAlg, ShortByteString)+-- > keyAlgVal = (,) <$> _keyAlgor <*> _keyValue+type role X_key phantom+type X_key :: Nat -> Type+data X_key n = X_KEY+    { _keyFlags :: Word16          -- ^ Flags+    , _keyProto :: Word8           -- ^ Protocol+    , _keyAlgor :: DNSKEYAlg       -- ^ Algorithm+    , _keyValue :: ShortByteString -- ^ Public Key+    }+deriving instance (KnownSymbol (XkeyConName n)) => Eq (X_key n)+deriving instance (KnownSymbol (XkeyConName n)) => Ord (X_key n)++instance (Nat16 n, KnownSymbol (XkeyConName n)) => Show (X_key n) where+    showsPrec p X_KEY{..} = showsP p $+        showString (symbolVal' (proxy# @(XkeyConName n))) . showChar ' '+        . shows' _keyFlags    . showChar ' '+        . shows' _keyProto    . showChar ' '+        . shows' _keyAlgor    . showChar ' '+        . showKv _keyValue+      where+        showKv = shows @Bytes64 . coerce++instance (KnownSymbol (XkeyConName n)) => Presentable (X_key n) where+    present X_KEY{..} =+        present     _keyFlags+        . presentSp _keyProto+        . presentSp _keyAlgor+        . presentKv _keyValue+      where+        presentKv = presentSp @Bytes64 . coerce++instance (Nat16 n, KnownSymbol (XkeyConName n)) => KnownRData (X_key n) where+    rdType _ = RRTYPE $ natToWord16 n+    {-# INLINE rdType #-}+    rdEncode X_KEY{..} = putSizedBuilder $!+        mbWord16   _keyFlags+        <> mbWord8 _keyProto+        <> coerce mbWord8 _keyAlgor+        <> mbShortByteString _keyValue+    rdDecode _ _ = const do+        _keyFlags <- get16+        _keyProto <- get8+        _keyAlgor <- DNSKEYAlg <$> get8+        _keyValue <- getShortByteString+        pure $ RData (X_KEY{..} :: X_key n)++-- | Shared wire-format representation for DNSSEC signature+-- records: the @RRSIG@ record+-- ([RFC 4034 section 3](https://datatracker.ietf.org/doc/html/rfc4034#section-3))+-- that signs an RRSet, and the legacy @SIG@ record+-- ([RFC 2535 section 4.1](https://datatracker.ietf.org/doc/html/rfc2535#section-4.1))+-- and its @SIG(0)@ transaction-authentication use+-- ([RFC 2931 section 3](https://datatracker.ietf.org/doc/html/rfc2931#section-3)).+-- The type parameter @n@ (either 'N_sig' or 'N_rrsig') determines+-- the RR type.  Each has its own type synonym ('T_sig', 'T_rrsig')+-- and matching record pattern synonym ('T_SIG', 'T_RRSIG') with+-- the corresponding field-name prefix (@sig@, @rrsig@).  The+-- wire format is shared, but the type role of @n@ is @nominal@:+-- a 'T_sig' value cannot be used where a 'T_rrsig' is expected.+-- This is deliberate — SIG(0) signs a single transaction while+-- RRSIG signs an RRSet, and conflating them at the type level+-- would be unsafe.+--+-- >                      1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3+-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |        Type Covered           |  Algorithm    |     Labels    |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |                         Original TTL                          |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |                      Signature Expiration                     |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |                      Signature Inception                      |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |            Key Tag            |                               |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+         Signer's Name         ++-- > |                                                               /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-/+-- > /                                                               /+-- > /                            Signature                          /+-- > /                                                               /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- As noted in+-- [Section 3.1.5 of RFC 4034](https://tools.ietf.org/html/rfc4034#section-3.1.5)+-- the RRsig inception and expiration times use serial number arithmetic.  As a+-- result these timestamps /are not/ pure values, their meaning is+-- time-dependent!  They depend on the present time and are both at most+-- approximately +\/-68 years from the present.  This ambiguity is not a+-- problem because cached RRSIG records should only persist a few days,+-- signature lifetimes should be *much* shorter than 68 years, and key rotation+-- should cause any misconstrued 136-year-old signatures to fail to validate.+-- This also means that the interpretation of a time that is exactly half-way+-- around the clock at @now +\/-0x80000000@ is not important, the signature+-- should never be valid.+--+-- To avoid ambiguity, these *impure* relative values are converted to pure+-- absolute times as they are received from from the network, and converted+-- back to 32-bit values when encoding.  Therefore, the constructor takes+-- absolute 64-bit representations of the inception and expiration times.+--+-- The signer zone name is not subject to wire-form name+-- compression+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- and canonicalises to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2),+-- confirmed by+-- [RFC 6840 section 5.1](https://datatracker.ietf.org/doc/html/rfc6840#section-5.1)).+-- The 'Eq' and 'Ord' instances compare the signer name in+-- canonical wire form (via 'equalWireHost' / 'compareWireHost'),+-- giving stable comparison semantics for general use in ordered+-- collections.  Canonical RR ordering is not a meaningful concept+-- for RRSIG records — they are never themselves signed — so the+-- canonical-ordering machinery from RFC 4034 §6.2 does not apply+-- to them in practice.+--+type role X_sig nominal+type X_sig :: Nat -> Type+data X_sig n = X_SIG+    { _sigType       :: RRTYPE          -- ^ Type Covered+    , _sigKeyAlg     :: DNSKEYAlg       -- ^ Algorithm+    , _sigNumLabels  :: Word8           -- ^ Labels+    , _sigTTL        :: Word32          -- ^ Original TTL+    , _sigExpiration :: Int64           -- ^ Signature Expiration+    , _sigInception  :: Int64           -- ^ Signature Inception+    , _sigKeyTag     :: Word16          -- ^ Key Tag+    , _sigZone       :: Domain          -- ^ Signer's Name+    , _sigValue      :: ShortByteString -- ^ Signature+    }++instance (Nat16 n, KnownSymbol (XsigConName n)) => Show (X_sig n) where+    showsPrec p X_SIG{..} = showsP p $+        showString (symbolVal' (proxy# @(XsigConName n))) . showChar ' '+        . shows' _sigType       . showChar ' '+        . shows' _sigKeyAlg     . showChar ' '+        . shows' _sigNumLabels  . showChar ' '+        . shows' _sigTTL        . showChar ' '+        . shows' _sigExpiration . showChar ' '+        . shows' _sigInception  . showChar ' '+        . shows' _sigKeyTag     . showChar ' '+        . shows' _sigZone       . showChar ' '+        . showSv _sigValue+      where+        showSv = shows @Bytes64 . coerce++-- | Equality of signer names is case-insensitive.+instance (KnownSymbol (XsigConName n)) => Eq  (X_sig n) where+    a == b = (_sigType       a) == (_sigType       b)+          && (_sigKeyAlg     a) == (_sigKeyAlg     b)+          && (_sigNumLabels  a) == (_sigNumLabels  b)+          && (_sigTTL        a) == (_sigTTL        b)+          && (_sigExpiration a) == (_sigExpiration b)+          && (_sigInception  a) == (_sigInception  b)+          && (_sigKeyTag     a) == (_sigKeyTag     b)+          && (_sigZone a) `equalWireHost` (_sigZone b)+          && (_sigValue      a) == (_sigValue      b)++-- | Comparison of signer names is case-insensitive.+instance (KnownSymbol (XsigConName n)) => Ord (X_sig n) where+    a `compare` b = (_sigType       a) `compare` (_sigType       b)+                 <> (_sigKeyAlg     a) `compare` (_sigKeyAlg     b)+                 <> (_sigNumLabels  a) `compare` (_sigNumLabels  b)+                 <> (_sigTTL        a) `compare` (_sigTTL        b)+                 <> (_sigExpiration a) `compare` (_sigExpiration b)+                 <> (_sigInception  a) `compare` (_sigInception  b)+                 <> (_sigKeyTag     a) `compare` (_sigKeyTag     b)+                 <> (_sigZone a) `compareWireHost` (_sigZone     b)+                 <> (_sigValue      a) `compare` (_sigValue      b)++instance (KnownSymbol (XsigConName n)) => Presentable (X_sig n) where+    present X_SIG{..} =+        present     _sigType+        . presentSp _sigKeyAlg+        . presentSp _sigNumLabels+        . presentSp _sigTTL+        . presentEp _sigExpiration+        . presentEp _sigInception+        . presentSp _sigKeyTag+        . presentSp _sigZone+        . presentSv _sigValue+      where+        presentEp = presentSp @Epoch64 . coerce+        presentSv = presentSp @Bytes64 . coerce++instance (Nat16 n, KnownSymbol (XsigConName n)) => KnownRData (X_sig n) where+    rdType _ = RRTYPE $ natToWord16 n+    {-# INLINE rdType #-}+    rdEncode X_SIG{..} = putSizedBuilder $+        coerce mbWord16     _sigType+        <> coerce mbWord8   _sigKeyAlg+        <> mbWord8          _sigNumLabels+        <> mbWord32         _sigTTL+        <> coerce clock     _sigExpiration+        <> coerce clock     _sigInception+        <> mbWord16         _sigKeyTag+        <> mbWireForm       _sigZone+        <> mbShortByteString _sigValue+      where+        clock :: Int64 -> SizedBuilder+        clock = mbWord32 . fromIntegral+    cnEncode X_SIG{..} = putSizedBuilder $+        coerce mbWord16     _sigType+        <> coerce mbWord8   _sigKeyAlg+        <> mbWord8          _sigNumLabels+        <> mbWord32         _sigTTL+        <> coerce clock     _sigExpiration+        <> coerce clock     _sigInception+        <> mbWord16         _sigKeyTag+        <> mbWireForm (canonicalise _sigZone)+        -- | Canonical encoding of the RRSIG omits the signature value.+      where+        clock :: Int64 -> SizedBuilder+        clock = mbWord32 . fromIntegral+    rdDecode _ _ = const do+        _sigType       <- RRTYPE <$> get16+        _sigKeyAlg     <- DNSKEYAlg <$> get8+        _sigNumLabels  <- get8+        _sigTTL        <- get32+        _sigExpiration <- getDnsTime+        _sigInception  <- getDnsTime+        _sigKeyTag     <- get16+        _sigZone       <- getDomainNC+        _sigValue      <- getShortByteString+        pure $ RData (X_SIG{..} :: X_sig n)++-- | The @ZONEMD@ resource record+-- ([RFC 8976 section 2.2](https://www.rfc-editor.org/rfc/rfc8976#section-2.2))+-- — a digest of the zone contents, used by recipients of zone+-- transfers to verify zone integrity end-to-end.  Four fields:+-- a 32-bit serial number matching the SOA, an 8-bit scheme+-- selector, an 8-bit hash-algorithm selector, and the digest+-- bytes.+--+-- >                      1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3+-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |                             Serial                            |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |    Scheme     |Hash Algorithm |                               |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+                               |+-- > |                             Digest                            |+-- > /                                                               /+-- > /                                                               /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- No embedded domain field, so derived 'Ord' agrees with the+-- canonical wire-form octet ordering.+data T_zonemd = T_ZONEMD+    { zonemdSerial  :: Word32 -- ^ Serial+    , zonemdScheme  :: Word8  -- ^ Scheme+    , zonemdHashAlg :: Word8  -- ^ Hash Algorithm+    , zonemdDigest  :: ShortByteString -- ^ Digest+    } deriving (Eq, Ord)++instance Show T_zonemd where+    showsPrec p T_ZONEMD{..} = showsP p $+        showString "X_SIG"     . showChar ' '+        . shows' zonemdSerial  . showChar ' '+        . shows' zonemdScheme  . showChar ' '+        . shows' zonemdHashAlg . showChar ' '+        . showMd zonemdDigest+      where+        showMd = shows @Bytes16 . coerce++instance Presentable T_zonemd where+    present T_ZONEMD{..} =+        present   zonemdSerial+        . presentSp zonemdScheme+        . presentSp zonemdHashAlg+        . presentMd zonemdDigest+      where+        presentMd d | SB.null d = present @String " ( )"+                    | otherwise = presentSp @Bytes16 (coerce d)++instance KnownRData T_zonemd where+    rdType _ = ZONEMD+    {-# INLINE rdType #-}+    rdEncode T_ZONEMD{..}+        | SB.length (coerce zonemdDigest) < 12+        = failWith CantEncode+        | otherwise+        = putSizedBuilder $+            mbWord32 zonemdSerial+            <> mbWord8 zonemdScheme+            <> mbWord8 zonemdHashAlg+            <> mbShortByteString zonemdDigest+    rdDecode _ _ len+        | len < 18 = failSGet "ZONEMD digest too short"+        | otherwise = do+            zonemdSerial    <- get32+            zonemdScheme    <- get8+            zonemdHashAlg   <- get8+            zonemdDigest    <- getShortByteString+            pure $ RData T_ZONEMD{..}++-- | The @IPSECKEY@ resource record+-- ([RFC 4025 section 2.1](https://datatracker.ietf.org/doc/html/rfc4025#section-2.1))+-- — IPsec keying material for a host or subnet.+--+-- >   0                   1                   2                   3+-- >   0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- >  |  precedence   | gateway type  |  algorithm    |   gateway     |+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+---------------+               ++-- >  ~                            gateway                            ~+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- >  |                                                               /+-- >  /                          public key                           /+-- >  /                                                               /+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-|+--+-- The /gateway type/ byte selects one of four defined gateway shapes+-- (none, IPv4, IPv6, or FQDN); the /gateway/ field carries the+-- corresponding value, and the trailing /public key/ holds the key+-- bytes.+--+-- For future or otherwise unrecognised gateway types (any value+-- outside 0..3) the wire-form boundary between the gateway and the+-- public key is unknown to the parser, so both are kept together as+-- a single opaque blob inside 'IPSecKeyGWG', and the @key@ component+-- below is then empty.+--+-- The constructors are not exported; the only public view is the+-- 'IPSecKey' bidirectional pattern synonym, which exposes a uniform+-- five-argument tuple @(precedence, gateway type, algorithm,+-- gateway, public key)@ regardless of the gateway shape.+--+type T_ipseckey :: Type+data T_ipseckey+    = IPSecX_ Word8 Word8 ShortByteString        -- ^ No gateway (type 0); fields: precedence, algorithm, public key.+    | IPSec4_ Word8 Word8 IPv4 ShortByteString   -- ^ IPv4 gateway (type 1); fields: precedence, algorithm, gateway, public key.+    | IPSec6_ Word8 Word8 IPv6 ShortByteString   -- ^ IPv6 gateway (type 2); fields: precedence, algorithm, gateway, public key.+    | IPSecD_ Word8 Word8 Domain ShortByteString -- ^ FQDN gateway (type 3); fields: precedence, algorithm, gateway, public key.+    | IPSecG_ Word8 Word8 Word8 ShortByteString  -- ^ Future or unrecognised gateway type (\>3); fields: precedence, gateway type, algorithm, opaque (gateway+key) blob.+   deriving (Eq, Show)++instance Ord T_ipseckey where+    (IPSecKey pa ta aa ga ka) `compare` (IPSecKey pb tb ab gb kb) =+        pa `compare` pb+        <> ta `compare` tb+        <> aa `compare` ab+        <> ga `compare` gb+        <> ka `compare` kb++instance Presentable T_ipseckey where+    present (IPSecKey p t a g k)+        | IPSecKeyGWG bytes <- g = \kont -> present "\\#"+            $ presentSp (3 + SB.length bytes)+            $ B.char8 ' ' <> B.word8HexFixed p <> B.word8HexFixed t <> B.word8HexFixed a+              <> present @Bytes16 (coerce bytes) kont+        | otherwise = present p+                    . presentSp t+                    . presentSp a+                    . presentSp g+                    . presentSp @Bytes64 (coerce k)++instance KnownRData T_ipseckey where+    rdType _ = IPSECKEY+    {-# INLINE rdType #-}+    rdEncode (IPSecKey p t a g k) = putSizedBuilder $+        mbWord8 p <> mbWord8 t <> mbWord8 a <> mbgk g+      where+        mbgk IPSecKeyGWX      = mbShortByteString k+        mbgk (IPSecKeyGW4 ip) = mbIPv4 ip <> mbShortByteString k+        mbgk (IPSecKeyGW6 ip) = mbIPv6 ip <> mbShortByteString k+        mbgk (IPSecKeyGWD dn) = mbWireForm dn <> mbShortByteString k+        mbgk (IPSecKeyGWG gk)  = mbShortByteString gk+    rdDecode _ _ = const do+        p <- get8+        t <- get8+        a <- get8+        case t of+            0 -> RData . IPSecX_ p a <$> getShortByteString+            1 -> RData <$.> IPSec4_ p a <$> getIPv4 <*> getShortByteString+            2 -> RData <$.> IPSec6_ p a <$> getIPv6 <*> getShortByteString+            3 -> RData <$.> IPSecD_ p a <$> getDomain <*> getShortByteString+            _ -> RData . IPSecG_ p t a <$> getShortByteString++-- | Uniform five-argument view of an 'T_ipseckey' record.+--+-- When matching against an existing record, /gateway type/ and+-- /gateway/ are always consistent (an 'IPSecKeyGW4' value implies+-- @gateway type == 1@, and so on).+--+-- When /constructing/ a record, the /gateway type/ and /gateway/+-- arguments must agree, and for unrecognised gateway types+-- (anything outside 0..3) the /public key/ argument must be empty+-- (the parser cannot find the boundary, so the gateway-and-key+-- bytes live together inside the 'IPSecKeyGWG' payload).  Valid+-- combinations are:+--+-- * @0@ with 'IPSecKeyGWX' — no gateway+-- * @1@ with 'IPSecKeyGW4' — IPv4 gateway+-- * @2@ with 'IPSecKeyGW6' — IPv6 gateway+-- * @3@ with 'IPSecKeyGWD' — FQDN gateway+-- * any other type byte with 'IPSecKeyGWG' and empty key+--+-- Any other combination raises a runtime error.+pattern IPSecKey :: Word8 -- ^ precedence+                 -> Word8 -- ^ gateway type+                 -> Word8 -- ^ algorithm+                 -> IPSecKeyGateway -- ^ gateway+                 -> ShortByteString -- ^ public key+                 -> T_ipseckey+pattern IPSecKey p t a g k <- (ipSecDecon -> (p, t, a, g, k)) where+    IPSecKey p 0 a IPSecKeyGWX k      = IPSecX_ p a k+    IPSecKey p 1 a (IPSecKeyGW4 ip) k = IPSec4_ p a ip k+    IPSecKey p 2 a (IPSecKeyGW6 ip) k = IPSec6_ p a ip k+    IPSecKey p 3 a (IPSecKeyGWD dn) k = IPSecD_ p a dn k+    IPSecKey p t a (IPSecKeyGWG gk) (SB.null -> True) = IPSecG_ p t a gk+    IPSecKey _ _ _ _ _ = error "Invalid IPSECKEY parameters"+{-# COMPLETE IPSecKey #-}++ipSecDecon :: T_ipseckey+           -> (Word8, Word8, Word8, IPSecKeyGateway, ShortByteString)+ipSecDecon (IPSecX_ p a k)    = (p, 0, a, IPSecKeyGWX,    k)+ipSecDecon (IPSec4_ p a ip k) = (p, 1, a, IPSecKeyGW4 ip, k)+ipSecDecon (IPSec6_ p a ip k) = (p, 2, a, IPSecKeyGW6 ip, k)+ipSecDecon (IPSecD_ p a dn k) = (p, 3, a, IPSecKeyGWD dn, k)+ipSecDecon (IPSecG_ p t a gk) = (p, t, a, IPSecKeyGWG gk, mempty)+{-# INLINE ipSecDecon #-}++-- | Shape of an 'IPSECKEY' record's /gateway/ field.  Four cases+-- match the four gateway types defined by RFC 4025; the catchall+-- 'IPSecKeyGWG' covers any future or otherwise unrecognised gateway+-- type byte and holds the gateway and public-key bytes together as+-- a single opaque blob (the parser has no way to find the boundary+-- between them when the shape is unknown).+data IPSecKeyGateway+    = IPSecKeyGWX                 -- ^ No gateway (gateway type 0).+    | IPSecKeyGW4 IPv4            -- ^ IPv4 gateway address (gateway type 1).+    | IPSecKeyGW6 IPv6            -- ^ IPv6 gateway address (gateway type 2).+    | IPSecKeyGWD Domain          -- ^ FQDN gateway (gateway type 3); not subject to name compression.+    | IPSecKeyGWG ShortByteString -- ^ Future or unrecognised gateway type (\>3); opaque gateway-and-key blob.+  deriving (Eq, Ord, Show)++instance Presentable IPSecKeyGateway where+    present IPSecKeyGWX      = present '.'+    present (IPSecKeyGW4 ip) = present ip+    present (IPSecKeyGW6 ip) = present ip+    present (IPSecKeyGWD dn) = present dn+    present _                = id++-- | Compute RFC 4034, Appendix B key tag over the DNSKEY RData: 16 bit flags,+-- 8 bit proto, 8 bit alg and key octets.+--+-- With the obsolete algorithm 1 we assign key tag 0 to truncated keys, but+-- RSAMD5 keys are no longer seen in the wild.  We check that the modulus+-- actually has at least 3 octets.+--+keytag :: X_key n -> Word16+keytag = fromIntegral . go+  where+    go :: X_key n -> Word32+    go X_KEY{..} | alg /= 1 = tag+      where+        (DNSKEYAlg alg) = _keyAlgor+        !z   = lo _keyFlags + hi _keyProto + lo alg+        ws32 = zipWith ($) (cycle [hi, lo]) $ SB.unpack _keyValue+        !raw = foldl' (+) z ws32+        !tag = (raw + (raw `shiftR` 16)) .&. 0xffff+    go X_KEY{..} | Just !tag <- c32 = tag+                    | otherwise = 0+      where+        len = SB.length _keyValue+        c32 = (+) <$> (hi <$.> SB.indexMaybe _keyValue (len - 3))+                  <*> (lo <$.> SB.indexMaybe _keyValue (len - 2))++    hi, lo :: Integral a => a -> Word32+    lo = fromIntegral+    hi = flip shiftL 8 . lo
+ src/Net/DNSBase/RData/NSEC.hs view
@@ -0,0 +1,320 @@+{-|+Module      : Net.DNSBase.RData.NSEC+Description : DNSSEC denial-of-existence records (NSEC, NSEC3, NSEC3PARAM, NXT)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++DNSSEC denial-of-existence machinery.  'T_nsec' (RFC 4034) names+the next existing owner in canonical order alongside a bitmap of+present RR types at the proving name.  'T_nsec3' (RFC 5155) is+the hashed variant, where the next-name pointer is the hashed+owner.  'T_nsec3param' (RFC 5155) carries the zone-wide NSEC3+hashing parameters at the zone apex.  'T_nxt' (RFC 2535) is the+obsolete predecessor of NSEC, defined here for compatibility+with archival zone data.+-}+{-# LANGUAGE+    NegativeLiterals+  , RecordWildCards+  #-}+module Net.DNSBase.RData.NSEC+    ( -- * NSEC, NSEC3, and NSEC Type Bitmap structures+      T_nsec(..)+    , T_nsec3(..)+    , T_nsec3param(..)+    , NsecTypes+    , nsecTypesFromList+    , nsecTypesToList+    , hasRRtype+    -- * Obsolete NXT structure+    , T_nxt(..)+    , NxtTypes+    , NxtRRtype+    , toNxtTypes+    , nxtTypesFromNE+    , nxtTypesToNE+    , hasNxtRRtype+    , module Net.DNSBase.NonEmpty+    ) where++import qualified Data.ByteString.Short as SB++import Net.DNSBase.Internal.Util++import Net.DNSBase.Bytes+import Net.DNSBase.Decode.Domain+import Net.DNSBase.Decode.State+import Net.DNSBase.Domain+import Net.DNSBase.Encode.State+import Net.DNSBase.NonEmpty+import Net.DNSBase.NsecTypes+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RRTYPE+import Net.DNSBase.Secalgs+import Net.DNSBase.Text++-----------------++-- | The @NSEC@ resource record+-- ([RFC 4034 section 4](https://datatracker.ietf.org/doc/html/rfc4034#section-4))+-- — the building block of authenticated denial of existence: a+-- 'Domain' naming the next existing owner in the zone's canonical+-- order, plus an 'NsecTypes' bitmap of RR types present at the+-- proving name.+--+-- The next-owner-name field is not subject to wire-form name+-- compression+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- and is not lower-cased when computing canonical wire form+-- ([RFC 6840 section 5.1](https://datatracker.ietf.org/doc/html/rfc6840#section-5.1)).+--+-- See 'T_nsec3' for the hashed-name variant.+data T_nsec = T_NSEC+    { nsecNext  :: Domain+    , nsecTypes :: NsecTypes+    } deriving (Eq, Show)++instance Ord T_nsec where+    a `compare` b = nsecNext  a `compare` nsecNext  b+                 <> nsecTypes a `compare` nsecTypes b++instance Presentable T_nsec where+    present T_NSEC{..} =+        present     nsecNext+        . presentSp nsecTypes++instance KnownRData T_nsec where+    rdType _ = NSEC+    {-# INLINE rdType #-}+    rdEncode T_NSEC{..} = do+        putSizedBuilder $ mbWireForm nsecNext+        putNsecTypes nsecTypes+    rdDecode _ _ len = do+        pos0 <- getPosition+        nsecNext  <- getDomainNC+        used <- subtract pos0 <$> getPosition+        nsecTypes <- getNsecTypes (len - used)+        pure $ RData T_NSEC{..}++-- | The @NSEC3@ resource record+-- ([RFC 5155 section 3.2](https://tools.ietf.org/html/rfc5155#section-3.2))+-- — the hashed denial-of-existence variant.  The next-owner-name+-- field carries the hashed equivalent rather than the plain name,+-- and the record itself includes the hashing parameters+-- (algorithm, flags, iteration count, salt) needed to reproduce+-- the hash.  The trailing 'NsecTypes' bitmap names the RR types+-- present at the proving (un-hashed) name.+--+-- >                      1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3+-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |   Hash Alg.   |     Flags     |          Iterations           |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |  Salt Length  |                     Salt                      /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |  Hash Length  |             Next Hashed Owner Name            /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > /                         Type Bit Maps                         /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- The 'Ord' instance compares the fields in wire-encoding order,+-- using 'dnsTextCmp' on the length-prefixed salt and hashed-name+-- bytes, so it agrees with the canonical RR-content ordering of+-- [RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2).+--+-- See 'T_nsec' for the un-hashed variant and 'T_nsec3param' for the+-- zone-apex parameter record.+data T_nsec3 = T_NSEC3+    { nsec3Alg   :: NSEC3HashAlg+    , nsec3Flags :: Word8+    , nsec3Iters :: Word16+    , nsec3Salt  :: ShortByteString+    , nsec3Next  :: ShortByteString+    , nsec3Types :: NsecTypes+    } deriving (Eq)++instance Ord T_nsec3 where+    a `compare` b = nsec3Alg   a `compare`    nsec3Alg   b+                 <> nsec3Flags a `compare`    nsec3Flags b+                 <> nsec3Iters a `compare`    nsec3Iters b+                 <> nsec3Salt  a `dnsTextCmp` nsec3Salt  b+                 <> nsec3Next  a `dnsTextCmp` nsec3Next  b+                 <> nsec3Types a `compare`    nsec3Types b++instance Show T_nsec3 where+    showsPrec p T_NSEC3{..} = showsP p $+        showString "T_NSEC3 "+        . shows'   nsec3Alg   . showChar ' '+        . shows'   nsec3Flags . showChar ' '+        . shows'   nsec3Iters . showChar ' '+        . showSalt nsec3Salt  . showChar ' '+        . showNext nsec3Next  . showChar ' '+        . shows'   nsec3Types+      where+        showNext s = shows @Bytes32 (coerce s)+        showSalt s | SB.null s = showChar '-'+                   | otherwise = shows @Bytes16 (coerce s)++instance Presentable T_nsec3 where+    present T_NSEC3{..} =+        present       nsec3Alg+        . presentSp   nsec3Flags+        . presentSp   nsec3Iters+        . presentSalt nsec3Salt+        . presentNext nsec3Next+        . presentSp   nsec3Types+      where+        presentNext s = presentSp @Bytes32 (coerce s)+        presentSalt s | SB.null s = presentSp '-'+                      | otherwise = presentSp @Bytes16 (coerce s)++instance KnownRData T_nsec3 where+    rdType _ = NSEC3+    {-# INLINE rdType #-}+    rdEncode T_NSEC3{..} = do+        putSizedBuilder $+            coerce mbWord8 nsec3Alg+            <> mbWord8 nsec3Flags+            <> mbWord16 nsec3Iters+            <> mbShortByteStringLen8 nsec3Salt+            <> mbShortByteStringLen8 nsec3Next+        putNsecTypes nsec3Types+    rdDecode _ _ len = do+        pos0 <- getPosition+        nsec3Alg   <- NSEC3HashAlg <$> get8+        nsec3Flags <- get8+        nsec3Iters <- get16+        nsec3Salt  <- getShortByteStringLen8+        nsec3Next  <- getShortByteStringLen8+        used       <- subtract pos0 <$> getPosition+        nsec3Types <- getNsecTypes (len - used)+        pure $ RData T_NSEC3{..}++-- | The @NSEC3PARAM@ resource record+-- ([RFC 5155 section 4.2](https://tools.ietf.org/html/rfc5155#section-4.2))+-- — a zone-apex record describing the NSEC3 hashing parameters+-- (algorithm, iteration count, salt) in use across the zone's+-- NSEC3 chain.  Validating resolvers do not consult this record+-- (each 'T_nsec3' carries its own parameters in the RDATA); it+-- exists for authoritative-server tooling.+--+-- >                      1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3+-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |   Hash Alg.   |     Flags     |          Iterations           |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |  Salt Length  |                     Salt                      /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- (Editorial: the salt and iteration count were largely a bad+-- idea in retrospect; best practice for zone signers is to set+-- the salt empty and the iteration count to zero.)+--+-- See 'T_nsec3' for the records produced under these parameters.+data T_nsec3param = T_NSEC3PARAM+    { nsec3paramAlg   :: NSEC3HashAlg+    , nsec3paramFlags :: Word8+    , nsec3paramIters :: Word16+    , nsec3paramSalt  :: ShortByteString+    } deriving (Eq, Show)++instance Ord T_nsec3param where+    compare a b =+       comparing nsec3paramAlg a b+       <> comparing nsec3paramFlags a b+       <> comparing nsec3paramIters a b+       <> dnsTextCmp (nsec3paramSalt  a) (nsec3paramSalt  b)++instance Presentable T_nsec3param where+    present T_NSEC3PARAM{..} =+        present       nsec3paramAlg+        . presentSp   nsec3paramFlags+        . presentSp   nsec3paramIters+        . presentSalt nsec3paramSalt+      where+        presentSalt s | SB.null s = presentSp '-'+                      | otherwise = presentSp @Bytes16 (coerce s)++instance KnownRData T_nsec3param where+    rdType _ = NSEC3PARAM+    {-# INLINE rdType #-}+    rdEncode T_NSEC3PARAM{..} = putSizedBuilder $+        mbWord8 (coerce nsec3paramAlg)+        <> mbWord8 nsec3paramFlags+        <> mbWord16 nsec3paramIters+        <> mbShortByteStringLen8 nsec3paramSalt+    rdDecode _ _ = const do+        nsec3paramAlg   <- NSEC3HashAlg <$> get8+        nsec3paramFlags <- get8+        nsec3paramIters <- get16+        nsec3paramSalt  <- getShortByteStringLen8+        pure $ RData T_NSEC3PARAM{..}++-- | The @NXT@ resource record+-- ([RFC 2535 section 5.2](https://www.rfc-editor.org/rfc/rfc2535.html#section-5.2))+-- — the obsolete predecessor of 'T_nsec', defined here for+-- compatibility with archival DNSSEC zone data.  Same conceptual+-- shape as @NSEC@ (next owner name + type bitmap) but with a+-- different type-bitmap encoding.+--+-- >                      1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3+-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |                  next domain name                             /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |                    type bit map                               /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- The domain name is wire-form name-compressed on decode only+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- and canonicalises to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare the domain field in+-- canonical wire form (via 'equalWireHost' / 'compareWireHost')+-- and the type bitmap byte-wise.+--+-- See 'T_nsec' for the modern replacement.+data T_nxt = T_NXT+    { nxtNext :: Domain+    , nxtBits :: NxtTypes+    }++instance Show T_nxt where+    showsPrec p T_NXT{..} = showsP p $+        showString "T_NXT "+        . shows' nxtNext . showChar ' '+        . shows' nxtBits++instance Eq T_nxt where+    a == b = nxtNext  a `equalWireHost` nxtNext  b+          && nxtBits  a ==              nxtBits  b++instance Ord T_nxt where+    a `compare` b = nxtNext a `compareWireHost` nxtNext b+                 <> nxtBits a `compare`         nxtBits b++instance Presentable T_nxt where+    present T_NXT{..} =+        present nxtNext+        . presentSp nxtBits++instance KnownRData T_nxt where+    rdType _ = NXT+    {-# INLINE rdType #-}++    rdEncode T_NXT{..} = putSizedBuilder $+        mbWireForm nxtNext+        <> mbShortByteString (coerce nxtBits)++    cnEncode rd@(T_NXT{nxtNext = d}) =+        rdEncode rd {nxtNext = canonicalise d}++    rdDecode _ _ len = do+        pos0    <- getPosition+        nxtNext <- getDomain+        used    <- subtract pos0 <$> getPosition+        nxtBits <- getNxtTypes (len - used)+        pure $ RData $ T_NXT{..}
+ src/Net/DNSBase/RData/Obsolete.hs view
@@ -0,0 +1,574 @@+{-|+Module      : Net.DNSBase.RData.Obsolete+Description : Obsolete RR types retained for wire-form parsing+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++A grab-bag of RR types that are no longer used in current zone+data but appear in historic records and zone-data archives.+They are defined here so wire-form parsers can read stray+examples without failing.  No new deployment should use any of+these types.++The module gathers four loose groups:++* Early host-name and mailbox pointers: 'T_md', 'T_mf', 'T_mb',+  'T_mg', 'T_mr' (the shared codec 'X_domain' is re-exported+  here).+* RFC 1035 and RFC 1183 records that never saw wide use:+  'T_minfo', 'T_x25', 'T_isdn', 'T_rt'.+* OSI / X.400-mapping records, all deprecated by RFC 9121:+  'T_nsap', 'T_nsapptr', 'T_px'.+* Other one-offs: 'T_gpos' (early geographic location,+  superseded by 'LOC'), 'T_kx' (Key Exchange), 'T_a6'+  (chained IPv6 addressing; obsoleted by RFC 6563).++'T_wks' (Well-Known Services) is re-exported here for+convenience; its definition lives in "Net.DNSBase.RData.WKS".++The pre-RFC-4034 records in this module lower-case their+embedded domains in canonical form; 'T_nsapptr' is the+exception (its derived instances compare the wire bytes+case-sensitively).+-}+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.RData.Obsolete+    ( -- * Obsolete RR types+      -- ** Obsolete RR types representing a host name or mailbox.+      X_domain(T_MD, T_MF, T_MB, T_MG, T_MR)+    , T_md+    , T_mf+    , T_mb+    , T_mg+    , T_mr+      -- ** Other obsolete RR types.+    , T_wks(..)+    , WksProto(..)+    , T_minfo(..)+    , T_x25(..)+    , T_isdn(..)+    , T_rt(..)+    , T_nsap(..)+    , T_nsapptr(..)+    , T_px(..)+    , T_gpos(..)+    , T_kx(..)+    , T_a6(T_A6)+    ) where++import qualified Data.ByteString.Short as SB+import Net.DNSBase.Internal.Util+import Net.DNSBase.RData.Internal.XNAME++import Net.DNSBase.Bytes+import Net.DNSBase.Decode.Domain+import Net.DNSBase.Decode.State+import Net.DNSBase.Domain+import Net.DNSBase.Encode.State+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RData.WKS+import Net.DNSBase.RRTYPE+import Net.DNSBase.Text++-- | The @MINFO@ resource record+-- ([RFC 1035 section 3.3.7](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.7))+-- — mailing-list request and owner addresses: two 'Domain'+-- fields, the request mailbox and the owner (bounce) mailbox.+--+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- >  /                    RMAILBX                    /+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- >  /                    EMAILBX                    /+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- Both fields are subject to wire-form name compression on encode+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- and canonicalise to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare both domain fields in+-- canonical wire form (via 'equalWireHost' / 'compareWireHost'),+-- so 'Ord' is canonical.+data T_minfo = T_MINFO+    { minfoRmailbx :: Domain -- ^ Request address+    , minfoEmailbx :: Domain -- ^ Owner (bounce) address+    } deriving (Show)++-- | Case-insensitive wire-form equality.+instance Eq T_minfo where+    a == b = (minfoRmailbx a) `equalWireHost` (minfoRmailbx b)+          && (minfoEmailbx a) `equalWireHost` (minfoEmailbx b)++-- | Case-insensitive wire-form order.+instance Ord T_minfo where+    a `compare` b = (minfoRmailbx a) `compareWireHost` (minfoRmailbx b)+                 <> (minfoEmailbx a) `compareWireHost` (minfoEmailbx b)++instance Presentable T_minfo where+    present T_MINFO{..} =+        present minfoRmailbx+        . presentSp minfoEmailbx++instance KnownRData T_minfo where+    rdType _ = MINFO+    {-# INLINE rdType #-}+    rdEncode T_MINFO{..} = do+        -- Subject to name compression.+        putDomain minfoRmailbx+        putDomain minfoEmailbx+    cnEncode T_MINFO{..} = putSizedBuilder $+           mbWireForm (canonicalise minfoRmailbx)+        <> mbWireForm (canonicalise minfoEmailbx)+    rdDecode _ _ = const do+        -- Subject to name compression.+        minfoRmailbx <- getDomain+        minfoEmailbx <- getDomain+        return $ RData $ T_MINFO{..}++-- | The @X25@ resource record+-- ([RFC 1183 section 3.1](https://www.rfc-editor.org/rfc/rfc1183.html#section-3.1))+-- — an X.25 PSDN address held as a single DNS+-- /character-string/.  RFC 1183 calls for at least four ASCII+-- digits, but the constructor does not enforce that — callers may+-- store any byte sequence that fits in a character-string (up to+-- 255 bytes).+--+-- The 'Ord' instance compares the payload as a DNS+-- character-string (length-prefixed lexicographic), so it agrees+-- with the canonical wire-form ordering of+-- [RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2).+newtype T_x25 = T_X25 SB.ShortByteString+    deriving (Eq, Show)++instance Ord T_x25 where+    (T_X25 a) `compare` (T_X25 b) = comparing DnsText a b++instance Presentable T_x25 where+    present (T_X25 str) = present @DnsText (coerce str)++instance KnownRData T_x25 where+    rdType _ = X25+    {-# INLINE rdType #-}+    rdEncode = putShortByteStringLen8 . coerce+    rdDecode _ _ = const $ RData . T_X25 <$> getShortByteStringLen8++-- | The @ISDN@ resource record+-- ([RFC 1183 section 3.2](https://www.rfc-editor.org/rfc/rfc1183.html#section-3.2))+-- — the ISDN number of the owner host, with an optional+-- Direct-Dial-In subaddress.  Both fields are DNS+-- /character-strings/; only the address is mandatory.+--+-- The 'Ord' instance compares both fields as DNS+-- character-strings.  With the trailing DDI absent, the wire form+-- is shorter than any encoding with a present DDI, so 'Ord' agrees+-- with the canonical wire-form ordering of+-- [RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2).+data T_isdn = T_ISDN SB.ShortByteString (Maybe SB.ShortByteString)+    deriving (Eq, Show)++instance Ord T_isdn where+    (T_ISDN aa ad) `compare` (T_ISDN ba bd) = aa `strCompare`  ba+                                           <> ad `mstrCompare` bd+      where+        strCompare = comparing DnsText+        mstrCompare = comparing (fmap DnsText)++instance Presentable T_isdn where+    present (T_ISDN address ddi) =+        present @DnsText (coerce address)+        . maybe id (presentSp @DnsText . coerce) ddi++instance KnownRData T_isdn where+    rdType _ = ISDN+    {-# INLINE rdType #-}+    rdEncode (T_ISDN address ddi) = do+        putShortByteStringLen8 address+        mapM_ putShortByteStringLen8 ddi+    rdDecode _ _ len = do+        pos0 <- getPosition+        address <- getShortByteStringLen8+        used <- subtract pos0 <$> getPosition+        ddi <- if | used == len -> pure Nothing+                  | otherwise   -> Just <$> getShortByteStringLen8+        pure $ RData $ T_ISDN address ddi++-- | The @RT@ resource record+-- ([RFC 1183 section 3.3](https://www.rfc-editor.org/rfc/rfc1183.html#section-3.3))+-- — Route-Through: a 16-bit preference and a 'Domain' naming an+-- intermediate host that will route packets to the owner.  Used+-- in the X.25 and ISDN era for hosts without their own wide-area+-- addresses.+--+-- The route-through domain is not subject to wire-form name+-- compression on encode but compression is tolerated on decode+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4)).+-- It canonicalises to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare the domain in canonical+-- wire form (via 'equalWireHost' / 'compareWireHost'), so 'Ord'+-- is canonical.+data T_rt = T_RT Word16 Domain+    deriving (Show)++instance Eq T_rt where+    (T_RT pa ra) == (T_RT pb rb) = pa == pb && ra `equalWireHost` rb++instance Ord T_rt where+    (T_RT pa ra) `compare` (T_RT pb rb) =+        pa `compare` pb+     <> ra `compareWireHost` rb++instance Presentable T_rt where+    present (T_RT pref router) = present pref . presentSp router++instance KnownRData T_rt where+    rdType _ = RT+    {-# INLINE rdType #-}+    rdEncode (T_RT pref router) = putSizedBuilder $+        mbWord16 pref <> mbWireForm router+    cnEncode (T_RT pref router) =+        rdEncode $ T_RT pref (canonicalise router)+    rdDecode _ _ = const do+        pref <- get16+        router <- getDomain+        pure $ RData $ T_RT pref router++-- | The @NSAP@ resource record+-- ([RFC 1706 section 5](https://www.rfc-editor.org/rfc/rfc1706.html#section-5);+-- deprecated by [RFC 9121](https://www.rfc-editor.org/rfc/rfc9121))+-- — mapped a domain name to an OSI Network Service Access Point+-- address.  An opaque byte string carrying the NSAP value+-- verbatim; presented in zone-file syntax as a @0x@-prefixed hex+-- literal.+--+-- Derived 'Ord' compares the raw bytes, which matches the+-- canonical wire-form ordering of+-- [RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2).+newtype T_nsap = T_NSAP SB.ShortByteString+    deriving (Eq, Ord)++instance Show T_nsap where+    showsPrec p a = showString "0x" . showsPrec @Bytes16 p (coerce a)++instance Presentable T_nsap where+    present a = present @String "0x" . present @Bytes16 (coerce a)++instance KnownRData T_nsap where+    rdType _ = NSAP+    {-# INLINE rdType #-}+    rdEncode = putSizedBuilder . mbShortByteString . coerce+    rdDecode _ _ = RData . T_NSAP <.> getShortNByteString++-- | The @NSAPPTR@ resource record+-- ([RFC 1348](https://www.rfc-editor.org/rfc/rfc1348#page-2);+-- obsoleted by @PTR@ in+-- [RFC 1706 section 6](https://www.rfc-editor.org/rfc/rfc1706.html#section-6),+-- deprecated by [RFC 9121](https://www.rfc-editor.org/rfc/rfc9121))+-- — the OSI counterpart of @PTR@, mapping an NSAP-derived owner+-- name to a domain name.+--+-- The target domain is not subject to wire-form name compression+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- and is /not/ in the+-- [RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)+-- list of types that lower-case their RDATA names.  Derived 'Eq'+-- and 'Ord' therefore compare the wire bytes verbatim+-- (case-sensitively).+newtype T_nsapptr = T_NSAPPTR Domain -- ^ Target 'Domain'+    deriving (Eq, Ord, Show)++instance Presentable T_nsapptr where+    present = present @Domain . coerce++instance KnownRData T_nsapptr where+    rdType _ = NSAPPTR+    {-# INLINE rdType #-}+    rdEncode = putSizedBuilder . mbWireForm . coerce+    rdDecode _ _ = const do+        RData . T_NSAPPTR <$> getDomainNC++-- | The @PX@ resource record+-- ([RFC 2163 section 4](https://www.rfc-editor.org/rfc/rfc2163.html#section-4);+-- deprecated by [RFC 9121](https://www.rfc-editor.org/rfc/rfc9121))+-- — points at X.400/RFC 822 mapping information: a 16-bit+-- preference and two 'Domain' fields naming the RFC 822 (SMTP)+-- and X.400 sides of the mapping.+--+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                  PREFERENCE                   |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                    MAP822                     /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                    MAPX400                    /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- Neither domain field is subject to wire-form name compression+-- on encode but compression is tolerated on decode+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4)).+-- Both canonicalise to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare both domains in canonical+-- wire form (via 'equalWireHost' / 'compareWireHost'), so 'Ord'+-- is canonical.+data T_px = T_PX+    { pxPref    :: Word16+    , pxMap822  :: Domain+    , pxMapX400 :: Domain+    } deriving (Show)++instance Eq T_px where+    a == b = pxPref    a ==              pxPref    b+          && pxMap822  a `equalWireHost` pxMap822  b+          && pxMapX400 a `equalWireHost` pxMapX400 b++instance Ord T_px where+    a `compare` b = pxPref    a `compare`         pxPref    b+                 <> pxMap822  a `compareWireHost` pxMap822  b+                 <> pxMapX400 a `compareWireHost` pxMapX400 b++instance Presentable T_px where+    present T_PX{..} =+        present pxPref+        . presentSp pxMap822+        . presentSp pxMapX400++instance KnownRData T_px where+    rdType _ = PX+    {-# INLINE rdType #-}+    rdEncode T_PX{..} = putSizedBuilder $+        mbWord16 pxPref+        <> mbWireForm pxMap822+        <> mbWireForm pxMapX400+    cnEncode T_PX{..} =+        rdEncode $ T_PX pxPref+                        (canonicalise pxMap822)+                        (canonicalise pxMapX400)+    rdDecode _ _ = const do+        pxPref    <- get16+        pxMap822  <- getDomain+        pxMapX400 <- getDomain+        pure $ RData T_PX{..}++-- | The @GPOS@ resource record+-- ([RFC 1712 section 3](https://www.rfc-editor.org/rfc/rfc1712.html#section-3))+-- — an early geographical-location record: longitude, latitude,+-- and altitude as three DNS /character-strings/ holding decimal+-- floating-point text.  Superseded by @LOC@-style records and not+-- used in modern zone data.+--+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                 LONGITUDE                  /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                  LATITUDE                  /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                  ALTITUDE                  /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- The 'Ord' instance compares the three fields as DNS+-- character-strings, agreeing with the canonical wire-form+-- ordering of+-- [RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2).+data T_gpos = T_GPOS+    { gposLongitude :: SB.ShortByteString+    , gposLatitude  :: SB.ShortByteString+    , gposAltitude  :: SB.ShortByteString+    } deriving (Eq, Show)++instance Ord T_gpos where+    a `compare` b = gposLongitude a `strCompare` gposLongitude b+                 <> gposLatitude  a `strCompare` gposLatitude  b+                 <> gposAltitude  a `strCompare` gposAltitude  b+      where+        strCompare = comparing DnsText++instance Presentable T_gpos where+    present T_GPOS{..} =+        present     @DnsText (coerce gposLongitude)+        . presentSp @DnsText (coerce gposLatitude)+        . presentSp @DnsText (coerce gposAltitude)++instance KnownRData T_gpos where+    rdType _ = GPOS+    {-# INLINE rdType #-}+    rdEncode T_GPOS{..} = putSizedBuilder $+        mbShortByteStringLen8    gposLongitude+        <> mbShortByteStringLen8 gposLatitude+        <> mbShortByteStringLen8 gposAltitude+    rdDecode _ _ = const do+        gposLongitude <- getShortByteStringLen8+        gposLatitude  <- getShortByteStringLen8+        gposAltitude  <- getShortByteStringLen8+        pure $ RData T_GPOS{..}++-- | The @KX@ resource record+-- ([RFC 2230 section 3.1](https://www.rfc-editor.org/rfc/rfc2230.html#section-3.1))+-- — names a Key Exchange host for the owner: a 16-bit preference+-- and a 'Domain' naming the exchanger.  Defined for the DNSSEC+-- precursor work; never widely deployed.+--+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                  PREFERENCE                   |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                   EXCHANGER                   /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- The exchanger field is not subject to wire-form name compression+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- and canonicalises to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare the exchanger in canonical+-- wire form (via 'equalWireHost' / 'compareWireHost'), so 'Ord'+-- is canonical.+data T_kx = T_KX+    { kxPref :: Word16+    , kxExch :: Domain+    } deriving (Show)++instance Eq T_kx where+    a == b = kxPref a ==              kxPref b+          && kxExch a `equalWireHost` kxExch b++instance Ord T_kx where+    a `compare` b = kxPref a `compare`         kxPref b+                 <> kxExch a `compareWireHost` kxExch b++instance Presentable T_kx where+    present T_KX{..} = present kxPref . presentSp kxExch++instance KnownRData T_kx where+    rdType _ = KX+    {-# INLINE rdType #-}++    rdEncode T_KX{..} = putSizedBuilder $+        mbWord16 kxPref+        <> mbWireForm kxExch+    cnEncode rd@(T_KX{kxExch = d}) =+        rdEncode rd {kxExch = canonicalise d}+    rdDecode _ _ = const do+        kxPref <- get16+        kxExch <- getDomainNC+        pure $ RData T_KX{..}++-- | The @A6@ resource record+-- ([RFC 2874 section 3.1](https://www.rfc-editor.org/rfc/rfc2874.html#section-3.1);+-- obsoleted by [RFC 6563](https://www.rfc-editor.org/rfc/rfc6563.html))+-- — an experimental chained IPv6 addressing scheme.  Each record+-- carries a prefix length, an address suffix containing the+-- low-order bits, and a 'Domain' naming where to look up the+-- remaining prefix bits.  Resolution walked the chain to assemble+-- the full address.  The deployment experience reported in RFC+-- 6563 led to A6 being abandoned in favour of plain 'Net.DNSBase.RData.A.T_aaaa'+-- records.+--+-- > +-----------+------------------+-------------------++-- > |Prefix len.|  Address suffix  |    Prefix name    |+-- > | (1 octet) |  (0..16 octets)  |  (0..255 octets)  |+-- > +-----------+------------------+-------------------++--+-- The wire encoding rules are:+--+-- * The prefix length is an unsigned octet between 0 and 128.+-- * The address-suffix field carries exactly enough octets to+--   hold @128 - /prefix-length/@ bits, with up to seven leading+--   pad bits set to zero so the field is an integral number of+--   bytes.+-- * The prefix-name field is a wire-form 'Domain'.  It is absent+--   when the prefix length is zero (the suffix already holds the+--   whole address); the suffix field is absent when the prefix+--   length is 128 (the whole address comes from the chain).+-- * The prefix-name is not subject to wire-form name compression+--   ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+--   and canonicalises to lower case+--   ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+--+-- The 'Eq' and 'Ord' instances compare the prefix-name field in+-- canonical wire form (via 'toHost'), so 'Ord' is canonical.+data T_a6 = T_a6+    { a6Prefix :: Word8+    , a6Suffix :: IPv6+    , a6Domain :: Maybe Domain+    } deriving (Show)++instance Eq T_a6 where+    a == b = (           a6Prefix a) == (           a6Prefix b)+          && (           a6Suffix a) == (           a6Suffix b)+          && (toHost <$> a6Domain a) == (toHost <$> a6Domain b)++instance Ord T_a6 where+    a `compare` b = (           a6Prefix a) `compare` (           a6Prefix b)+                 <> (           a6Suffix a) `compare` (           a6Suffix b)+                 <> (toHost <$> a6Domain a) `compare` (toHost <$> a6Domain b)++-- | /Smart constructor/ for @A6@ records:+--+-- - Silently caps the prefix length to 128+-- - Ignores the domain when the prefix length is 0+-- - Otherwise, uses the root domain if no domain is provided+--+pattern T_A6 :: Word8 -> IPv6 -> Maybe Domain -> T_a6+pattern T_A6 prefix suffix domain <- T_a6 prefix suffix domain where+    T_A6 prefix suffix domain = T_a6{..}+      where+        a6Prefix = bool 128 prefix (prefix <= 128)+        a6Domain | prefix == 0 = Nothing+                 | otherwise   = Just $! fromMaybe RootDomain domain+        a6Suffix | (s0, s1, s2, s3) <- fromIPv6w suffix+                   = toIPv6w (s0 .&. m0, s1 .&. m1, s2 .&. m2, s3 .&. m3)+          where+            (m0, m1, m2, m3) = mask128 $ fromIntegral a6Prefix++instance Presentable T_a6 where+    present T_a6{..} =+        present a6Prefix+        . presentSp a6Suffix+        . maybe id presentSp a6Domain++instance KnownRData T_a6 where+    rdType _ = A6+    {-# INLINE rdType #-}++    rdEncode T_a6{..} = putSizedBuilder $+        mbWord8 a6Prefix+        <> mconcat [mbWord8 (fromIntegral w) | w <- bytesFromIPv6]+        <> maybe mempty mbWireForm a6Domain+      where+        npad = fromIntegral a6Prefix `shiftR` 3+        bytesFromIPv6 = drop npad $ fromIPv6b a6Suffix++    cnEncode rd@(T_a6{a6Domain = Just d}) =+        rdEncode rd {a6Domain = Just (canonicalise d)}+    cnEncode rd = rdEncode rd++    rdDecode _ _ = const do+        a6Prefix <- get8+        when (a6Prefix > 128) do+            failSGet "A6 prefix exceeds 128"+        let npad = fromIntegral a6Prefix `shiftR` 3+        a6Suffix <- bytesToIPv6 npad <$> getNBytes (16 - npad)+        a6Domain <- if | a6Prefix == 0 -> pure Nothing+                       | otherwise     -> Just <$> getDomainNC+        pure $ RData T_a6{..}+      where+        bytesToIPv6 npad = toIPv6b . (replicate npad 0 ++) . map fromIntegral++--------------------++-- | Mask upper @p@ bits of IPv6 address.+mask128 :: Int -> (Word32, Word32, Word32, Word32)+mask128 p | p < 64    = (w0, w1, m32, m32)+          | otherwise = (0,   0,  w2,  w3)+  where+    m64 = 0xffff_ffff_ffff_ffff :: Word64+    m32 = 0xffff_ffff :: Word32+    hi = m64 `shiftR` p+    lo = m64 `shiftR` (p - 64)+    w0 = fromIntegral @Word64 @Word32 (hi `shiftR` 32)+    w1 = fromIntegral @Word64 @Word32 hi+    w2 = fromIntegral @Word64 @Word32 (lo `shiftR` 32)+    w3 = fromIntegral @Word64 @Word32 lo
+ src/Net/DNSBase/RData/SOA.hs view
@@ -0,0 +1,178 @@+{-|+Module      : Net.DNSBase.RData.SOA+Description : Zone administration records (SOA and RP)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++Two zone-administration RR types: 'T_soa' is the mandatory+zone-apex record describing zone serial, refresh / retry /+expire / negative-TTL timing, and the responsible operator's+mailbox.  'T_rp' is an optional record pointing at a person+responsible for a name plus a separate TXT record with free-form+contact details.+-}+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.RData.SOA+    ( T_soa(..)+    , T_rp(..)+    ) where++import Net.DNSBase.Internal.Util++import Net.DNSBase.Decode.Domain+import Net.DNSBase.Decode.State+import Net.DNSBase.Domain+import Net.DNSBase.Encode.Metric+import Net.DNSBase.Encode.State+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RRTYPE++-- | The @SOA@ resource record+-- ([RFC 1035 section 3.3.13](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.13))+-- — the mandatory zone-apex record carrying zone serial, refresh,+-- retry, expire, and negative-response TTL alongside the master+-- nameserver and the operator's mailbox.  Returned in negative+-- responses to convey the negative-cache TTL, and in the @AXFR@+-- zone-transfer protocol.+--+-- The mname and rname fields are subject to wire-form name+-- compression on encode+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- and canonicalise to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare the two domain fields in+-- their canonical wire form (via 'equalWireHost' /+-- 'compareWireHost') and the remaining fields in wire-encoding+-- order, so 'Ord' is canonical: it agrees with lexicographic+-- ordering of the full canonical wire form.+--+-- See 'T_rp' for the responsible-person record.+data T_soa = T_SOA+    { soaMname   :: Domain    -- ^ Master nameserver+    , soaRname   :: Domain    -- ^ Responsible mailbox, local part is first label+    , soaSerial  :: Word32    -- ^ Zone serial number+    , soaRefresh :: Word32    -- ^ Frequency of secondary zone refresh+    , soaRetry   :: Word32    -- ^ AXFR retry interval+    , soaExpire  :: Word32    -- ^ Expiration time of stale secondary data+    , soaMinttl  :: Word32    -- ^ Negative response TTL+    } deriving (Show)++-- | Equality compares the mname and rname fields in canonical+-- wire form, the remaining fields pointwise.+instance Eq T_soa where+    a == b = (soaSerial  a) ==              (soaSerial  b)+          && (soaMname   a) `equalWireHost` (soaMname   b)+          && (soaRname   a) `equalWireHost` (soaRname   b)+          && (soaRefresh a) ==              (soaRefresh b)+          && (soaRetry   a) ==              (soaRetry   b)+          && (soaExpire  a) ==              (soaExpire  b)+          && (soaMinttl  a) ==              (soaMinttl  b)++-- | Canonical: compares the mname and rname fields in canonical+-- wire form and the remaining fields in wire-encoding order, so+-- the result matches lexicographic comparison of the canonical+-- wire form.+instance Ord T_soa where+    a `compare` b = (soaMname   a) `compareWireHost` (soaMname   b)+                 <> (soaRname   a) `compareWireHost` (soaRname   b)+                 <> (soaSerial  a) `compare`         (soaSerial  b)+                 <> (soaRefresh a) `compare`         (soaRefresh b)+                 <> (soaRetry   a) `compare`         (soaRetry   b)+                 <> (soaExpire  a) `compare`         (soaExpire  b)+                 <> (soaMinttl  a) `compare`         (soaMinttl  b)++instance Presentable T_soa where+    present T_SOA{..} =+        present     soaMname+        . presentSp soaRname+        . presentSp soaSerial+        . presentSp soaRefresh+        . presentSp soaRetry+        . presentSp soaExpire+        . presentSp soaMinttl++instance KnownRData T_soa where+    rdType _ = SOA+    {-# INLINE rdType #-}+    rdEncode T_SOA{..}= do+        putDomain soaMname+        putDomain soaRname+        putSizedBuilder $+               mbWord32 soaSerial+            <> mbWord32 soaRefresh+            <> mbWord32 soaRetry+            <> mbWord32 soaExpire+            <> mbWord32 soaMinttl+    cnEncode T_SOA{..} = putSizedBuilder $+           mbWireForm (canonicalise soaMname)+        <> mbWireForm (canonicalise soaRname)+        <> mbWord32 soaSerial+        <> mbWord32 soaRefresh+        <> mbWord32 soaRetry+        <> mbWord32 soaExpire+        <> mbWord32 soaMinttl+    rdDecode _ _ = const do+        soaMname <- getDomain+        soaRname <- getDomain+        soaSerial <- get32+        soaRefresh <- get32+        soaRetry <- get32+        soaExpire <- get32+        soaMinttl <- get32+        return $ RData T_SOA{..}++-- | The @RP@ resource record+-- ([RFC 1183 section 2.2](https://www.rfc-editor.org/rfc/rfc1183.html#section-2.2))+-- — the responsible person for a name: an mbox-dname encoding an+-- email address (the first label is the local part, per the+-- usual DNS mailbox-name convention), and a txt-dname pointing+-- at a 'Net.DNSBase.RData.TXT.T_txt' record with free-form contact details.+--+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- >  /                   mbox-dname                  /+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- >  /                   txt-dname                   /+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- Neither field is wire-form name-compressed on encode+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- but compression is tolerated on decode.  Both fields+-- canonicalise to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2),+-- [RFC 6840 section 5.1](https://datatracker.ietf.org/doc/html/rfc6840#section-5.1)).+-- The 'Eq' and 'Ord' instances compare both fields in canonical+-- wire form (via 'equalWireHost' / 'compareWireHost'); since the+-- field order matches the wire encoding, 'Ord' is canonical.+--+-- See 'T_soa' for the mandatory zone-apex record.+data T_rp = T_RP+    { rpMbox :: Domain+    , rpTxt  :: Domain+    } deriving (Show)++instance Eq T_rp where+    a == b = rpMbox a `equalWireHost` rpMbox b+          && rpTxt  a `equalWireHost` rpTxt  b++instance Ord T_rp where+    a `compare` b = rpMbox a `compareWireHost` rpMbox b+                 <> rpTxt  a `compareWireHost` rpTxt  b++instance Presentable T_rp where+    present T_RP{..} = present rpMbox . presentSp rpTxt++instance KnownRData T_rp where+    rdType _ = RP+    rdEncode T_RP{..} = putSizedBuilder $+        mbWireForm rpMbox <> mbWireForm rpTxt+    cnEncode T_RP{..} =+        rdEncode $ T_RP (canonicalise rpMbox)+                        (canonicalise rpTxt)+    rdDecode _ _ = const do+        rpMbox <- getDomain+        rpTxt  <- getDomain+        return $ RData T_RP{..}
+ src/Net/DNSBase/RData/SRV.hs view
@@ -0,0 +1,617 @@+{-|+Module      : Net.DNSBase.RData.SRV+Description : Service-endpoint and locator records (MX, SRV, AFSDB, NAPTR, NID/L32/L64/LP, AMTRELAY)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++This module gathers RR types that map a name to a service+endpoint or address locator.  'T_mx' (RFC 1035), 'T_srv'+(RFC 2782), 'T_afsdb' (RFC 1183), and 'T_naptr' (RFC 3403) are+pre-RFC-4034 records pointing at a host via a domain name;+canonical RDATA lower-cases the embedded domain.  The ILNP+family ('T_nid', 'T_l32', 'T_l64', 'T_lp'; RFC 6742) and+'T_amtrelay' (RFC 8777) are later records — those with a+domain field treat it case-sensitively in canonical form per+RFC 6840 section 5.1.+-}+{-# LANGUAGE+    MagicHash+  , RecordWildCards+  , UndecidableInstances+  #-}++module Net.DNSBase.RData.SRV+    ( T_mx(..)+    , T_srv(..)+    , T_afsdb(..)+    , T_naptr(..)+      -- * NID and L64+    , X_nid(.., T_NID, T_L64)+    , type XnidConName, T_nid, T_l64+      -- *** 'T_NID' fields+    , nidPref+    , nidAddr+      -- *** 'T_L64' fields+    , l64Pref+    , l64Addr+      -- * L32+    , T_l32(..)+      -- * LP+    , T_lp(..)+      -- * AMTRELAY+    , T_amtrelay(..)+    , AmtRelay(Amt_Nil, Amt_A, Amt_AAAA, Amt_Host, Amt_Opaque)+    ) where++import qualified Data.ByteString.Short as SB+import Data.ByteString.Builder (char8, word8HexFixed, word16HexFixed)+import GHC.Exts (proxy#)+import GHC.TypeLits as TL (TypeError, ErrorMessage(..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal')++import Net.DNSBase.Internal.Util+import Net.DNSBase.Internal.Bytes++import Net.DNSBase.Decode.Domain+import Net.DNSBase.Decode.State+import Net.DNSBase.Domain+import Net.DNSBase.Encode.Metric+import Net.DNSBase.Encode.State+import Net.DNSBase.Nat16+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RRTYPE+import Net.DNSBase.Text++type XnidConName :: Nat -> Symbol+type family XnidConName n where+    XnidConName N_nid = "T_NID"+    XnidConName N_l64 = "T_L64"+    XnidConName n     = TypeError+                        ( ShowType n+                          :<>: TL.Text " is not a NID or L64 RRTYPE" )++-- | X_nid specialised to @NID@ records.+type T_nid = X_nid N_nid+-- | X_nid specialised to @L64@ records.+type T_l64 = X_nid N_l64++-- | Record pattern synonym viewing the shared 'X_nid' record as an+-- @NID@ (Node Identifier) record, RFC 6742.  Fields: 'nidPref',+-- 'nidAddr'.  Not coercible to/from 'T_l64': the role of 'X_nid' is+-- /nominal/ because the 64-bit payload means a Node-ID here and a+-- 64-bit locator prefix in L64.+pattern T_NID :: Word16 -- ^ Preference+              -> Word64 -- ^ Node Identifier+              -> T_nid+pattern T_NID { nidPref, nidAddr } = (X_NID nidPref nidAddr :: T_nid)+{-# COMPLETE T_NID #-}++-- | Record pattern synonym viewing the shared 'X_nid' record as an+-- @L64@ (64-bit locator) record, RFC 6742.  Fields: 'l64Pref',+-- 'l64Addr'.  Not coercible to/from 'T_nid' (see 'T_NID' note).+pattern T_L64 :: Word16 -- ^ Preference+              -> Word64 -- ^ 64-bit locator prefix+              -> T_l64+pattern T_L64 { l64Pref, l64Addr } = (X_NID l64Pref l64Addr :: T_l64)+{-# COMPLETE T_L64 #-}++-- | The @MX@ resource record+-- ([RFC 1035 section 3.3.9](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.9))+-- — a mail exchanger for the owner name: a 16-bit preference+-- (lower is preferred) and a 'Domain' naming the exchange host.+--+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- >  |                  PREFERENCE                   |+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- >  /                   EXCHANGE                    /+-- >  /                                               /+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- The exchange field is subject to wire-form name compression on+-- encode+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- and canonicalises to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare the exchange in canonical+-- wire form (via 'equalWireHost' / 'compareWireHost'), so 'Ord'+-- is canonical.+--+-- A name that resolves to a CNAME should not be used in the+-- exchange field+-- ([RFC 2181 section 10.3](https://datatracker.ietf.org/doc/html/rfc2181#section-10.3),+-- [RFC 5321 section 5.1](https://datatracker.ietf.org/doc/html/rfc5321#section-5.1)).+data T_mx = T_MX+    { mxPref :: Word16 -- ^ Preference, lower is better+    , mxExch :: Domain -- ^ Exchange host.+    } deriving (Show)++-- | Case-insensitive wire-form equality.+instance Eq T_mx where+    a == b = (mxPref a) ==              (mxPref b)+          && (mxExch a) `equalWireHost` (mxExch b)++-- | Case-insensitive wire-form order.+instance Ord T_mx where+    compare a b = (mxPref a) `compare`         (mxPref b)+               <> (mxExch a) `compareWireHost` (mxExch b)++instance Presentable T_mx where+    present T_MX{..} = present mxPref . presentSp mxExch++instance KnownRData T_mx where+    rdType _ = MX+    {-# INLINE rdType #-}+    rdEncode T_MX{..} = do+        put16 mxPref+        -- Subject to name compression.+        putDomain mxExch+    cnEncode T_MX{..} = putSizedBuilder $+        mbWord16 mxPref+        <> mbWireForm (canonicalise mxExch)+    rdDecode _ _ = const do+        mxPref <- get16+        -- Subject to name compression.+        mxExch <- getDomain+        return $ RData $ T_MX{..}++-- | The @SRV@ resource record+-- ([RFC 2782](https://datatracker.ietf.org/doc/html/rfc2782))+-- — names the location of a service: 16-bit priority, weight,+-- and port, plus a 'Domain' naming the target host.+--+-- The target field is not subject to wire-form name compression+-- on encode+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- but compression is tolerated on decode.  It canonicalises to+-- lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare the target in canonical+-- wire form (via 'equalWireHost' / 'compareWireHost'), so 'Ord'+-- is canonical.+data T_srv = T_SRV+    { srvPriority :: Word16+    , srvWeight   :: Word16+    , srvPort     :: Word16+    , srvTarget   :: Domain -- not subject to name compression+    } deriving (Show)++-- | Equality is not case-senstive on the target host name.+instance Eq T_srv where+    a == b = (srvPriority a) ==              (srvPriority b)+          && (srvWeight   a) ==              (srvWeight   b)+          && (srvPort     a) ==              (srvPort     b)+          && (srvTarget   a) `equalWireHost` (srvTarget   b)++-- | Order is not case-senstive on the target host name.+instance Ord T_srv where+    a `compare` b = (srvPriority a) `compare`         (srvPriority b)+                 <> (srvWeight   a) `compare`         (srvWeight   b)+                 <> (srvPort     a) `compare`         (srvPort     b)+                 <> (srvTarget   a) `compareWireHost` (srvTarget   b)++instance Presentable T_srv where+    present T_SRV{..} =+        present srvPriority+        . presentSp srvWeight+        . presentSp srvPort+        . presentSp srvTarget++instance KnownRData T_srv where+    rdType _ = SRV+    {-# INLINE rdType #-}+    rdEncode T_SRV{..} = putSizedBuilder $+        mbWord16 srvPriority+        <> mbWord16 srvWeight+        <> mbWord16 srvPort+        -- No Name compression when encoding.+        <> mbWireForm srvTarget+    cnEncode rd@(T_SRV{srvTarget = t}) =+        rdEncode rd { srvTarget = canonicalise t }+    rdDecode _ _ = const do+        srvPriority <- get16+        srvWeight   <- get16+        srvPort     <- get16+        -- Name compression accepted when decoding.+        srvTarget   <- getDomain+        return $ RData $ T_SRV{..}++-- | The @AFSDB@ resource record+-- ([RFC 1183 section 1](https://datatracker.ietf.org/doc/html/rfc1183#section-1);+-- see also+-- [RFC 5864 section 5](https://tools.ietf.org/html/rfc5864#section-5))+-- — points at an AFS-cell or DCE-authentication-cell server:+-- a 16-bit subtype tag and a 'Domain' hostname.+--+-- The hostname field is not subject to wire-form name compression+-- on encode but compression is tolerated on decode.  It+-- canonicalises to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare the hostname in canonical+-- wire form (via 'equalWireHost' / 'compareWireHost'), so 'Ord'+-- is canonical.+data T_afsdb = T_AFSDB+    { afsdbSubtype  :: Word16+    , afsdbHostname :: Domain+    } deriving (Show)++instance Eq T_afsdb where+    a == b = (afsdbSubtype  a) == (afsdbSubtype  b)+          && (afsdbHostname a) `equalWireHost` (afsdbHostname b)++instance Ord T_afsdb where+    a `compare` b = (afsdbSubtype  a) `compare`         (afsdbSubtype  b)+                 <> (afsdbHostname a) `compareWireHost` (afsdbHostname b)++instance Presentable T_afsdb where+    present T_AFSDB{..} =+        present afsdbSubtype+        . presentSp afsdbHostname++instance KnownRData T_afsdb where+    rdType _ = AFSDB+    {-# INLINE rdType #-}+    rdEncode T_AFSDB{..} = putSizedBuilder $+        mbWord16 afsdbSubtype+        -- No Name compression when encoding.+        <> mbWireForm afsdbHostname+    cnEncode T_AFSDB{..} =+        rdEncode $ T_AFSDB afsdbSubtype+                           (canonicalise afsdbHostname)+    rdDecode _ _ = const do+        afsdbSubtype  <- get16+        -- Name compression accepted when decoding.+        afsdbHostname <- getDomain+        return $ RData $ T_AFSDB{..}++-- | The @NAPTR@ resource record+-- ([RFC 3403 section 4](https://www.rfc-editor.org/rfc/rfc3403.html#section-4))+-- — Naming Authority Pointer: a rewriting rule that translates+-- the owner name into another resource via the flags/services+-- tags, an optional regexp, and a replacement domain.+--+-- >                                 1  1  1  1  1  1+-- >   0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                     ORDER                     |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                   PREFERENCE                  |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                     FLAGS                     /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                   SERVICES                    /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                    REGEXP                     /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                  REPLACEMENT                  /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- The replacement field is not subject to wire-form name+-- compression on encode but compression is tolerated on decode.+-- It canonicalises to lower case+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+-- The 'Eq' and 'Ord' instances compare the replacement in+-- canonical wire form (via 'equalWireHost' / 'compareWireHost')+-- and the character-string fields as DNS character-strings, so+-- 'Ord' is canonical.+data T_naptr = T_NAPTR+    { naptrOrder       :: Word16+    , naptrPreference  :: Word16+    , naptrFlags       :: ShortByteString+    , naptrServices    :: ShortByteString+    , naptrRegexp      :: ShortByteString+    , naptrReplacement :: Domain+    } deriving (Show)++-- | Equality is not case-senstive on the replacement domain.+instance Eq T_naptr where+    a == b = (naptrOrder       a) ==              (naptrOrder       b)+          && (naptrPreference  a) ==              (naptrPreference  b)+          && (naptrFlags       a) ==              (naptrFlags       b)+          && (naptrServices    a) ==              (naptrServices    b)+          && (naptrRegexp      a) ==              (naptrRegexp      b)+          && (naptrReplacement a) `equalWireHost` (naptrReplacement b)++-- | Order is not case-senstive on the replacement domain.+instance Ord T_naptr where+    a `compare` b = (naptrOrder       a) `compare`         (naptrOrder       b)+                 <> (naptrPreference  a) `compare`         (naptrPreference  b)+                 <> (naptrFlags       a) `strCompare`      (naptrFlags       b)+                 <> (naptrServices    a) `strCompare`      (naptrServices    b)+                 <> (naptrRegexp      a) `strCompare`      (naptrRegexp      b)+                 <> (naptrReplacement a) `compareWireHost` (naptrReplacement b)+      where+        strCompare = comparing DnsText++instance Presentable T_naptr where+    present T_NAPTR{..} =+        present     naptrOrder+        . presentSp naptrPreference+        . presentSp @DnsText (coerce naptrFlags)+        . presentSp @DnsText (coerce naptrServices)+        . presentSp @DnsText (coerce naptrRegexp)+        . presentSp naptrReplacement++instance KnownRData T_naptr where+    rdType _ = NAPTR+    {-# INLINE rdType #-}+    rdEncode T_NAPTR{..} = putSizedBuilder $+           mbWord16              naptrOrder+        <> mbWord16              naptrPreference+        <> mbShortByteStringLen8 naptrFlags+        <> mbShortByteStringLen8 naptrServices+        <> mbShortByteStringLen8 naptrRegexp+           -- no name compression+        <> mbWireForm            naptrReplacement+    cnEncode rd@(T_NAPTR{naptrReplacement = r}) =+        rdEncode rd { naptrReplacement = canonicalise r }+    rdDecode _ _ = const do+        naptrOrder       <- get16+        naptrPreference  <- get16+        naptrFlags       <- getShortByteStringLen8+        naptrServices    <- getShortByteStringLen8+        naptrRegexp      <- getShortByteStringLen8+           -- possible name decompression+        naptrReplacement <- getDomain+        return $ RData $ T_NAPTR{..}++-- | Shared wire-format representation for ILNP node-identifier+-- and locator records: @NID@+-- ([RFC 6742 section 2.1.1](https://www.rfc-editor.org/rfc/rfc6742.html#section-2.1.1))+-- carries a 64-bit Node-ID, and @L64@+-- ([RFC 6742 section 2.3.1](https://www.rfc-editor.org/rfc/rfc6742.html#section-2.3.1))+-- carries a 64-bit IPv6 locator prefix.  The type parameter @n@+-- (either 'N_nid' or 'N_l64') determines the RR type.  Each has+-- its own type synonym ('T_nid', 'T_l64') and matching record+-- pattern synonym ('T_NID', 'T_L64') with the corresponding+-- field-name prefix (@nid@, @l64@).  The role of 'X_nid' is+-- /nominal/: the 64-bit payload means different things in each,+-- so 'T_nid' and 'T_l64' are not coercible.+--+-- Derived 'Ord' is canonical: no embedded domain, fields compared+-- in wire-encoding order.  See 'T_l32' and 'T_lp' for the rest+-- of the ILNP record family.+--+-- >   0                   1                   2                   3+-- >   0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- >  |          Preference           |                               |+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+                               ++-- >  |                             NodeID                            |+-- >  +                               +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- >  |                               |+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+type X_nid :: Nat -> Type+type role X_nid nominal+data X_nid n = X_NID+    { _nidPref :: Word16 -- ^ Preference+    , _nidAddr :: Word64 -- ^ Node ID or 64-bit IPv6 prefix+    }+deriving instance (KnownSymbol (XnidConName n)) => Eq (X_nid n)+deriving instance (KnownSymbol (XnidConName n)) => Ord (X_nid n)++instance (Nat16 n, KnownSymbol (XnidConName n)) => Show (X_nid n) where+    showsPrec p X_NID{..} = showsP p $+        showString (symbolVal' (proxy# @(XnidConName n)))+        . showChar ' ' . shows' _nidPref+        . showChar ' ' . shows' _nidAddr++instance (KnownSymbol (XnidConName n)) => Presentable (X_nid n) where+    present X_NID{..} =+        present _nidPref+        . \k -> bld ' ' 48 <> bld ':' 32 <> bld ':' 16 <> bld ':'  0 <> k+      where+        bld :: Char -> Int -> Builder+        bld sep shft = char8 sep <>+            (word16HexFixed $ fromIntegral $ _nidAddr `shiftR` shft)++instance (Nat16 n, KnownSymbol (XnidConName n)) => KnownRData (X_nid n) where+    rdType _ = RRTYPE $ natToWord16 n+    {-# INLINE rdType #-}+    rdEncode X_NID{..} = putSizedBuilder $+           mbWord16              _nidPref+        <> mbWord64              _nidAddr+    rdDecode _ _ = const do+        _nidPref          <- get16+        _nidAddr          <- get64+        pure $ RData (X_NID{..} :: X_nid n)++-- | The @L32@ resource record+-- ([RFC 6742 section 2.2.1](https://www.rfc-editor.org/rfc/rfc6742.html#section-2.2.1))+-- — an ILNP 32-bit locator: a 16-bit preference and a 32-bit+-- network locator carried in an 'IPv4' value.+--+-- >  0                   1                   2                   3+-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |          Preference           |      Locator32 (16 MSBs)      |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |     Locator32 (16 LSBs)       |+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- Derived 'Ord' is canonical: no embedded domain, fields compared+-- in wire-encoding order.  See 'X_nid' and 'T_lp' for the rest+-- of the ILNP record family.+data T_l32 = T_L32+    { l32Pref :: Word16+    , l32Addr :: IPv4+    } deriving (Eq, Ord, Show)++instance Presentable T_l32 where+    present T_L32{..} = present l32Pref . presentSp l32Addr++instance KnownRData T_l32 where+    rdType _ = L32+    {-# INLINE rdType #-}+    rdEncode T_L32{..} = putSizedBuilder $+           mbWord16              l32Pref+        <> mbWord32              (fromIPv4w l32Addr)+    rdDecode _ _ = const do+        l32Pref          <- get16+        l32Addr          <- toIPv4w <$> get32+        pure $ RData $ T_L32{..}+++-- | The @LP@ resource record+-- ([RFC 6742 section 2.4.1](https://www.rfc-editor.org/rfc/rfc6742.html#section-2.4.1))+-- — an ILNP locator pointer: a 16-bit preference and a 'Domain'+-- naming a host that publishes locator records.+--+-- >  0                   1                   2                   3+-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |          Preference           |                               /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+                               /+-- > /                                                               /+-- > /                              FQDN                             /+-- > /                                                               /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- The FQDN field is not subject to wire-form name compression.+-- The 'Eq' and 'Ord' instances compare the FQDN case-insensitively+-- in wire form (via 'equalWireHost' / 'compareWireHost').+--+-- See 'X_nid' and 'T_l32' for the rest of the ILNP record family.+data T_lp = T_LP+    { lpPref :: Word16+    , lpFqdn :: Domain+    } deriving (Show)++-- | Case-insensitive wire-form equality.+instance Eq T_lp where+    a == b = (lpPref a) ==              (lpPref b)+          && (lpFqdn a) `equalWireHost` (lpFqdn b)++-- | Case-insensitive wire-form order.+instance Ord T_lp where+    compare a b = (lpPref a) `compare`         (lpPref b)+               <> (lpFqdn a) `compareWireHost` (lpFqdn b)++instance Presentable T_lp where+    present T_LP{..} = present lpPref . presentSp lpFqdn++instance KnownRData T_lp where+    rdType _ = LP+    {-# INLINE rdType #-}+    rdEncode T_LP{..} = putSizedBuilder $+        mbWord16 lpPref+        <> mbWireForm lpFqdn+    rdDecode _ _ = const do+        lpPref <- get16+        lpFqdn <- getDomainNC+        pure $ RData $ T_LP{..}++-- | The @AMTRELAY@ resource record+-- ([RFC 8777 section 4](https://datatracker.ietf.org/doc/html/rfc8777#section-4))+-- — the relay-address for AMT (Automatic Multicast Tunneling)+-- discovery.  An 8-bit /precedence/, a 1-bit /discovery-optional/+-- flag, a 7-bit relay-type field, and an 'AmtRelay' value whose+-- format depends on the type:+--+-- > 0       empty+-- > 1       wire-form IPv4 address+-- > 2       wire-form IPv6 address+-- > 3       uncompressed wire-form domain name+-- > 4-127   reserved (unlikely to be specified)+--+-- >   0                   1                   2                   3+-- >   0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- >  |   precedence  |D|    type     |                               |+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+                               ++-- >  ~                            relay                              ~+-- >  +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- Derived 'Ord' compares precedence, then discovery flag, then+-- 'AmtRelay' (constructor order, then field), matching the+-- canonical wire-form ordering.  The 'Domain' inside an+-- @Amt_Host@ relay is compared case-sensitively, as is the+-- convention for RR types defined after RFC 4034.+data T_amtrelay = T_AMTRELAY+    { amtPref  :: Word8 -- ^ Preference, lower is better+    , amtDisc  :: Bool  -- ^ Discovery optional+    , amtRelay :: AmtRelay+    } deriving (Eq, Ord, Show)++-- | New variants of the AmtRelay value type are not expected, so an ADT is+-- used to capture just the specified variants and an opaque catchall.+--+data AmtRelay = Amt_Nil+              | Amt_A IPv4+              | Amt_AAAA IPv6+              | Amt_Host Host+              | Amt_Any_ Word8 ShortByteString+  deriving (Eq, Ord, Show)++-- | /Smart constructor/ of opaque relay forms, that ensures a non-empty value+-- and type in [4,127].  The underlying @Amt_Any_@ constructor is not exposed.+--+pattern Amt_Opaque :: Word8 -> ShortByteString -> AmtRelay+pattern Amt_Opaque t b <- Amt_Any_ t b where+    Amt_Opaque t b | t > 3 && t < 128 && not (SB.null b) = Amt_Any_ t b+                   | otherwise = error "Invalid opaque AmtRelay"++amtTypeWord :: Bool -> Word8 -> Word8+amtTypeWord d t = bool t (0x80 .|. t) d++instance Presentable T_amtrelay where+    present T_AMTRELAY{..} = case amtRelay of+        Amt_Nil -> present amtPref+                   . presentSp (fromEnum amtDisc)+                   . presentSp @Word8 0+                   . presentSp "."+        Amt_A a -> present amtPref+                   . presentSp (fromEnum amtDisc)+                   . presentSp @Word8 1+                   . presentSp a+        Amt_AAAA a -> present amtPref+                      . presentSp (fromEnum amtDisc)+                      . presentSp @Word8 2+                      . presentSp a+        Amt_Host h -> present amtPref+                      . presentSp (fromEnum amtDisc)+                      . presentSp @Word8 3+                      . presentSp (fromHost h)+        Amt_Any_ t bs ->+            present "\\# "+            . present (2 + SB.length bs)+            . present ' '+            . (word8HexFixed amtPref <>)+            . (word8HexFixed (amtTypeWord amtDisc t) <>)+            . present @Bytes16 (coerce bs)++instance KnownRData T_amtrelay where+    rdType _ = AMTRELAY+    {-# INLINE rdType #-}+    rdEncode T_AMTRELAY{..} = do+        put8 amtPref+        case amtRelay of+            Amt_Nil -> put8 (amtTypeWord amtDisc 0)+            Amt_A a -> do+                put8 (amtTypeWord amtDisc 1)+                putIPv4 a+            Amt_AAAA a -> do+                put8 (amtTypeWord amtDisc 2)+                putIPv6 a+            Amt_Host h -> do+                put8 (amtTypeWord amtDisc 3)+                putWireForm (fromHost h)+            Amt_Any_ t bs -> do+                put8 (amtTypeWord amtDisc t)+                putShortByteString bs+    rdDecode _ _ = const do+        amtPref <- get8+        w <- get8+        let amtDisc = (w .&. 0x80) /= 0+            t = w .&. 0x7f+        amtRelay <- case t of+            0 -> pure Amt_Nil+            1 -> Amt_A <$> getIPv4+            2 -> Amt_AAAA <$> getIPv6+            3 -> Amt_Host . toHost <$> getDomain+            _ -> Amt_Any_ t <$> getShortByteString+        pure $ RData $ T_AMTRELAY{..}
+ src/Net/DNSBase/RData/SVCB.hs view
@@ -0,0 +1,328 @@+{-|+Module      : Net.DNSBase.RData.SVCB+Description : Service Binding (SVCB) and HTTPS resource records+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The Service Binding RR ('T_svcb') and its HTTPS-specific+variant ('T_https'), defined by RFC 9460.  Both share a wire+format with three fields — priority, target name, and a list+of typed (key, value) service parameters — represented+internally by the 'X_svcb' data type, indexed by a type-level+natural that determines the specific RR type.++The service-parameter machinery is split across submodules:++* "Net.DNSBase.RData.SVCB.SVCParamKey" — the 16-bit key codes,+  with pattern synonyms for the registered keys.+* "Net.DNSBase.RData.SVCB.SVCParamValue" — the+  'KnownSVCParamValue' typeclass, the existential+  'SVCB.SVCParamValue' wrapper, and the 'OpaqueSPV' fallback for+  unrecognised keys.+* "Net.DNSBase.RData.SVCB.SPV" — the concrete value types+  ('Net.DNSBase.RData.SVCB.SPV_alpn',+  'Net.DNSBase.RData.SVCB.SPV_port', ...).+* "Net.DNSBase.RData.SVCB.SPVSet" — the (key-indexed)+  collection holding the parameters of a single SVCB/HTTPS+  record.++New service-parameter value types can be installed at runtime via+'Net.DNSBase.Resolver.extendRRwithType' on the @SVCB@ or @HTTPS@+RR type — see "Net.DNSBase.Extensible" for a worked example.  The+@mandatory@ key (codepoint 0) is reserved and cannot be replaced+by user code.+-}+{-# LANGUAGE+    MagicHash+  , RecordWildCards+  , UndecidableInstances+  #-}+{-# OPTIONS_GHC -Wno-duplicate-exports #-}++module Net.DNSBase.RData.SVCB+    ( -- * SVCB and HTTPS+      X_svcb(.., T_SVCB, T_HTTPS)+    , type XsvcbConName+    , T_svcb+    , T_https+      -- *** 'T_SVCB' fields+    , svcPriority+    , svcTarget+    , svcParamValues+      -- *** 'T_HTTPS' fields+    , httpsPriority+    , httpsTarget+    , httpsParamValues+      -- * Service parameter values+    , KnownSVCParamValue(..)+    , SPVSet(..)+    , spvLookup+    , module Net.DNSBase.RData.SVCB.SPV+    , module Net.DNSBase.RData.SVCB.SVCParamValue+    , module Net.DNSBase.RData.SVCB.SVCParamKey+    ) where++import qualified Data.IntMap as IM+import Data.IntMap (IntMap)+import GHC.Exts (proxy#)+import GHC.IsList(IsList(..))+import GHC.TypeLits as TL (TypeError, ErrorMessage(..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal')++import Net.DNSBase.Internal.Util++import Net.DNSBase.Decode.Domain+import Net.DNSBase.Decode.State+import Net.DNSBase.Domain+import Net.DNSBase.Encode.Metric+import Net.DNSBase.Encode.State+import Net.DNSBase.Nat16+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RData.SVCB.SPV+import Net.DNSBase.RData.SVCB.SVCParamKey+import Net.DNSBase.RData.SVCB.SVCParamValue+import Net.DNSBase.RData.SVCB.SPVSet (SPVSet(..), spvSetFromMonoList, spvLookup)+import Net.DNSBase.RRTYPE++type XsvcbConName :: Nat -> Symbol+type family XsvcbConName n where+    XsvcbConName N_svcb  = "T_SVCB"+    XsvcbConName N_https = "T_HTTPS"+    XsvcbConName n       = TypeError+                           ( ShowType n+                             :<>: TL.Text " is not a SVCB-based RRTYPE" )++-- | Each parameter decoder is responsible for deserialising just the value+-- part of the service parameter key-value pair, the key is already decoded and+-- used to locate the right map entry.  The input 'Int' parameter is the+-- length of the serialised data to decode.+--+type SPVDecoderMap = IntMap (Int -> SGet SVCParamValue)++-- | X_svcb specialised to @SVCB@ records.+type T_svcb  = X_svcb N_svcb+-- | X_svcb specialised to @HTTPS@ records.+type T_https = X_svcb N_https++-- | Record pattern synonym viewing the shared 'X_svcb' record as a+-- generic SVCB service-binding record (RFC 9460).  Fields:+-- 'svcPriority', 'svcTarget', 'svcParamValues'.  See 'X_svcb' for+-- why 'T_svcb' and 'T_https' are not coercible.+pattern T_SVCB :: Word16 -- ^ SvcPriority+               -> Domain -- ^ TargetName+               -> SPVSet -- ^ SvcParams+               -> T_svcb+pattern T_SVCB { svcPriority, svcTarget, svcParamValues }+      = (X_SVCB svcPriority svcTarget svcParamValues :: T_svcb)+{-# COMPLETE T_SVCB #-}++-- | Record pattern synonym viewing the shared 'X_svcb' record as+-- an HTTPS service-binding record (RFC 9460).  Fields:+-- 'httpsPriority', 'httpsTarget', 'httpsParamValues'.+pattern T_HTTPS :: Word16 -- ^ SvcPriority+                -> Domain -- ^ TargetName+                -> SPVSet -- ^ SvcParams+                -> T_https+pattern T_HTTPS { httpsPriority, httpsTarget, httpsParamValues }+      = (X_SVCB httpsPriority httpsTarget httpsParamValues :: T_https)+{-# COMPLETE T_HTTPS #-}++-- | Shared wire-format representation for the @SVCB@ service+-- binding record+-- ([RFC 9460 section 2](https://datatracker.ietf.org/doc/html/rfc9460#section-2))+-- and its HTTPS-specific variant+-- ([RFC 9460 section 9](https://datatracker.ietf.org/doc/html/rfc9460#section-9)).+-- The type parameter @n@ (either 'N_svcb' or 'N_https') determines+-- the RR type.  Each has its own type synonym ('T_svcb',+-- 'T_https') and matching record pattern synonym ('T_SVCB',+-- 'T_HTTPS') with the corresponding field-name prefix (@svc@,+-- @https@).  The wire format is shared, but the type role of+-- @n@ is @nominal@: a 'T_svcb' value cannot be used where a+-- 'T_https' is expected.  This is deliberate — the two RR types+-- serve different transports, and future SvcParamKeys may apply+-- to only one of them.+--+-- >                                 1  1  1  1  1  1+-- >   0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                  SvcPriority                  |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                  TargetName                   /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                   SvcParams                   /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- The target field is not subject to wire-form name compression+-- ([RFC 3597 section 4](https://datatracker.ietf.org/doc/html/rfc3597#section-4))+-- and is /not/ in the+-- [RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)+-- list of types that lower-case their RDATA names — it is+-- compared case-sensitively in canonical form.  The 'Ord'+-- instance compares structurally on the parsed fields rather+-- than on the wire form, so it is /not/ canonical: callers that+-- need RFC 4034 canonical ordering must serialise to wire form+-- first.+--+-- The /SvcParams/ field is a list of @(key, length, value)@+-- triples — possibly empty — making up the rest of the RData:+--+-- >                                 1  1  1  1  1  1+-- >   0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                  SvcParamKey                  |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > |                  SvcParamLen                  |+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                  SvcParamValue                /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- On the wire the list must be in strictly ascending key order;+-- the presentation form may list keys in any order.  Each value+-- has the type associated with its key in the decoder state+-- configured for the RR type — keys absent from the state decode+-- as 'OpaqueSPV', preserving the raw bytes.+--+-- The record pattern synonyms 'T_SVCB' and 'T_HTTPS' build the+-- corresponding 'T_svcb' or 'T_https' value directly, with their+-- own field-name prefixes (@svc@ and @https@):+--+-- > let s = T_SVCB  { svcPriority      = 0+-- >                 , svcTarget        = RootDomain+-- >                 , svcParamValues   = [] }+-- >     h = T_HTTPS { httpsPriority    = 0+-- >                 , httpsTarget      = RootDomain+-- >                 , httpsParamValues = [] }+-- >  in RData s : RData h : []+--+-- Functions that work on either RR type can use the+-- underscore-prefixed selectors on the shared 'X_svcb' record:+--+-- > aliasDomain :: forall n. X_svcb n -> Maybe Domain+-- > aliasDomain r | _svcPriority r == 0 = Just $ _svcTarget r+-- >               | otherwise           = Nothing+type X_svcb :: Nat -> Type+type role X_svcb nominal+data X_svcb n = X_SVCB+    { _svcPriority    :: Word16 -- ^ SvcPriority+    , _svcTarget      :: Domain -- ^ TargetName+    , _svcParamValues :: SPVSet -- ^ SvcParams+    }++deriving instance Eq (X_svcb n)++instance (KnownSymbol (XsvcbConName n)) => Show (X_svcb n) where+    showsPrec p X_SVCB{..} = showsP p $+        showString (symbolVal' (proxy# @(XsvcbConName n))) . showChar ' '+        . shows' _svcPriority    . showChar ' '+        . shows' _svcTarget      . showChar ' '+        . shows' _svcParamValues++instance Ord (X_svcb n) where+    a `compare` b = (_svcPriority a) `compare` (_svcPriority b)+                 <> (_svcTarget   a) `compare` (_svcTarget   b)+                 <> (spvs         a) `compare` (spvs         b)+      where+        spvs = toList . _svcParamValues++instance Presentable (X_svcb n) where+    present (X_SVCB p d vs)  =+        present p . presentSp d . flip (foldr presentSp) (toList vs)++instance (Nat16 n, KnownSymbol (XsvcbConName n)) => KnownRData (X_svcb n) where+    type RDataExtensionVal (X_svcb n) = SPVDecoderMap+    rdataExtensionVal _ = baseSVCParams++    rdType _ = RRTYPE $ natToWord16 n+    rdEncode (X_SVCB p d vs) = do+        putSizedBuilder $ mbWord16 p <> mbWireForm d+        mapM_ enc $ toList vs+      where+        enc (SVCParamValue (x :: t)) = do+            put16 $ coerce $ spvKey t+            passLen $ encodeSPV x+    -- The resolver serice parameter extension slots for @T_svcb@+    -- and @T_https@ are configured with the table of known parameters+    -- and can be extended at runtime as part of resolver configuration.+    rdDecode _ sdm len = do+        pos0            <- getPosition+        _svcPriority    <- get16+        _svcTarget      <- getDomainNC+        pos1            <- getPosition+        vals            <- decodeSVCFieldValues (len - (pos1 - pos0))+        let _svcParamValues = spvSetFromMonoList $ reverse vals+        pure $ RData $ (X_SVCB{..} :: X_svcb n)+      where+        decodeSVCFieldValues :: Int -> SGet [SVCParamValue]+        decodeSVCFieldValues = fitSGet <$> id <*> loop [] 0+          where+            loop :: [SVCParamValue] -> Word16 -> Int -> SGet [SVCParamValue]+            loop acc !kmin !n | n > 0 = do+                pos0 <- getPosition+                key  <- get16+                vlen <- getInt16+                when (key == 0xffff) reserved+                when (kmin > key) $ nonmono (kmin-1) key+                spv <- case IM.lookup (fromIntegral key) sdm of+                    Just dc -> fitSGet vlen $ dc vlen+                    Nothing -> opaqueSPV key <$> getShortNByteString vlen+                used <- (subtract pos0) <$> getPosition+                loop (spv : acc) (key + 1) (n - used)+            loop acc _ 0 = pure acc+            loop _ _ _ = failSGet "internal error"++            -- 65535 is a reserved "Invalid key"+            reserved = failSGet "Reserved invalid key: 65535"+            -- Keys MUST be in strictly increasing order+            nonmono k1 k2 =+                failSGet $ "Non-increasing keys: " ++ show k1 ++ ", " ++ show k2++instance (Nat16 n, KnownSymbol (XsvcbConName n))+      => TypeExtensible (X_svcb n) SPVDecoderMap where+    type TypeExtensionArg (X_svcb n) b = KnownSVCParamValue b++    -- Insert the typed decoder at b's SvcParam key, except for the+    -- reserved @mandatory@ slot (codepoint 0), which the library+    -- owns and silently drops user attempts to replace.+    extendByType _ b m+        | key == mandatoryKey = m+        | otherwise = IM.insert key (decodeSPV b) m+      where+        key = fromIntegral @Word16 . coerce $ spvKey b++-- | Initial decoder state used as the+-- 'Net.DNSBase.RData.rdataExtensionVal' for both 'T_svcb' and+-- 'T_https'.  Not exported: user code interacts with it through+-- 'Net.DNSBase.Resolver.extendRRwithType', which calls+-- 'extendByType' to insert additional 'KnownSVCParamValue'+-- decoders.+baseSVCParams :: SPVDecoderMap+baseSVCParams = IM.fromList+    [ spvMapEntry SPV_mandatory+    , spvMapEntry SPV_alpn+    , spvMapEntry SPV_ndalpn+    , spvMapEntry SPV_port+    , spvMapEntry SPV_ipv4hint+    , spvMapEntry SPV_ech+    , spvMapEntry SPV_ipv6hint+    , spvMapEntry SPV_dohpath+    , spvMapEntry SPV_tlsgroups+    , spvMapEntry SPV_docpath+    , spvMapEntry SPV_pvd+    ]+  where+    spvMapEntry :: forall a -> KnownSVCParamValue a+                => (Int, Int -> SGet SVCParamValue)+    spvMapEntry a =+        ( fromIntegral @Word16 . coerce $ spvKey a+        , decodeSPV a)++-- Numeric SvcParamKey for the @mandatory@ key; protected from+-- user override inside 'extendByType'.+mandatoryKey :: Int+mandatoryKey = fromIntegral @Word16 . coerce $ spvKey SPV_mandatory
+ src/Net/DNSBase/RData/SVCB/SPV.hs view
@@ -0,0 +1,415 @@+{-|+Module      : Net.DNSBase.RData.SVCB.SPV+Description : Concrete value types for SVCB / HTTPS service parameters+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++One 'KnownSVCParamValue' instance per standardised service+parameter key.  Each type corresponds to a 'SVCParamKey' from+the IANA registry and carries the value payload for that key+in a form suited to the application that consumes it (a port+as 'Word16', address hints as a 'NonEmpty' of 'IPv4' / 'IPv6',+and so on).++An unknown key falls through to+'Net.DNSBase.RData.SVCB.OpaqueSPV', which preserves the raw wire+bytes.  Applications register additional typed values at runtime+via 'Net.DNSBase.Resolver.extendRRwithType' on the @SVCB@ or+@HTTPS@ RR type — see "Net.DNSBase.Extensible" for a worked+example.+-}++module Net.DNSBase.RData.SVCB.SPV+    ( SPV_mandatory(SPV_MANDATORY)+    , SPV_alpn(..)+    , SPV_ndalpn(..)+    , SPV_port(..)+    , SPV_ipv4hint(..)+    , SPV_ipv6hint(..)+    , SPV_ech(..)+    , SPV_dohpath(..)+    , SPV_docpath(..)+    , SPV_tlsgroups(..)+    , SPV_pvd(..)+    ) where++import qualified Data.ByteString.Short as SB+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Unsafe as T+import Data.Set (Set)++import Net.DNSBase.Internal.Util++import Net.DNSBase.Bytes+import Net.DNSBase.Decode.State+import Net.DNSBase.Encode.Metric+import Net.DNSBase.Encode.State+import Net.DNSBase.NonEmpty+import Net.DNSBase.Present+import Net.DNSBase.RData.SVCB.SPVList+import Net.DNSBase.RData.SVCB.SVCParamKey+import Net.DNSBase.RData.SVCB.SVCParamValue+import Net.DNSBase.Text++-- | The @mandatory@ service parameter+-- ([RFC 9460 section 8](https://datatracker.ietf.org/doc/html/rfc9460#section-8))+-- — the set of additional 'SVCParamKey' codes a client must+-- recognise to make sense of this RR, on top of any keys that+-- are automatically mandatory for the application protocol.  A+-- client that does not understand all the listed keys must+-- ignore the RR.+--+-- The set may not be empty on the wire (an empty list is+-- encoded as the parameter being absent) and may hold at most+-- 32767 keys.  The constructor is not exported; build instances+-- via 'fromNonEmptyList' or by combining values with their+-- 'Semigroup' instance.+newtype SPV_mandatory = SPV_mandatory (Set SVCParamKey)+    deriving (Eq, Semigroup)++-- | One-way pattern exposing the underlying key set for lookups.+-- Construction is available only via 'fromNonEmptyList' or via the+-- 'Semigroup' instance.+pattern SPV_MANDATORY :: Set SVCParamKey -- ^ The keys as a 'Set'+                      -> SPV_mandatory+pattern SPV_MANDATORY s <- SPV_mandatory s+{-# COMPLETE SPV_MANDATORY #-}++instance Show SPV_mandatory where+    showsPrec p (SPV_mandatory s) = showsP p $+        showString "fromNonEmptyList @SPV_mandatory "+        . shows' (NE.fromList $ Set.toList s)++instance IsNonEmptyList SPV_mandatory where+    type Item1 SPV_mandatory = SVCParamKey+    fromNonEmptyList = coerce . Set.fromList . NE.toList+    toNonEmptyList = NE.fromList . Set.toList . coerce++-- | Wire-form order+instance Ord SPV_mandatory where+    SPV_MANDATORY a `compare` SPV_MANDATORY b =+        comparing Set.size a b+        <> comparing Set.toList a b++instance Presentable SPV_mandatory where+    present (SPV_MANDATORY (NE.fromList . Set.toList -> key :| keys)) =+        present MANDATORY+        . pfst key+        . flip (foldr pnxt) keys+      where+        pfst = presentCharSep '='+        pnxt = presentCharSep ','++instance KnownSVCParamValue SPV_mandatory where+    spvKey _ = MANDATORY+    encodeSPV (SPV_MANDATORY (coerce -> ks)) = do+        when (Set.size ks > 0x7fff) do failWith CantEncode+        putSizedBuilder $ foldMap mbWord16+                        $ coerce @[SVCParamKey] @[Word16] $ Set.toList ks++    -- | Decode the mandatory key list.+    -- XXX: Does not yet enforce ascending order, non-duplication,+    -- self-exclusion, or exclusion of automatically mandatory keys, all of+    -- which are required by the SVCB draft:+    -- <https://datatracker.ietf.org/doc/html/draft-ietf-dnsop-svcb-https-12#section-2.2>,+    -- <https://datatracker.ietf.org/doc/html/draft-ietf-dnsop-svcb-https-12#section-8>+    --+    -- The resulting keyset will however be de-duplicated and ordered.+    --+    decodeSPV _ len = do+        k <- mkKey <$> get16+        ks <- getFixedWidthSequence 2 (mkKey <$> get16) (len - 2)+        pure $ SVCParamValue $ mkMandatory $ Set.fromList $ k : ks+      where+        mkKey :: Word16 -> SVCParamKey+        mkKey = coerce+        mkMandatory :: Set SVCParamKey -> SPV_mandatory+        mkMandatory = coerce++-- | The @alpn@ service parameter+-- ([RFC 9460 section 7.1](https://datatracker.ietf.org/doc/html/rfc9460#section-7.1))+-- — the set of Application-Layer Protocol Negotiation+-- ([RFC 7301](https://datatracker.ietf.org/doc/html/rfc7301))+-- protocol identifiers this service endpoint supports.  Together+-- with 'SPV_ndalpn' it defines the SVCB ALPN set: by default the+-- scheme's protocol is implicitly included, and 'SPV_ndalpn'+-- suppresses that default.+newtype SPV_alpn = SPV_ALPN (NonEmpty ShortByteString)+    deriving (Eq, Show)++instance Ord SPV_alpn where+    (SPV_ALPN as) `compare` (SPV_ALPN bs) =+        comparing len as bs+        <> comparing (coerce @(NonEmpty ShortByteString) @(NonEmpty DnsText)) as bs+      where+        len xs = foldl' (\a x -> a + 1 + SB.length x) 0 xs++instance Presentable SPV_alpn where+    present (SPV_ALPN vs) =+        present ALPN . present '=' . presentSPVList vs++instance KnownSVCParamValue SPV_alpn where+    spvKey _ = ALPN+    encodeSPV (SPV_ALPN vs) =+        putSizedBuilder $ foldMap (mbShortByteStringLen8 . coerce) vs+    decodeSPV _ len = do+        pos0 <- getPosition+        a <- getShortByteStringLen8+        pos1 <- getPosition+        let used = pos1 - pos0+        as <- getVarWidthSequence getShortByteStringLen8 (len - used)+        pure $ SVCParamValue . SPV_ALPN $ a :| as++-- | The @no-default-alpn@ service parameter+-- ([RFC 9460 section 7.1](https://datatracker.ietf.org/doc/html/rfc9460#section-7.1))+-- — a value-less flag that suppresses the scheme's default ALPN+-- from the SVCB ALPN set.  Meaningful only alongside an explicit+-- 'SPV_alpn' that supplies a replacement protocol list.+data SPV_ndalpn = SPV_NDALPN+    deriving (Eq, Ord, Show)++instance Presentable SPV_ndalpn where+    present _ = present NODEFAULTALPN++instance KnownSVCParamValue SPV_ndalpn where+    spvKey _ = NODEFAULTALPN+    encodeSPV _ = pure ()+    decodeSPV _ _ = pure $ SVCParamValue SPV_NDALPN++-- | The @port@ service parameter+-- ([RFC 9460 section 7.2](https://datatracker.ietf.org/doc/html/rfc9460#section-7.2))+-- — overrides the scheme's default TCP or UDP port for reaching+-- this service endpoint.+newtype SPV_port = SPV_PORT Word16+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++instance Presentable SPV_port where+    present (SPV_PORT port) =+        present PORT+        . presentCharSep '=' port++instance KnownSVCParamValue SPV_port where+    spvKey _ = PORT+    encodeSPV = put16 . coerce+    decodeSPV _ _ = SVCParamValue . SPV_PORT <$> get16++-- | The @ipv4hint@ service parameter+-- ([RFC 9460 section 7.3](https://datatracker.ietf.org/doc/html/rfc9460#section-7.3))+-- — a non-empty list of IPv4 addresses for this service endpoint+-- that a client may use to start a connection in parallel with+-- an authoritative @A@ lookup.  Hints are advisory; clients+-- should still validate them against authoritative address+-- records when they arrive.+newtype SPV_ipv4hint = SPV_IPV4HINT (NonEmpty IPv4)+    deriving (Eq)++instance Show SPV_ipv4hint where+    showsPrec p (SPV_IPV4HINT ips) = showsP p $+        showString "SPV_IPV4HINT "+        . shows' (fmap show ips)++instance Ord SPV_ipv4hint where+    compare (SPV_IPV4HINT a) (SPV_IPV4HINT b) =+        comparing NE.length a b <> compare a b++instance Presentable SPV_ipv4hint where+    present (SPV_IPV4HINT (a :| as)) =+        present IPV4HINT+        . pfst a+        . flip (foldr pnxt) as+      where+        pfst = presentCharSep '='+        pnxt = presentCharSep ','++instance KnownSVCParamValue SPV_ipv4hint where+    spvKey _ = IPV4HINT+    encodeSPV (SPV_IPV4HINT ips) = putSizedBuilder $ foldMap mbIPv4 ips+    decodeSPV _ len = do+        ip  <- getIPv4+        ips <- getFixedWidthSequence 4 getIPv4 (len - 4)+        return $ SVCParamValue $ SPV_IPV4HINT (ip :| ips)++-- | The @ipv6hint@ service parameter+-- ([RFC 9460 section 7.3](https://datatracker.ietf.org/doc/html/rfc9460#section-7.3))+-- — the IPv6 counterpart of 'SPV_ipv4hint': a non-empty list of+-- IPv6 addresses to try in parallel with the authoritative+-- @AAAA@ lookup.+newtype SPV_ipv6hint = SPV_IPV6HINT (NonEmpty IPv6)+    deriving (Eq)++instance Show SPV_ipv6hint where+    showsPrec p (SPV_IPV6HINT ips) = showsP p $+        showString "SPV_IPV6HINT "+        . shows' (fmap show ips)++instance Ord SPV_ipv6hint where+    compare (SPV_IPV6HINT a) (SPV_IPV6HINT b) =+        comparing NE.length a b <> compare a b++instance Presentable SPV_ipv6hint where+    present (SPV_IPV6HINT (a :| as)) =+        present IPV6HINT+        . pfst a+        . flip (foldr pnxt) as+      where+        pfst = presentCharSep '='+        pnxt = presentCharSep ','++instance KnownSVCParamValue SPV_ipv6hint where+    spvKey _ = IPV6HINT+    encodeSPV (SPV_IPV6HINT ips) = putSizedBuilder $ foldMap mbIPv6 ips+    decodeSPV _ len = do+        ip  <- getIPv6+        ips <- getFixedWidthSequence 16 getIPv6 (len - 16)+        return $ SVCParamValue $ SPV_IPV6HINT (ip :| ips)++-- | The @ech@ service parameter+-- ([RFC9848, Section 3](https://datatracker.ietf.org/doc/html/rfc9848#section-3))+-- — an Encrypted Client Hello (ECH) configuration list.+-- Presented as a base64-encoded value.+newtype SPV_ech = SPV_ECH ShortByteString+    deriving (Eq, Show)++instance Ord SPV_ech where+    compare = dnsTextCmp++instance Presentable SPV_ech where+    present (SPV_ECH c) = present ECH . presentCharSep @Bytes64 '=' (coerce c)++instance KnownSVCParamValue SPV_ech where+    spvKey _ = ECH+    encodeSPV (SPV_ECH c) = putShortByteString $ coerce c+    decodeSPV _ 0 = failSGet "Invalid empty 'ech' ParamKey value"+    decodeSPV _ len+        | len < 4 = failSGet "'ech' ParamKey value too short"+        | otherwise = SVCParamValue . SPV_ECH <$> getShortNByteString len++-- | The @dohpath@ service parameter+-- ([RFC 9461](https://datatracker.ietf.org/doc/html/rfc9461#name-new-svcparamkey-dohpath))+-- — a URI template (UTF-8) advertising the DNS-over-HTTPS+-- endpoint at this service.  Typically seen on resolver-discovery+-- answers to queries for @_dns.resolver.arpa@ or on explicit+-- queries to a specific operator's resolver.+newtype SPV_dohpath = SPV_DOHPATH T.Text+    deriving (Eq, Show)++instance Ord SPV_dohpath where+    compare (SPV_DOHPATH a) (SPV_DOHPATH b) =+        comparing T.lengthWord8 a b+        <> compare a b++instance Presentable SPV_dohpath where+    present (SPV_DOHPATH uri) =+        present DOHPATH . presentCharSep @DnsUtf8Text '=' (coerce uri)++instance KnownSVCParamValue SPV_dohpath where+    spvKey _ = DOHPATH+    encodeSPV (SPV_DOHPATH uri) = putUtf8Text uri+    decodeSPV _ = SVCParamValue . SPV_DOHPATH <.> getUtf8Text++-- | The @docpath@ service parameter+-- ([RFC 9953 section 8.2](https://datatracker.ietf.org/doc/html/rfc9953#section-8.2))+-- — the absolute path to the DNS-over-CoAP (DoC) resource at this+-- service endpoint, represented as a list of path segments.  An+-- empty list denotes the root path @\"/\"@ (on the wire: a+-- zero-length SvcParamValue).+--+-- Each segment is 1..255 octets per the RFC ABNF; the wire-form+-- decoder rejects zero-length segments.  Presentation form is a+-- comma-separated list of segments using the standard RFC 9460+-- Appendix A.1 quoting and escaping rules, identical to those of+-- 'SPV_alpn'.+newtype SPV_docpath = SPV_DOCPATH [ShortByteString]+    deriving (Eq, Show)++-- | Wire-form canonical order: by total wire length first, then+-- by the segment-list 'DnsText' ordering.+instance Ord SPV_docpath where+    (SPV_DOCPATH as) `compare` (SPV_DOCPATH bs) =+        comparing wireLen as bs+        <> comparing (coerce @[ShortByteString] @[DnsText]) as bs+      where+        wireLen = foldl' (\a x -> a + 1 + SB.length x) 0++instance Presentable SPV_docpath where+    present (SPV_DOCPATH vs) =+        present DOCPATH . present '=' . presentCSVList vs++instance KnownSVCParamValue SPV_docpath where+    spvKey _ = DOCPATH+    encodeSPV (SPV_DOCPATH vs) =+        putSizedBuilder $ foldMap mbShortByteStringLen8 vs+    decodeSPV _ len = do+        vs <- getVarWidthSequence segment len+        pure $ SVCParamValue $ SPV_DOCPATH vs+      where+        segment = do+            seg <- getShortByteStringLen8+            when (SB.null seg) $ failSGet "Empty docpath segment"+            pure seg++-- | The @tls-supported-groups@ service parameter+-- ([draft-ietf-tls-key-share-prediction-04 section 5](https://datatracker.ietf.org/doc/html/draft-ietf-tls-key-share-prediction-04#section-5))+-- — a non-empty list of TLS Named Group codepoints (the+-- [IANA TLS Supported Groups registry](https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-8))+-- that the service supports.  Clients can use this hint to+-- predict an acceptable key share, reducing the chance of a+-- HelloRetryRequest round-trip.+--+-- The wire form is a non-empty sequence of 16-bit codepoints in+-- network byte order; the decoder rejects an empty value.  The+-- presentation form is a comma-separated list of decimal+-- integers and forbids zone-file escape sequences (per the+-- draft).  Duplicates are flagged as a syntax error by the+-- specification but are not currently rejected by either the+-- encoder or the decoder — callers are expected to feed in a+-- duplicate-free list, in their preferred order (the spec does+-- not impose canonical ordering on the wire).+newtype SPV_tlsgroups = SPV_TLSGROUPS (NonEmpty Word16)+    deriving (Eq, Show)++-- | Wire-form canonical order: by length first, then elementwise.+instance Ord SPV_tlsgroups where+    (SPV_TLSGROUPS as) `compare` (SPV_TLSGROUPS bs) =+        comparing NE.length as bs <> compare as bs++instance Presentable SPV_tlsgroups where+    present (SPV_TLSGROUPS (g :| gs)) =+        present TLSGROUPS+        . pfst g+        . flip (foldr pnxt) gs+      where+        pfst = presentCharSep '='+        pnxt = presentCharSep ','++instance KnownSVCParamValue SPV_tlsgroups where+    spvKey _ = TLSGROUPS+    encodeSPV (SPV_TLSGROUPS gs) = putSizedBuilder $ foldMap mbWord16 gs+    decodeSPV _ len = do+        g  <- get16+        gs <- getFixedWidthSequence 2 get16 (len - 2)+        pure $ SVCParamValue $ SPV_TLSGROUPS (g :| gs)++-- | The @pvd@ service parameter+-- ([draft-ietf-intarea-proxy-config-14 section 7.5](https://datatracker.ietf.org/doc/html/draft-ietf-intarea-proxy-config-14#section-7.5))+-- — a value-less flag that announces the host supports+-- Provisioning Domain discovery via the well-known PvD URI.  Its+-- presence in an SVCB or HTTPS RR signals that a client MAY+-- fetch PvD Additional Information from+-- @https:\/\/host\/.well-known\/pvd@.  Per the draft, the wire+-- value MUST be empty; the presentation form is just the bare+-- key name with no @\'=\'@.+data SPV_pvd = SPV_PVD+    deriving (Eq, Ord, Show)++instance Presentable SPV_pvd where+    present _ = present PVD++instance KnownSVCParamValue SPV_pvd where+    spvKey _ = PVD+    encodeSPV _ = pure ()+    decodeSPV _ _ = pure $ SVCParamValue SPV_PVD
+ src/Net/DNSBase/RData/SVCB/SPVList.hs view
@@ -0,0 +1,26 @@+{-|+Module      : Net.DNSBase.RData.SVCB.SPVList+Description : Internal helper for presenting comma-separated SVCB value lists+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++A small helper used by the multi-valued SVCB service-parameter+types ('Net.DNSBase.RData.SVCB.SPV_alpn' and friends) to emit their values in the+RFC 9460 comma-separated zone-file form.+-}++module Net.DNSBase.RData.SVCB.SPVList+    ( presentSPVList+    ) where++import Net.DNSBase.Internal.Util++import Net.DNSBase.Text++-- | Render a non-empty list of byte-string values as a single+-- comma-separated DNS character-string, in the form expected for+-- multi-valued service parameters such as @alpn@.+presentSPVList :: (NonEmpty ShortByteString) -> Builder -> Builder+presentSPVList (v :| vs) = presentCSVList (v : vs)
+ src/Net/DNSBase/RData/SVCB/SPVSet.hs view
@@ -0,0 +1,113 @@+{-|+Module      : Net.DNSBase.RData.SVCB.SPVSet+Description : Indexed collection of SVCB service-parameter values+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The collection of service parameters carried in a single+@SVCB@ or @HTTPS@ record, keyed by 'Net.DNSBase.RData.SVCB.SVCParamKey' (one value+per key code, per RFC 9460).  Construction is via the 'IsList'+instance — @fromList [SVCParamValue p1, ...]@; enumeration via+'toList' returns the parameters in ascending key order, which+is also the canonical on-the-wire order.++Each key code is associated with a specific 'KnownSVCParamValue'+type; the values are held inside the existential 'SVCParamValue'+wrapper so a single set can mix heterogeneous parameter types.+'spvLookup' takes the parameter /type/ as a type application+and returns the typed value when the matching key is present:++> ghci> import qualified GHC.IsList as IL (fromList)+> ghci> spvset = IL.fromList @SPVSet [SVCParamValue (SPV_PORT 80), SVCParamValue SPV_NDALPN]+> ghci> spvset+> fromList @SPVSet [SVCParamValue SPV_NDALPN,SVCParamValue 80]+> ghci> spvLookup @SPV_ndalpn spvset+> Just SPV_NDALPN++The type application can be elided when a pattern match+constrains the result type:++> ghci> case spvLookup spvset of { Just (SPV_PORT p) -> p; _ -> 0 }+> 80+-}++module Net.DNSBase.RData.SVCB.SPVSet+    ( SPVSet(SPVMap)+    , spvLookup+    , spvSetFromMonoList+    ) where++import qualified Data.IntMap.Strict as IM+import GHC.IsList(IsList(..))++import Net.DNSBase.Internal.Util++import Net.DNSBase.Present+import Net.DNSBase.RData.SVCB.SVCParamValue++-- | The set of service parameters in an @SVCB@ or @HTTPS@ record,+-- with at most one value per 'Net.DNSBase.RData.SVCB.SVCParamKey'.  The 'Monoid'+-- instance provides the empty set; the 'Semigroup' instance is+-- left-biased on key collisions.+newtype SPVSet = SPVSet (IM.IntMap SVCParamValue)+    deriving (Eq, Semigroup, Monoid)++instance Show SPVSet where+    showsPrec p (toList -> pvs) = showsP p $+        showString "fromList @SPVSet " . shows' pvs++instance Presentable SPVSet where+    present vs k = case toList vs of+        v:rest -> present v $ foldr presentSp k rest+        []     -> k++-- | One-sided pattern that exposes the underlying 'IM.IntMap' for+-- traversal or low-level inspection.  The values are kept in the+-- existential 'SVCParamValue' wrapper, so any concrete parameter+-- may be either typed (a 'KnownSVCParamValue' instance) or+-- 'Net.DNSBase.RData.SVCB.OpaqueSPV'.  For typed lookups by parameter type use+-- 'spvLookup' instead.+pattern SPVMap :: IM.IntMap SVCParamValue -- ^ Values as an 'IM.IntMap'+               -> SPVSet+pattern SPVMap m <- SPVSet m++-- | Look up the parameter at the key associated with type @a@,+-- returning a 'Just' only when the stored value really is of type+-- @a@.  A value of the same key code but held as 'Net.DNSBase.RData.SVCB.OpaqueSPV'+-- (because the typed instance was not registered when the record+-- was decoded) does /not/ match — opaque values must be+-- retrieved through 'SPVMap'.+spvLookup :: forall a. KnownSVCParamValue a+          => SPVSet -> Maybe a+spvLookup = (>>= fromSPV @a) . IM.lookup key . coerce+  where+    key = fromIntegral $ spvKey a++-- | Construction is via 'fromList', and enumeration is via 'toList'.+instance IsList SPVSet where+    type Item SPVSet = SVCParamValue++    -- | Construct a parameter Map from an unordered list.+    fromList vs =+        coerce $ IM.fromList+               [ (key, v) | v <- vs , let key = fromIntegral $ serviceParamKey v ]++    -- | Return the map as a list in ascending parameter order.+    toList = IM.elems . coerce++-- | Build an 'SPVSet' from a list of 'SVCParamValue's whose keys+-- are in /strict monotone-increasing/ order (so also no+-- duplicates) — the precondition imposed by the underlying+-- 'IM.fromDistinctAscList' used to build the set.  The \"Mono\"+-- is intended as a reminder of the precondition.+--+-- Used internally by the wire-form decoder, which validates+-- ascending keys during parsing; application code that cannot+-- guarantee the precondition should use 'fromList' from the+-- 'IsList' instance instead.+spvSetFromMonoList :: [SVCParamValue] -> SPVSet+spvSetFromMonoList = coerce $ IM.fromDistinctAscList . map kv+  where+    kv !v = let !k = fromIntegral $ serviceParamKey v in (k, v)
+ src/Net/DNSBase/RData/SVCB/SVCParamKey.hs view
@@ -0,0 +1,94 @@+{-|+Module      : Net.DNSBase.RData.SVCB.SVCParamKey+Description : SVCB / HTTPS service-parameter key codes+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 16-bit numeric keys that select among service-parameter+values inside an @SVCB@ or @HTTPS@ resource record.  The keys+that were initially registered are listed in+[RFC 9460 section 14.3.2](https://datatracker.ietf.org/doc/html/rfc9460#section-14.3.2),+with subsequent additions tracked in the+[SvcParamKey IANA registry](https://www.iana.org/assignments/dns-svcb/dns-svcb.xhtml).+The bidirectional patterns below cover the keys that have+standardised value formats in this library; unknown keys are+carried as 'Net.DNSBase.RData.SVCB.OpaqueSPV' values.+-}++module Net.DNSBase.RData.SVCB.SVCParamKey where++import Data.Word (Word16)++import Net.DNSBase.Present+++-- | A service-parameter key code+-- ([RFC 9460 section 2.1](https://datatracker.ietf.org/doc/html/rfc9460#section-2.1)).+-- The pattern synonyms below name the keys that have standardised+-- value formats; an unrecognised code keeps its numeric form and+-- presents as @keyN@.+newtype SVCParamKey = SVCParamKey Word16+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++-- | Keys the client must understand to use this RR+-- [RFC9460, Section 14.3.2](https://datatracker.ietf.org/doc/html/rfc9460#section-14.3.2)+pattern MANDATORY     :: SVCParamKey ; pattern MANDATORY     = SVCParamKey 0++-- | Application-Layer Protocol Negotiation identifiers+-- [RFC9460, Section 14.3.2](https://datatracker.ietf.org/doc/html/rfc9460#section-14.3.2)+pattern ALPN          :: SVCParamKey ; pattern ALPN          = SVCParamKey 1++-- | Suppress the default ALPN for this scheme+-- [RFC9460, Section 14.3.2](https://datatracker.ietf.org/doc/html/rfc9460#section-14.3.2)+pattern NODEFAULTALPN :: SVCParamKey ; pattern NODEFAULTALPN = SVCParamKey 2++-- | Alternative TCP/UDP port+-- [RFC9460, Section 14.3.2](https://datatracker.ietf.org/doc/html/rfc9460#section-14.3.2)+pattern PORT          :: SVCParamKey ; pattern PORT          = SVCParamKey 3++-- | Speculative IPv4 address hints+-- [RFC9460, Section 14.3.2](https://datatracker.ietf.org/doc/html/rfc9460#section-14.3.2)+pattern IPV4HINT      :: SVCParamKey ; pattern IPV4HINT      = SVCParamKey 4++-- | Encrypted Client Hello configuration+-- [RFC9848, IANA Considerations](https://datatracker.ietf.org/doc/html/rfc9848#name-iana-considerations)+pattern ECH           :: SVCParamKey ; pattern ECH           = SVCParamKey 5++-- | Speculative IPv6 address hints+-- [RFC9460, Section 14.3.2](https://datatracker.ietf.org/doc/html/rfc9460#section-14.3.2)+pattern IPV6HINT      :: SVCParamKey ; pattern IPV6HINT      = SVCParamKey 6++-- | URI template for DNS-over-HTTPS resolver discovery+-- [RFC9461, Section 4](https://datatracker.ietf.org/doc/html/rfc9461#section-4)+pattern DOHPATH       :: SVCParamKey ; pattern DOHPATH       = SVCParamKey 7++-- | Oblivious HTTP support indicator+-- [RFC9540, Section 4](https://datatracker.ietf.org/doc/html/rfc9540#section-4)+pattern OHTTP         :: SVCParamKey ; pattern OHTTP         = SVCParamKey 8++-- | TLS supported groups+-- [draft-ietf-tls-key-share-prediction-04, section 5](https://datatracker.ietf.org/doc/html/draft-ietf-tls-key-share-prediction-04#section-5)+pattern TLSGROUPS     :: SVCParamKey ; pattern TLSGROUPS     = SVCParamKey 9++-- | DNS over CoAP path [RFC9953, Section 3](https://datatracker.ietf.org/doc/html/rfc9953#section-8.2)+pattern DOCPATH       :: SVCParamKey ; pattern DOCPATH       = SVCParamKey 10++-- | Provisioning Domain [RFC-ietf-intarea-proxy-config-14, Section 7.5](https://datatracker.ietf.org/doc/html/draft-ietf-intarea-proxy-config-14#section-7.5)+pattern PVD           :: SVCParamKey ; pattern PVD           = SVCParamKey 11++instance Presentable SVCParamKey where+    present MANDATORY       = present @String "mandatory"+    present ALPN            = present @String "alpn"+    present NODEFAULTALPN   = present @String "no-default-alpn"+    present PORT            = present @String "port"+    present IPV4HINT        = present @String "ipv4hint"+    present ECH             = present @String "ech"+    present IPV6HINT        = present @String "ipv6hint"+    present DOHPATH         = present @String "dohpath"+    present OHTTP           = present @String "ohttp"+    present TLSGROUPS       = present @String "tls-supported-groups"+    present DOCPATH         = present @String "docpath"+    present PVD             = present @String "pvd"+    present (SVCParamKey n) = present @String "key" . present n
+ src/Net/DNSBase/RData/SVCB/SVCParamValue.hs view
@@ -0,0 +1,194 @@+{-|+Module      : Net.DNSBase.RData.SVCB.SVCParamValue+Description : Typed values for SVCB / HTTPS service-parameter keys+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++An @SVCB@ or @HTTPS@ record carries a list of (key, value) service+parameters.  Each key has its own value type, so the value side is+structured as an extensible typeclass 'KnownSVCParamValue' with+one instance per standardised key, wrapped in an existential+'SVCParamValue' so a single list can hold a heterogeneous mix.+Unknown keys fall through to 'OpaqueSPV', which preserves the raw+wire bytes for later inspection or pass-through.++Applications can add a new service-parameter type at runtime by+writing a 'KnownSVCParamValue' instance and installing it via+'Net.DNSBase.Resolver.extendRRwithType' on the @SVCB@ or @HTTPS@+RR type — see "Net.DNSBase.Extensible" for a worked example.+-}++module Net.DNSBase.RData.SVCB.SVCParamValue+    ( KnownSVCParamValue(..)+    , SVCParamValue(..)+    , fromSPV+    , serviceParamKey+      -- Representation of unknown parameters+    , OpaqueSPV(..)+    , opaqueSPV+    , toOpaqueSPV+    ) where++import qualified Data.ByteString.Short as SB+import Net.DNSBase.Internal.Util++import Net.DNSBase.Decode.State+import Net.DNSBase.Encode.State+import Net.DNSBase.Nat16+import Net.DNSBase.Present+import Net.DNSBase.RData.SVCB.SVCParamKey+import Net.DNSBase.Text++-- * Generic SVC Field-Value++-- | The class of types representing the value side of a service+-- parameter inside an @SVCB@ or @HTTPS@ record.  Each instance+-- corresponds to a specific 'SVCParamKey'; the 'encodeSPV' and+-- 'decodeSPV' methods handle only the value bytes.  The+-- surrounding @(key, length)@ frame is owned by the SVCB-record+-- encoder: 'encodeSPV' writes just the payload, and the framework+-- wraps the result in the 2-byte length prefix.+-- For value-less parameters this means 'encodeSPV' is just+-- @pure ()@.+--+-- The 'Presentable' instance builds the RFC 9460 zone-file+-- presentation form: the key name followed (where the value is+-- non-empty) by @=@ and the value.  The 'Show' instance is+-- typically derived and aims to produce syntactically valid+-- Haskell.+class (Typeable a, Eq a, Ord a, Show a, Presentable a) => KnownSVCParamValue a where+    -- | The associated key number+    spvKey     :: forall b -> b ~ a => SVCParamKey+    -- | CPS presentation form builder for the key+    spvKeyPres :: forall b -> b ~ a => Builder -> Builder+    -- | Encode value to wire form+    encodeSPV  :: forall r s. ErrorContext r => a -> SPut s r+    -- | Decode value from wire form+    decodeSPV  :: forall b -> b ~ a => Int -> SGet SVCParamValue++    -- | Override to get user-friendly output for runtime-added types.+    -- Otherwise, defaults to @key@/number/.+    spvKeyPres _ = present (spvKey a)+++-- | Existential wrapper around any 'KnownSVCParamValue', so a+-- single list can hold a mix of typed service parameters.  The+-- 'present' method delegates to the underlying instance, which+-- emits both the key name and the value.+data SVCParamValue = forall a. KnownSVCParamValue a => SVCParamValue a++-- | Extract specific known 'SVCParamValue' from existential wrapping+fromSPV :: forall a. KnownSVCParamValue a => SVCParamValue -> Maybe a+fromSPV (SVCParamValue a) = cast a++svcParamValueKey :: SVCParamValue -> SVCParamKey+svcParamValueKey (SVCParamValue (_ :: t)) = spvKey t+{-# INLINE svcParamValueKey #-}++-- | Perform a default encoding of the contained 'KnownSVCParamValue'.+spvEncode :: ErrorContext r => SVCParamValue -> SPut s r+spvEncode (SVCParamValue a) = encodeSPV a++-- | Key associated with a generic SvcParamValue+serviceParamKey :: SVCParamValue -> SVCParamKey+serviceParamKey (SVCParamValue (_ :: t)) = spvKey t++instance Eq SVCParamValue where+    (SVCParamValue (_a :: a)) == (SVCParamValue (_b :: b))+        | spvKey a /= spvKey b = False+        | Just Refl <- teq a b = _a == _b+        | otherwise = False++-- | Compare first by key number, then by content.+-- When two key numbers match, but the data types nevertheless differ, order+-- opaque type after non-opaque.  In the unlikely case of two non-opaque types+-- with the same key, compare their opaque encodings (this could throw an error+-- if one of the objects is not encodable, perhaps because encoding would be+-- too long).+instance Ord SVCParamValue where+    compare sa@(SVCParamValue (_a :: a)) sb@(SVCParamValue (_b :: b)) =+        compare (spvKey a) (spvKey b)+        <> if | Just Refl <- teq a b -> compare _a _b+              | isOpaque (spvKey a) sa -> GT+              | isOpaque (spvKey b) sb -> LT+              | otherwise              -> ocmp (toOpaqueSPV sa) (toOpaqueSPV sb)+      where+        ocmp (Right oa) (Right ob) = compare oa ob+        ocmp (Left e)   _          = error $ show e+        ocmp _          (Left e)   = error $ show e++instance Show SVCParamValue where+    showsPrec p (SVCParamValue a) =+        showParen (p > app_prec) $+            showString "SVCParamValue "+            . showsPrec (app_prec + 1) a+      where+        app_prec = 10++instance Presentable SVCParamValue where+    present (SVCParamValue a)  = present a++-- | Fallback carrier for service-parameter values whose key code+-- has no 'KnownSVCParamValue' instance registered.  The key code+-- is encoded as a type-level natural so 'OpaqueSPV' values with+-- different codes have distinct types.  The wire payload is kept+-- as raw bytes and round-trips losslessly; the presentation form+-- is @keyN=...@ with the value as a 'DnsText' character-string.+data OpaqueSPV n where+     OpaqueSPV :: Nat16 n => SB.ShortByteString -> OpaqueSPV n+deriving instance Eq (OpaqueSPV n)+deriving instance Ord (OpaqueSPV n)+deriving instance Show (OpaqueSPV n)++instance Nat16 n => KnownSVCParamValue (OpaqueSPV n) where+    spvKey _ = SVCParamKey $ natToWord16 n+    encodeSPV (OpaqueSPV txt) = putShortByteString txt+    decodeSPV _ = SVCParamValue . OpaqueSPV @n <.> getShortNByteString++instance Nat16 n => Presentable (OpaqueSPV n) where+    present (OpaqueSPV v) =+        present "key" . present (natToWord16 n)+        -- Empty values suppressed+        . bool id (presentCharSep @DnsText '=' (coerce v)) ((SB.length v) > 0)++-- | Build an 'SVCParamValue' from a raw numeric key and a raw+-- byte payload.  Useful when a caller has a wire encoding for a+-- key that has no registered 'KnownSVCParamValue' instance, or+-- when round-tripping bytes for keys that should remain+-- uninterpreted.+opaqueSPV :: Word16 -> SB.ShortByteString -> SVCParamValue+opaqueSPV w bs = withNat16 w go+  where+    go :: forall (n :: Nat) -> Nat16 n => SVCParamValue+    go n = SVCParamValue $ (OpaqueSPV bs :: OpaqueSPV n)++-- | Encode an 'SVCParamValue' to its 'OpaqueSPV' equivalent under+-- the same key code.  Values that are already opaque are returned+-- unchanged.  For typed values this re-encodes the payload to+-- wire form; encoding can fail (for example if the result would+-- be too long to fit a 16-bit length field), in which case the+-- 'EncodeErr' is returned.+toOpaqueSPV :: SVCParamValue -> Either (EncodeErr (Maybe ())) SVCParamValue+toOpaqueSPV s@(svcParamValueKey -> k) = withNat16 (coerce k) go+  where+    go :: forall (n :: Nat) -> Nat16 n+       => Either (EncodeErr (Maybe ())) SVCParamValue+    go n | isOpaque k s = Right s+         | otherwise+           = SVCParamValue . mkopaque <$> encodeVerbatim do spvEncode s+             where+               -- Raw value bytes (the SVCB framework supplies the+               -- 2-byte length prefix on the wire, but here we are+               -- capturing just the payload for opaque storage).+               mkopaque :: ByteString -> OpaqueSPV n+               mkopaque bs = OpaqueSPV $ SB.toShort bs++-- | Check whether the given 'SVCParamValue is opaque of given key.+--+isOpaque :: SVCParamKey -> SVCParamValue -> Bool+isOpaque k spv = withNat16 (coerce k) go+  where+    go :: forall (n :: Nat) -> Nat16 n => Bool+    go n = isJust (fromSPV spv :: Maybe (OpaqueSPV n))
+ src/Net/DNSBase/RData/TLSA.hs view
@@ -0,0 +1,257 @@+{-|+Module      : Net.DNSBase.RData.TLSA+Description : DANE-style key/certificate records (TLSA, SMIMEA, SSHFP, OPENPGPKEY)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++Four DANE-style records that publish cryptographic identifiers+via DNS.  'T_tlsa' (RFC 6698) carries TLS certificate+associations; 'T_smimea' (RFC 8162) carries the same for+S/MIME — both share the wire format of the underlying 'X_tlsa'+representation.  'T_sshfp' (RFC 4255) carries SSH host-key+fingerprints.  'T_openpgpkey' (RFC 7929) carries an OpenPGP+transferable public key.+-}+{-# LANGUAGE+    MagicHash+  , RecordWildCards+  , UndecidableInstances+  #-}++module Net.DNSBase.RData.TLSA+    ( -- * TLSA and SMIMEA+      X_tlsa(.., T_TLSA, T_SMIMEA)+    , type XtlsaConName, T_tlsa, T_smimea+      -- *** 'T_TLSA' fields+    , tlsaUsage+    , tlsaSelector+    , tlsaMtype+    , tlsaAssocData+      -- *** 'T_SMIMEA' fields+    , smimeaUsage+    , smimeaSelector+    , smimeaMtype+    , smimeaAssocData+      -- * SSHFP+    , T_sshfp(..)+      -- * OPENPGPKEY+    , T_openpgpkey(..)+    ) where++import GHC.Exts (proxy#)+import GHC.TypeLits as TL (TypeError, ErrorMessage(..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal')++import Net.DNSBase.Internal.Util++import Net.DNSBase.Bytes+import Net.DNSBase.Decode.State+import Net.DNSBase.Encode.Metric+import Net.DNSBase.Encode.State+import Net.DNSBase.Nat16+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RRTYPE++type XtlsaConName :: Nat -> Symbol+type family XtlsaConName n where+    XtlsaConName N_tlsa   = "T_TLSA"+    XtlsaConName N_smimea = "T_SMIMEA"+    XtlsaConName n        = TypeError+                     ( ShowType n+                       :<>: TL.Text " is not a TLSA or SMIMEA RRTYPE" )++-- | X_tlsa specialised to @TLSA@ records.+type T_tlsa      = X_tlsa N_tlsa+-- | X_tlsa specialised to @SMIMEA@ records.+type T_smimea    = X_tlsa N_smimea++-- | Record pattern synonym viewing the shared 'X_tlsa' record as a+-- @TLSA@ (DANE for TLS) record, RFC 6698.  Fields: 'tlsaUsage',+-- 'tlsaSelector', 'tlsaMtype', 'tlsaAssocData'.  Not coercible to/from+-- 'T_smimea': the role of 'X_tlsa' is /nominal/ because TLSA and SMIMEA+-- bind to different protocols and the shared wire format is+-- coincidental.+pattern T_TLSA :: Word8 -- ^ Certificate Usage+               -> Word8 -- ^ Selector+               -> Word8 -- ^ Matching Type+               -> ShortByteString -- ^ Certificate Association Data+               -> T_tlsa+pattern T_TLSA { tlsaUsage, tlsaSelector, tlsaMtype, tlsaAssocData }+      = (X_TLSA tlsaUsage tlsaSelector tlsaMtype tlsaAssocData :: T_tlsa)+{-# COMPLETE T_TLSA #-}++-- | Record pattern synonym viewing the shared 'X_tlsa' record as an+-- @SMIMEA@ (DANE for S/MIME) record, RFC 8162.  Fields: 'smimeaUsage',+-- 'smimeaSelector', 'smimeaMtype', 'smimeaAssocData'.  Not coercible+-- to/from 'T_tlsa' (see 'T_TLSA' note).+pattern T_SMIMEA :: Word8 -- ^ Certificate Usage+                 -> Word8 -- ^ Selector+                 -> Word8 -- ^ Matching Type+                 -> ShortByteString -- ^ Certificate Association Data+                 -> T_smimea+pattern T_SMIMEA { smimeaUsage, smimeaSelector, smimeaMtype, smimeaAssocData }+      = (X_TLSA smimeaUsage smimeaSelector smimeaMtype smimeaAssocData :: T_smimea)+{-# COMPLETE T_SMIMEA #-}++-- | Shared wire-format representation for DANE certificate-binding+-- records: the @TLSA@ record+-- ([RFC 6698 section 2.1](https://tools.ietf.org/html/rfc6698#section-2.1),+-- DANE for TLS) and the @SMIMEA@ record+-- ([RFC 8162 section 2](https://tools.ietf.org/html/rfc8162#section-2),+-- DANE for S/MIME).  The type parameter @n@ (either 'N_tlsa' or+-- 'N_smimea') determines the RR type.  Each has its own type synonym+-- ('T_tlsa', 'T_smimea') and matching record pattern synonym+-- ('T_TLSA', 'T_SMIMEA') with the corresponding field-name prefix+-- (@tlsa@, @smimea@).  The role of 'X_tlsa' is /nominal/: the wire+-- format is shared but the two RR types bind to different protocols,+-- so 'T_tlsa' and 'T_smimea' are not coercible.+--+-- >                      1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3+-- >  0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |  Cert. Usage  |   Selector    | Matching Type |               /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+               /+-- > /                                                               /+-- > /                 Certificate Association Data                  /+-- > /                                                               /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- If a received message carries a payload shorter than 3 bytes the+-- record is returned as an opaque RData of the corresponding+-- RRTYPE with the truncated bytes as its value; DANE validators+-- should treat such records as present but "unusable".+--+-- Derived 'Ord' is canonical+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+--+-- See 'T_sshfp' for the SSH host-key fingerprint record and+-- 'T_openpgpkey' for the OpenPGP key record — both also live in+-- this module.+type X_tlsa :: Nat -> Type+type role X_tlsa nominal+data X_tlsa n = X_TLSA+    { _tlsaUsage     :: Word8           -- ^ Certificate Usage+    , _tlsaSelector  :: Word8           -- ^ Selector+    , _tlsaMtype     :: Word8           -- ^ Matching Type+    , _tlsaAssocData :: ShortByteString -- ^ Certificate Association Data+    }+deriving instance (KnownSymbol (XtlsaConName n)) => Eq (X_tlsa n)+deriving instance (KnownSymbol (XtlsaConName n)) => Ord (X_tlsa n)++instance (Nat16 n, KnownSymbol (XtlsaConName n)) => Show (X_tlsa n) where+    showsPrec p X_TLSA{..} = showsP p $+        showString (symbolVal' (proxy# @(XtlsaConName n))) . showChar ' '+        . shows' _tlsaUsage    . showChar ' '+        . shows' _tlsaSelector . showChar ' '+        . shows' _tlsaMtype    . showChar ' '+        . showAd _tlsaAssocData+      where+        showAd = shows @Bytes16 . coerce++instance (KnownSymbol (XtlsaConName n)) => Presentable (X_tlsa n) where+    present X_TLSA{..} =+        present     _tlsaUsage+        . presentSp _tlsaSelector+        . presentSp _tlsaMtype+        . presentAd _tlsaAssocData+      where+        presentAd = presentSp @Bytes16 . coerce++instance (Nat16 n, KnownSymbol (XtlsaConName n)) => KnownRData (X_tlsa n) where+    rdType _ = RRTYPE $ natToWord16 n+    {-# INLINE rdType #-}+    rdEncode X_TLSA{..} = putSizedBuilder $+        mbWord8              _tlsaUsage+        <> mbWord8           _tlsaSelector+        <> mbWord8           _tlsaMtype+        <> mbShortByteString _tlsaAssocData+    rdDecode _ _ = const do+        _tlsaUsage     <- get8+        _tlsaSelector  <- get8+        _tlsaMtype     <- get8+        _tlsaAssocData <- getShortByteString+        pure $ RData (X_TLSA{..} :: X_tlsa n)++-- | The @SSHFP@ resource record+-- ([RFC 4255 section 3.1](https://www.rfc-editor.org/rfc/rfc4255.html#section-3.1))+-- — a fingerprint of an SSH host public key.  Three fields: an+-- 8-bit /algorithm/ tag (matches the SSH key algorithm), an 8-bit+-- /fingerprint type/ tag (SHA-1, SHA-256, ...), and the+-- fingerprint bytes.+--+-- >                     1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3+-- > 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++-- > |   algorithm   |    fp type    |                               /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+                               /+-- > /                                                               /+-- > /                          fingerprint                          /+-- > /                                                               /+-- > +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-++--+-- See 'X_tlsa' / 'T_openpgpkey' for the other DANE-style records+-- in this module.+data T_sshfp = T_SSHFP+    { sshfpKeyAlgor :: Word8+    , sshfpHashType :: Word8+    , sshfpKeyValue :: ShortByteString+    } deriving (Eq, Ord)++instance Show T_sshfp where+    showsPrec p T_SSHFP{..} = showsP p $+        showString "T_SSHFP "+        . shows' sshfpKeyAlgor . showChar ' '+        . shows' sshfpHashType . showChar ' '+        . showKv sshfpKeyValue+      where+        showKv = shows @Bytes16 . coerce++instance Presentable T_sshfp where+    present T_SSHFP{..} =+        present     sshfpKeyAlgor+        . presentSp sshfpHashType+        . presentKv sshfpKeyValue+      where+        presentKv = presentSp @Bytes16 . coerce++instance KnownRData T_sshfp where+    rdType _ = SSHFP+    {-# INLINE rdType #-}+    rdEncode T_SSHFP{..} = putSizedBuilder $+        mbWord8              sshfpKeyAlgor+        <> mbWord8           sshfpHashType+        <> mbShortByteString sshfpKeyValue+    rdDecode _ _ = const do+        sshfpKeyAlgor <- get8+        sshfpHashType <- get8+        sshfpKeyValue <- getShortByteString+        return $ RData T_SSHFP{..}++-- | The @OPENPGPKEY@ resource record+-- ([RFC 7929 section 2.2](https://www.rfc-editor.org/rfc/rfc7929.html#section-2.2))+-- — an OpenPGP transferable public key, carried as raw bytes (no+-- ASCII armor, no base64).  Single-field; presented in+-- base64 form.+--+-- See 'X_tlsa' / 'T_sshfp' for the other DANE-style records in+-- this module.+data T_openpgpkey = T_OPENPGPKEY+    { openpgpKey :: ShortByteString+    } deriving (Eq, Ord)++instance Show T_openpgpkey where+    showsPrec p T_OPENPGPKEY{..} = showsP p $+        showString "T_OPENPGPKEY " . shows @Bytes64 (coerce openpgpKey)++instance Presentable T_openpgpkey where+    present T_OPENPGPKEY{..} = present @Bytes64 (coerce openpgpKey)++instance KnownRData T_openpgpkey where+    rdType _ = OPENPGPKEY+    {-# INLINE rdType #-}+    rdEncode T_OPENPGPKEY{..} = putSizedBuilder $+        mbShortByteString openpgpKey+    rdDecode _ _ = RData . T_OPENPGPKEY <.> getShortNByteString
+ src/Net/DNSBase/RData/TXT.hs view
@@ -0,0 +1,156 @@+{-|+Module      : Net.DNSBase.RData.TXT+Description : Text-payload RR types (TXT, HINFO, NULL)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++Three RFC 1035 RR types carrying byte-string payloads.+'T_txt' is the general-purpose record holding one or more+character-strings — used by SPF, DKIM, DMARC, and many ad-hoc+TXT conventions.  'T_hinfo' was defined to describe a host's+hardware and operating system but is rarely used in modern zone+data.  'T_null' is opaque arbitrary bytes; primarily a+historical placeholder, presented using the generic RFC 3597+syntax.+-}+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.RData.TXT+    ( T_txt(..)+    , T_hinfo(..)+    , T_null(..)+    ) where++import qualified Data.ByteString.Short as SB++import Net.DNSBase.Internal.Util++import Net.DNSBase.Bytes+import Net.DNSBase.Decode.State+import Net.DNSBase.Encode.State+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RRTYPE+import Net.DNSBase.Text++-- | The @TXT@ resource record+-- ([RFC 1035 section 3.3.14](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.14))+-- — a non-empty list of byte-strings, each at most 255 bytes long.+-- Most TXT-record conventions (SPF, DKIM, DMARC, ...) concatenate+-- the strings on read, but the wire format preserves the boundaries.+--+-- The constructor does not enforce the per-string 255-byte limit;+-- encoding fails if any individual string exceeds it.  Values+-- decoded from wire form are always within the limit by+-- construction.+--+-- The 'Ord' instance compares the strings as DNS+-- character-strings (length-prefixed lexicographic), agreeing+-- with the canonical wire-form ordering of+-- [RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2).+newtype T_txt = T_TXT (NonEmpty ShortByteString) -- ^ One or more character-strings+    deriving (Eq, Show)++instance Ord T_txt where+    compare = comparing asDnsText+      where+        asDnsText :: T_txt -> NonEmpty DnsText+        asDnsText = coerce++instance Presentable T_txt where+    present (T_TXT (str :| strs)) =+        pfst str+        . flip (foldr pnxt) strs+      where+        pfst = present @DnsText . coerce+        pnxt = presentSp @DnsText . coerce++instance KnownRData T_txt where+    rdType _ = TXT+    {-# INLINE rdType #-}+    rdEncode (T_TXT strs) =+        mapM_ encodeCharString strs+    rdDecode _ _ len = do+        pos0 <- getPosition+        str  <- getShortByteStringLen8+        used <- subtract pos0 <$> getPosition+        rest <- getVarWidthSequence getShortByteStringLen8 (len - used)+        pure $ RData $ T_TXT $ str :| rest++-- | The @HINFO@ resource record+-- ([RFC 1035 section 3.3.2](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.2))+-- — host information: a /CPU/ character-string and an /OS/+-- character-string describing the named host's hardware and+-- operating system.  Rarely used in modern zone data; RFC 8482+-- reuses the type code as a placeholder answer for @ANY@ queries.+--+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                      CPU                      /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                       OS                      /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- The 'Ord' instance compares both fields as DNS+-- character-strings, giving canonical ordering+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+data T_hinfo = T_HINFO+    { hinfoCPU :: ShortByteString+    , hinfoOS  :: ShortByteString+    } deriving (Eq, Show)++instance Ord T_hinfo where+    a `compare` b = hinfoCPU a `strCompare` hinfoCPU b+                 <> hinfoOS  a `strCompare` hinfoOS  b+      where+        strCompare = comparing DnsText++instance Presentable T_hinfo where+    present T_HINFO{..} =+        present     @DnsText (coerce hinfoCPU)+        . presentSp @DnsText (coerce hinfoOS)++instance KnownRData T_hinfo where+    rdType _ = HINFO+    {-# INLINE rdType #-}+    rdEncode T_HINFO{..} = do+        encodeCharString hinfoCPU+        encodeCharString hinfoOS+    rdDecode _ _ = const do+        RData <$.> T_HINFO <$> getShortByteStringLen8 <*> getShortByteStringLen8++-- | The @NULL@ resource record+-- ([RFC 1035 section 3.3.10](https://datatracker.ietf.org/doc/html/rfc1035#section-3.3.10))+-- — arbitrary opaque bytes (up to 65535).  Rarely seen on the+-- wire; presented using the generic+-- [RFC 3597 section 5](https://datatracker.ietf.org/doc/html/rfc3597#section-5)+-- syntax (@\\\# /n/ /hex/@).+--+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- > /                  <anything>                   /+-- > /                                               /+-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- Derived 'Ord' is canonical+-- ([RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2)).+newtype T_null = T_NULL Bytes16+    deriving (Eq, Ord, Show)++instance Presentable T_null where+    present (T_NULL val) =+        present @String "\\# "+        . present (SB.length $ coerce val)+        . presentSp val++instance KnownRData T_null where+    rdType _ = NULL+    {-# INLINE rdType #-}+    rdEncode = putShortByteString . coerce+    rdDecode _ _ = RData . T_NULL . coerce <.> getShortNByteString++--------------++-- | Encode a DNS /character-string/ (explicit one byte length).+encodeCharString :: ShortByteString -> SPut s RData+encodeCharString = putShortByteStringLen8
+ src/Net/DNSBase/RData/WKS.hs view
@@ -0,0 +1,139 @@+{-|+Module      : Net.DNSBase.RData.WKS+Description : Well-Known Services (obsolete)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The @WKS@ resource record predates port-by-port service discovery+conventions and was effectively obsoleted by them.  It is defined+here so wire-form parsers can read stray @WKS@ records in zone+data without failing; new deployments should not produce @WKS@.+-}+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.RData.WKS+    ( T_wks(..)+    , WksProto(.., UDP, TCP)+    ) where++import qualified Data.Set as Set+import qualified Data.Primitive.ByteArray as A+import Data.Set (Set, fromAscList)+import Net.DNSBase.Internal.Util++import Net.DNSBase.Decode.State+import Net.DNSBase.Encode.State+import Net.DNSBase.Present+import Net.DNSBase.RData+import Net.DNSBase.RRTYPE++-- | IP protocol number used in the 'T_wks' header byte.  Bidirectional+-- patterns 'TCP' (6) and 'UDP' (17) cover the two protocols @WKS@+-- was ever realistically used for; any other protocol number+-- presents as its decimal value.+newtype WksProto = WksProto Word8+    deriving newtype (Eq, Ord, Bounded, Enum, Num, Real, Integral, Show, Read)++pattern TCP :: WksProto; pattern TCP = WksProto 6+pattern UDP :: WksProto; pattern UDP = WksProto 17++instance Presentable WksProto where+    present UDP = present @String "UDP"+    present TCP = present @String "TCP"+    present p   = present @Word8 $ fromIntegral p++-- | The @WKS@ resource record+-- ([RFC 1035 section 3.4.2](https://datatracker.ietf.org/doc/html/rfc1035#section-3.4.2)),+-- mapping an 'IPv4' address and a 'WksProto' protocol number to the+-- set of TCP/UDP port numbers (16-bit) on which the named host+-- accepts connections.  Ports are encoded on the wire as a packed+-- bitmap whose length implies the maximum port carried.+--+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- >  |                    ADDRESS                    |+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++-- >  |       PROTOCOL        |                       |+-- >  +--+--+--+--+--+--+--+--+                       |+-- >  |                                               |+-- >  /                   <BIT MAP>                   /+-- >  /                                               /+-- >  +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--++--+-- The 'Ord' instance compares by address, then protocol, then+-- the port set in descending order — matching the byte-wise+-- comparison of the wire-form port bitmap, so it agrees with the+-- canonical RR-content ordering of+-- [RFC 4034 section 6.2](https://datatracker.ietf.org/doc/html/rfc4034#section-6.2).+data T_wks = T_WKS+    { wksAddr4 :: IPv4       -- ^ Host IPv4 address+    , wksProto :: WksProto   -- ^ IP protocol number+    , wksPorts :: Set Word16 -- ^ Set of port numbers+    } deriving (Eq, Show)++instance Ord T_wks where+    a `compare` b = wksAddr4 a `compare` wksAddr4 b+                 <> wksProto a `compare` wksProto b+                 <> portlist a `compare` portlist b+      where+        portlist :: T_wks -> [Down Word16]+        portlist = coerce . Set.toList . wksPorts++instance Presentable T_wks where+    present T_WKS{..} =+        present          wksAddr4+        . presentSp      wksProto+        . presentSpPorts wksPorts+      where+        presentSpPorts (Set.toList -> ports) =+            present @String " ("+            . flip (foldr presentSp) ports+            . present @String " )"++instance KnownRData T_wks where+    rdType _ = WKS+    {-# INLINE rdType #-}+    rdEncode T_WKS{..} = do+        putIPv4 wksAddr4+        put8 $ coerce wksProto+        putPortBitmap wksPorts+    rdDecode _ _ len = do+        wksAddr4 <- getIPv4+        wksProto <- WksProto <$> get8+        wksPorts <- getPortBitmap (len - 5)+        pure $ RData T_WKS{..}++getPortBitmap :: Int -> SGet (Set Word16)+getPortBitmap len+    | len > 0x2000 = failSGet "WKS bitmap too long"+    | otherwise    = fromAscList . go 0 <$> getNBytes len+  where+    go :: Word16 -> [Word8] -> [Word16]+    go !off (w : ws)+        | z <- countLeadingZeros w+        , z < 8+        , port <- off .|. fromIntegral z+          = port : go off (w `clearBit` (7-z) : ws)+        | otherwise = go (off + 8) ws+    go _ _ = []++putPortBitmap :: Set Word16 -> SPut s RData+putPortBitmap s+    | Set.null s = pure ()+    | otherwise  = putShortByteString sbs+  where+    top = fromIntegral $ Set.findMax s `shiftR` 3+    sbs = baToShortByteString bitmap+      where+        bitmap :: ByteArray+        bitmap = A.runByteArray do+            a <- A.newByteArray $ top + 1+            A.fillByteArray a 0 (top + 1) 0+            sequence_+                [ modifyArray a byte (`setBit` bitpos)+                | t <- Set.toList s+                , let it = fromIntegral t+                , let byte = (it `shiftR` 3)+                , let bitpos = 7 - (it .&. 0x7) ]+            pure a
+ src/Net/DNSBase/RData/XNAME.hs view
@@ -0,0 +1,32 @@+{-|+Module      : Net.DNSBase.RData.XNAME+Description : Domain-name-valued RR types (NS, CNAME, PTR, DNAME)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The classical RR types from RFC 1035 whose RDATA is a single+domain name: 'T_ns' (delegation), 'T_cname' (canonical-name+alias), and 'T_ptr' (reverse-mapping pointer).  All three share+the 'X_domain' newtype underneath, but the types are nominally+distinct so a CNAME value can't be used where a PTR is expected+(and vice versa).++'T_dname' (RFC 6672) is exported alongside because it has the+same shape — a single 'Net.DNSBase.Domain.Domain' — though it does not share the+codec: @DNAME@'s target is not subject to wire-form name+compression on encode.++The obsolete mailbox-pointer types @MB@, @MD@, @MF@, @MG@,+@MR@ are also 'X_domain' instances but live in+"Net.DNSBase.RData.Obsolete".+-}++module Net.DNSBase.RData.XNAME+    ( -- * RR types representing a single domain name+      X_domain(T_NS, T_PTR, T_CNAME)+    , type XdomainConName, T_ns, T_ptr, T_cname, T_dname(..)+    ) where++import Net.DNSBase.RData.Internal.XNAME
+ src/Net/DNSBase/RR.hs view
@@ -0,0 +1,29 @@+{-|+Module      : Net.DNSBase.RR+Description : The DNS resource-record container type+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++An 'RR' value is the standard DNS resource record: an owner name,+a class, a type, a TTL, and an 'Net.DNSBase.RData.RData' payload.+The payload is held inside the existential+'Net.DNSBase.RData.RData' wrapper, so a single 'RR' value can+carry any registered RR type's data.  Use 'rrDataCast' to recover+a specific 'Net.DNSBase.RData.KnownRData' value from the wrapper;+the 'Net.DNSBase.RData.fromRData' / 'Net.DNSBase.RData.monoRData'+/ 'Net.DNSBase.RData.rdataType' helpers re-exported from+"Net.DNSBase.RData" do the same on 'Net.DNSBase.RData.RData'+directly.+-}++module Net.DNSBase.RR+    ( -- * DNS resource record data type+      RR(..)+    , putRR+    , rrDataCast+    , rrType+    ) where++import Net.DNSBase.Internal.RR
+ src/Net/DNSBase/RRCLASS.hs view
@@ -0,0 +1,22 @@+{-|+Module      : Net.DNSBase.RRCLASS+Description : DNS resource record CLASS values (RFC 1035 section 3.2.4)+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 16-bit @CLASS@ field of a DNS resource record.  In modern+practice essentially everything uses 'IN' (Internet); the other+registered values ('CHAOS', 'HESIOD', 'NONE', 'ANYCLASS') are+historic or have specialised uses.  See the+[IANA DNS Classes registry](https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-2)+for the full list.+-}++module Net.DNSBase.RRCLASS+    ( -- * DNS resource class numbers+      RRCLASS(..)+    ) where++import Net.DNSBase.Internal.RRCLASS
+ src/Net/DNSBase/RRSet.hs view
@@ -0,0 +1,69 @@+{-|+Module      : Net.DNSBase.RRSet+Description : Owner/class/type RR sets with associated DNSSEC signatures+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++An 'RRSet' groups a flat list of 'RR' values into the standard+DNS unit: records sharing the same (owner, class, type),+together with any 'RRSIG' records covering them.  The+'rrSetsFromList' function partitions a flat list — typically+the answer or authority section of a 'Net.DNSBase.Message.DNSMessage' — into the+corresponding RRSets, attaching each RRSIG to the set it+covers based on the type-covered field.+-}+{-# LANGUAGE RecordWildCards #-}+module Net.DNSBase.RRSet+    ( RRSet(..)+    , rrSetsFromList+    )+    where+import qualified Data.List as L+import qualified Data.List.NonEmpty as NE++import Net.DNSBase.Internal.Domain+import Net.DNSBase.Internal.RR+import Net.DNSBase.Internal.RRTYPE+import Net.DNSBase.Internal.RRCLASS+import Net.DNSBase.Internal.Util+import Net.DNSBase.RData.Dnssec++data RRSet = RRSet+    { rrSetOwner :: Domain+    , rrSetClass :: RRCLASS+    , rrSetType  :: RRTYPE+    , rrSetRecs  :: [RR]+    , rrSetSigs  :: [RR]+    }++rrSetsFromList :: [RR] -> [RRSet]+rrSetsFromList rrs = rrs+    & map decorate+    & L.sortBy (comparing drrKey)+    & NE.groupWith drrKey+    & makeSets+  where+    decorate :: RR -> (RR, RRTYPE, Domain)+    decorate rr =+        let !styp = maybe (rrType rr) rrsigType (rrDataCast rr)+            !host = canonicalise (rrOwner rr)+         in (rr, styp, host)++    drrKey :: (RR, RRTYPE, Domain) -> (RRTYPE, RRCLASS, Domain)+    drrKey (rr, typ, host) = (typ, rrClass rr, host)++    makeSets :: [NonEmpty (RR, RRTYPE, Domain)] -> [RRSet]+    makeSets [] = []+    makeSets (((rr@(rrClass -> rrSetClass), rrSetType, rrSetOwner) :| rest) : grps)+        | !owner <- rrOwner rr+        , (rrSetRecs, rrSetSigs) <- L.partition ((== rrSetType) . rrType)+            $ rr : rrsOfWithOwner owner rest+        , not (null rrSetRecs) = RRSet {..} : makeSets grps+        | otherwise = makeSets grps++    rrsOfWithOwner owner = foldr go []+      where+        go (setOwner -> !h) !t = h : t+        setOwner (r, _, _) = r {rrOwner = owner}
+ src/Net/DNSBase/RRTYPE.hs view
@@ -0,0 +1,112 @@+{-|+Module      : Net.DNSBase.RRTYPE+Description : DNS resource record TYPE values and matching type-level Naturals+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The 16-bit @TYPE@ field of a DNS resource record, along with+the type-level @Nat@ synonyms ('N_a', 'N_ns', 'N_aaaa', ...)+that index the shared-codec and opaque datatypes+('Net.DNSBase.RData.XNAME.X_domain',+'Net.DNSBase.RData.SVCB.X_svcb',+'Net.DNSBase.RData.Dnssec.X_ds',+'Net.DNSBase.RData.Dnssec.X_key',+'Net.DNSBase.RData.Dnssec.X_sig')+and select among the RR types that share a single underlying+representation.  See the+[IANA Resource Record (RR) TYPEs registry](https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml#dns-parameters-4)+for the full list of codepoints.+-}++module Net.DNSBase.RRTYPE+    ( -- * DNS Resource Record type numbers+      RRTYPE(..)+      -- ** Corresponding type-level Naturals+    , type N_a+    , type N_ns+    , type N_md+    , type N_mf+    , type N_cname+    , type N_soa+    , type N_mb+    , type N_mg+    , type N_mr+    , type N_null+    , type N_wks+    , type N_ptr+    , type N_hinfo+    , type N_minfo+    , type N_mx+    , type N_txt+    , type N_rp+    , type N_afsdb+    , type N_x25+    , type N_isdn+    , type N_rt+    , type N_nsap+    , type N_nsapptr+    , type N_sig+    , type N_key+    , type N_px+    , type N_gpos+    , type N_aaaa+    , type N_loc+    , type N_nxt+    , type N_eid+    , type N_nimloc+    , type N_srv+    , type N_atma+    , type N_naptr+    , type N_kx+    , type N_cert+    , type N_a6+    , type N_dname+    , type N_sink+    , type N_opt+    , type N_apl+    , type N_ds+    , type N_sshfp+    , type N_ipseckey+    , type N_rrsig+    , type N_nsec+    , type N_dnskey+    , type N_dhcid+    , type N_nsec3+    , type N_nsec3param+    , type N_tlsa+    , type N_smimea+    , type N_hip+    , type N_ninfo+    , type N_rkey+    , type N_talink+    , type N_cds+    , type N_cdnskey+    , type N_openpgpkey+    , type N_csync+    , type N_zonemd+    , type N_svcb+    , type N_https+    , type N_dsync+    , type N_hhit+    , type N_brid+    , type N_nid+    , type N_l32+    , type N_l64+    , type N_lp+    , type N_nxname+    , type N_ixfr+    , type N_axfr+    , type N_mailb+    , type N_maila+    , type N_any+    , type N_caa+    , type N_amtrelay+    , type N_resinfo+    , type N_wallet+    , type N_cla+    , type N_ipn+    ) where++import Net.DNSBase.Internal.RRTYPE
+ src/Net/DNSBase/Resolver.hs view
@@ -0,0 +1,644 @@+{-|+Module      : Net.DNSBase.Resolver+Description : Stub resolver configuration and per-thread handles+Copyright   : (c) IIJ Innovation Institute Inc., 2009+              (c) Viktor Dukhovni, 2020-2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++The resolver is built in three stages:++1. 'ResolverConf' carries the caller's choices: nameserver+   source, per-attempt timeout, retry budget, default+   'QueryControls', and any user-registered RR-type or EDNS+   option codecs.  Build one by adjusting fields of+   'defaultResolvConf'.++2. 'makeResolvSeed' turns a 'ResolverConf' into a 'ResolvSeed':+   nameserver hostnames are resolved to addresses, and the+   user's codec registrations are merged with the library's+   built-in defaults.  The seed is immutable and safe to share+   across threads.++3. 'withResolver' produces a per-thread 'Resolver' handle from+   a shared seed.  A 'Resolver' carries thread-local mutable+   state (a CSPRNG for query IDs) and /must not/ be shared+   between threads — programs that issue queries concurrently+   should call 'withResolver' once per worker thread.++A minimal example:++> main :: IO ()+> main = do+>     seed <- makeResolvSeed defaultResolvConf >>= either throwIO pure+>     withResolver seed \ r ->+>         lookupA r $$(dnLit8 "example.com") >>= \ case+>             Left  e -> throwIO e+>             Right a -> print a++The codec set baked into the seed can be extended at+conf-build time via 'registerRRtype' / 'registerEdnsOption'+(new RR-type or EDNS-option codecs) and the four+'extendRRwithType' / 'extendRRwithValue' /+'extendEdnsOptionWithType' / 'extendEdnsOptionWithValue'+combinators (extensions onto codecs that admit them).  See+"Net.DNSBase.Extensible" for worked examples.+-}+{-# LANGUAGE RecordWildCards #-}++module Net.DNSBase.Resolver+  ( -- * Resolver configuration+    ResolverConf+  , defaultResolvConf+  , setResolverConfTimeout+  , setResolverConfRetries+  , setResolverConfQueryControls+  , setResolverConfSource+  , NameserverConf(..)+  , NameserverSpec(..)+  -- * Resolver seed+  , ResolvSeed+  , makeResolvSeed+  -- * Resolver instance+  , Resolver(resolvSeed, resolvRng)+  , withResolver+  -- * Look up 'RRTYPE' by name.+  , RRtypeNames+  , confTypeNames+  , rrtypeLookup+  -- * Controls.+  -- ** Query controls.+  , QueryControls(..)+  , EdnsControls+  -- ** Extending the codec set.+  --+  -- $extending+  , TypeExtensible(..)+  , KnownRData(..)+  , registerRRtype+  , extendRRwithType+  , extendRRwithValue+  , KnownEdnsOption(..)+  , registerEdnsOption+  , extendEdnsOptionWithType+  , extendEdnsOptionWithValue+  -- * Chained-composition opt-in+  --+  -- $dnsio+  , DNSIO+  , runDNSIO+  , liftDNS+  ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder.Extra as B+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Short as SB+import qualified Data.IntMap.Strict as IM+import qualified Data.Map.Strict as M+import qualified Data.Type.Equality as R+import qualified Type.Reflection as R+import Data.Char (chr)+import Data.String (fromString)+import Data.Void (Void)+import Network.Socket ( AddrInfo(..), AddrInfoFlag(..), HostName, PortNumber )+import Network.Socket ( ServiceName, SocketType(Datagram) )+import Network.Socket ( defaultHints, getAddrInfo )+import Numeric (readDec)+import Numeric.Natural (Natural)+import GHC.IO.Exception (IOErrorType(..))+import System.IO.Error (ioeSetErrorString, mkIOError, tryIOError)++import Net.DNSBase.Decode.Internal.Option+import Net.DNSBase.Decode.Internal.State+import Net.DNSBase.EDNS.Internal.Option+import Net.DNSBase.EDNS.Internal.OptNum+import Net.DNSBase.Encode.Internal.State+import Net.DNSBase.Internal.Error+import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.RData+import Net.DNSBase.Internal.RRTYPE+import Net.DNSBase.Internal.Util+import Net.DNSBase.Nat16+import Net.DNSBase.Resolver.Internal.Parser+import Net.DNSBase.Resolver.Internal.Types++import Net.DNSBase.EDNS.Option.ECS+import Net.DNSBase.EDNS.Option.EDE+import Net.DNSBase.EDNS.Option.NSID+import Net.DNSBase.EDNS.Option.Secalgs+import Net.DNSBase.Extensible (TypeExtensible(..), ValueExtensible(..))++-- Built-in RData type modules+import Net.DNSBase.RData.A+import Net.DNSBase.RData.CAA+import Net.DNSBase.RData.CSYNC+import Net.DNSBase.RData.Dnssec+-- Re-exported by Dnssec+-- import Net.DNSBase.RData.NSEC+import Net.DNSBase.RData.Obsolete+import Net.DNSBase.RData.SOA+import Net.DNSBase.RData.SRV+import Net.DNSBase.RData.SVCB+import Net.DNSBase.RData.TLSA+import Net.DNSBase.RData.TXT+-- Re-exported by Obsolete+-- import Net.DNSBase.RData.WKS+import Net.DNSBase.RData.XNAME++----++-- $dnsio+-- The primary API (e.g. 'makeResolvSeed', 'Net.DNSBase.Lookup.lookupAnswers') returns+-- @'IO' ('Either' 'DNSError' a)@: each call's error half is explicit+-- at the type level and the user's surrounding code stays in plain+-- 'IO'.  For programs that prefer transformer-style composition of+-- many DNS calls with short-circuit error handling, 'DNSIO' is a thin+-- alias for @'ExceptT' 'DNSError' 'IO'@; 'runDNSIO' and 'liftDNS'+-- convert between the two forms.++-- Set Resolver timeout+setResolverConfTimeout :: Int -> ResolverConf -> ResolverConf+setResolverConfTimeout t rc = rc {rcTimeout = t}++-- Set Resolver retries+setResolverConfRetries :: Int -> ResolverConf -> ResolverConf+setResolverConfRetries n rc = rc {rcRetries = n}++-- Set Resolver configuration source+setResolverConfSource :: NameserverConf -> ResolverConf -> ResolverConf+setResolverConfSource s rc = rc {rcSource = s}++-- Set Resolver query controls+setResolverConfQueryControls :: QueryControls -> ResolverConf -> ResolverConf+setResolverConfQueryControls q rc = rc {rcQryCtls = q}++-- $extending+-- The resolver knows about a set of RR-type and EDNS-option+-- codecs at conf-build time.  'registerRRtype' and+-- 'registerEdnsOption' install a fresh codec entry at the+-- type's default extension value; the four+-- 'extendRRwithType' / 'extendRRwithValue' /+-- 'extendEdnsOptionWithType' / 'extendEdnsOptionWithValue'+-- combinators fold typed or value-driven extensions onto an+-- already-extensible codec's existing entry.  See+-- "Net.DNSBase.Extensible" for worked examples and the design+-- behind the two extension flavours.+--+-- User registrations take precedence over the library's+-- built-in codec set, except at a small number of /protected/+-- code points (e.g. the SVCB @mandatory@ key), where attempted+-- user additions are silently ignored.++-- | Register a decoder for an RR-type.+-- If the RR's data type is itself extensible, you can+-- use 'extendRRwithType' or 'extendRRwithValue' to+-- apply additional extensions on top.+--+-- The registration takes precedence over the library's built-in+-- codec at the same RR-type code, except at protected code+-- points (e.g. RR-type 0 and 65535, or the OPT pseudo-RR), where+-- the registration is silently ignored.+registerRRtype :: forall a -> KnownRData a+               => ResolverConf -> ResolverConf+registerRRtype a rc =+    rc { rcRDataMap = IM.insert key entry (rcRDataMap rc) }+  where+    key   = fromIntegral @Word16 . coerce $ rdType a+    entry = RDataCodec (Proxy @a) (rdataExtensionVal a)++-- | Extend the registered codec of a type-extensible RR type @t@+-- with an additional typed extension @b@.  If @t@ is not yet+-- known it is automatically registered, in either case 'extendByType'+-- is then applied to the existing decoder state to fold in @b@.+--+-- This is how one adds an extra SvcParam-key decoder for SVCB+-- and/or HTTPS records.+--+-- > conf+-- >     & extendRRwithType T_svcb  MyParamType+-- >     & extendRRwithType T_https MyParamType+--+extendRRwithType :: forall t ->+                    ( KnownRData t+                    , TypeExtensible t (RDataExtensionVal t)+                    )+                 => forall b -> TypeExtensionArg t b+                 => ResolverConf -> ResolverConf+extendRRwithType t b rc =+    rc { rcRDataMap = IM.insert key entry (rcRDataMap rc) }+  where+    key      = fromIntegral @Word16 . coerce $ rdType t+    baseline = case IM.lookup key (rcRDataMap rc) of+        Just (RDataCodec (_ :: Proxy a) opts)+            | Just R.Refl <- R.testEquality (R.typeRep @t) (R.typeRep @a)+            -> opts+        _   -> rdataExtensionVal t+    entry    = RDataCodec (Proxy @t) (extendByType t b baseline)++-- | Register an EDNS option decoder.+-- If the EDNS option\'s data type is itself extensible, you can+-- use 'extendEdnsOptionWithType' or 'extendEdnsOptionWithValue' to+-- apply additional extensions on top.+--+-- The registration takes precedence over the library's built-in+-- decoder at the same option code (if any) after the merge step+-- in 'makeResolvSeed'.+registerEdnsOption :: forall a -> KnownEdnsOption a+                   => ResolverConf -> ResolverConf+registerEdnsOption a rc =+    rc { rcOptionMap = IM.insert key entry (rcOptionMap rc) }+  where+    key   = fromIntegral @Word16 . coerce $ optNum a+    entry = OptionCodec (Proxy @a) (optionExtensionVal a)++-- | Extend the registered decoder for a type-extensible EDNS option+-- type @t@ with an additional typed extension @b@.  If @t@ is not+-- yet present in the resolver configuration, it is first registered,+-- in either case 'extendByType' is then applied fold in @b@.+--+-- This is the EDNS-option-side parallel to 'extendRRwithType'.+extendEdnsOptionWithType :: forall t ->+                            ( KnownEdnsOption t+                            , TypeExtensible t (OptionExtensionVal t)+                            )+                         => forall b -> TypeExtensionArg t b+                         => ResolverConf -> ResolverConf+extendEdnsOptionWithType t b rc =+    rc { rcOptionMap = IM.insert key entry (rcOptionMap rc) }+  where+    key      = fromIntegral @Word16 . coerce $ optNum t+    baseline = case IM.lookup key (rcOptionMap rc) of+        Just (OptionCodec (_ :: Proxy a) opts)+            | Just R.Refl <- R.testEquality (R.typeRep @t) (R.typeRep @a)+            -> opts+        _   -> optionExtensionVal t+    entry    = OptionCodec (Proxy @t) (extendByType t b baseline)++-- | Extend the registered codec for RR type @t@ with a+-- caller-supplied value @v@, whose type satisfies @t@'s+-- 'ValueExtensionArg' constraint.  Parallel to+-- 'extendRRwithType', but for instances whose extension table+-- is keyed by runtime data rather than user-supplied types.+extendRRwithValue :: forall t ->+                     ( KnownRData t+                     , ValueExtensible t (RDataExtensionVal t)+                     )+                  => forall b. ValueExtensionArg t b+                  => b -> ResolverConf -> ResolverConf+extendRRwithValue t v rc =+    rc { rcRDataMap = IM.insert key entry (rcRDataMap rc) }+  where+    key      = fromIntegral @Word16 . coerce $ rdType t+    baseline = case IM.lookup key (rcRDataMap rc) of+        Just (RDataCodec (_ :: Proxy a) opts)+            | Just R.Refl <- R.testEquality (R.typeRep @t) (R.typeRep @a)+            -> opts+        _   -> rdataExtensionVal t+    entry    = RDataCodec (Proxy @t) (extendByValue t v baseline)++-- | Extend the registered codec for EDNS option type @t@ with+-- a caller-supplied value @v@, whose type satisfies @t@'s+-- 'ValueExtensionArg' constraint.  The EDNS-option-side+-- parallel to 'extendRRwithValue'.  This is the canonical way+-- to add an EDE info-code → friendly-name mapping:+--+-- > conf+-- >     & extendEdnsOptionWithValue O_ede (33, "Frobnicated")+-- >     & extendEdnsOptionWithValue O_ede (34, "Bogosity")+extendEdnsOptionWithValue :: forall t ->+                             ( KnownEdnsOption t+                             , ValueExtensible t (OptionExtensionVal t)+                             )+                          => forall b. ValueExtensionArg t b+                          => b -> ResolverConf -> ResolverConf+extendEdnsOptionWithValue t v rc =+    rc { rcOptionMap = IM.insert key entry (rcOptionMap rc) }+  where+    key      = fromIntegral @Word16 . coerce $ optNum t+    baseline = case IM.lookup key (rcOptionMap rc) of+        Just (OptionCodec (_ :: Proxy a) opts)+            | Just R.Refl <- R.testEquality (R.typeRep @t) (R.typeRep @a)+            -> opts+        _   -> optionExtensionVal t+    entry    = OptionCodec (Proxy @t) (extendByValue t v baseline)+++-- | Build a 'ResolvSeed' from a 'ResolverConf'.  The seed is+-- immutable and safely shared across threads; each thread then+-- calls 'withResolver' to obtain its own 'Resolver'.+--+-- The configured nameservers are resolved to socket addresses,+-- and the user's codec registrations (from 'registerRRtype',+-- 'extendRRwithType' and 'registerEdnsOption') are combined with the+-- library's built-in codec set.  At each RR-type or EDNS option+-- code point, the user-registered codec takes precedence over the+-- library default — except at a small set of /protected/ code+-- points (e.g. the SVCB @mandatory@ key), where any attempted+-- user override is silently ignored.+--+-- Returns @'Left' err@ if the configured nameservers cannot be+-- resolved or the configuration file cannot be parsed.+--+-- Example:+--+-- >>> seed <- makeResolvSeed defaultResolvConf >>= either throwIO pure+--+makeResolvSeed :: ResolverConf -> IO (Either DNSError ResolvSeed)+makeResolvSeed conf = runDNSIO do+    seedServers <- findAddresses+    let !seedRDataMap  = reservedCodecs+                        `IM.union` (rcRDataMap conf `IM.union` defaultCodecs)+        !seedOptionMap = rcOptionMap conf `IM.union` baseOptions+        seedConfig     = conf+    pure ResolvSeed{..}+  where+    findAddresses :: DNSIO (NonEmpty Nameserver)+    findAddresses = case rcSource conf of+        HostList rs     -> join <$> mapM getNameserverAddresses rs+        SourceFile file -> getDefaultNameservers file >>= mkAddrs++    getNameserverAddresses (NameserverSpec h mp) = makeAddrInfo (Just h) mp++    -- When /etc/resolv.conf contains no addresses, default to the loopback address,+    -- by passing 'Nothing' for the server name.+    mkAddrs []     = makeAddrInfo Nothing Nothing+    mkAddrs (l:ls) = join <$> mapM getNameserverAddresses (l :| ls)+++-- | Default resolver configuration, with nameserver list from+-- @\/etc\/resolv.conf@ and no user-registered codec extensions.+defaultResolvConf :: ResolverConf+defaultResolvConf = ResolverConf+    { rcSource    = SourceFile "/etc/resolv.conf"+    , rcTimeout   = 3_000_000  -- 3 seconds+    , rcRetries   = 3+    , rcQryCtls   = mempty+    , rcRDataMap  = IM.empty+    , rcOptionMap = IM.empty+    }++-- | Determines whether a HostName is a valid IPv4 or IPv6 address+--+-- Also false if input is an IPv4 or IPv6 address with trailing characters,+-- or in the (impossible) case of multiple valid parses+isAddr :: HostName -> Bool+isAddr addr =+    case reads @IP addr of+        [(_,r)] -> null r+        _       -> False++makeAddrInfo :: Maybe HostName -> Maybe PortNumber -> DNSIO (NonEmpty Nameserver)+makeAddrInfo maddr mport = do+    let flags | addrLiteral = AI_NUMERICHOST : defaultFlags+              | otherwise   = defaultFlags+        hints = defaultHints {addrFlags = flags, addrSocketType = Datagram}+        serv = maybe "53" show mport++    -- getAddrInfo should never return an empty list (it raises an IO exception instead),+    -- but just in case, handle empty results.+    withExceptT BadNameserver (getAddrInfo' hints maddr serv) >>= \ case+        a : as -> pure $ Nameserver addrName <$> a :| as+        _      -> let host = fromMaybe defaultHostName maddr+                      ioe = mkIOError NoSuchThing host Nothing Nothing+                   in throwE $ BadNameserver $ ioeSetErrorString ioe "Host unknown"+  where+    defaultFlags = [AI_NUMERICSERV, AI_ADDRCONFIG]+    defaultHostName = "localhost"+    addrLiteral = maybe False isAddr maddr+    addrName | addrLiteral = Nothing+             | otherwise   = maddr <|> Just defaultHostName++getAddrInfo' :: AddrInfo -> Maybe HostName -> ServiceName -> ExceptT IOError IO [AddrInfo]+getAddrInfo' h a s = ExceptT $ tryIOError (getAddrInfo (Just h) a (Just s))++---------- RRTYPE lookups++-- | Mapping from @RRTYPE@ name to 'RRTYPE' code.+newtype RRtypeNames = RRNames_ (M.Map SB.ShortByteString RRTYPE)++-- | Attempt to find an RRTYPE' by name.  The lookup map can be constructed+-- via 'confTypeNames', and should be reused for multiple lookups when+-- possible.+--+-- - The input name is not case-senstive.+-- - Names of the form @TYPE@/num/ (with /num/ the type number) are supported,+--   and return the corresponding 'RRTYPE'.+rrtypeLookup :: B.ByteString+             -> RRtypeNames+             -> Maybe RRTYPE+rrtypeLookup ((,) <$> B.length <*> B.unpack -> (len, ws)) (coerce -> m)+    | t@(Just _) <- M.lookup name m+    = t+    | SB.isPrefixOf rrtypePrefix name+    , digits <- map (chr . fromIntegral) $ drop (SB.length rrtypePrefix) ws+    , [(w, "")] <- readDec @Natural digits+    , w <= fromIntegral @Word16 @Natural maxBound+    = Just $! RRTYPE $ fromIntegral w+    | otherwise+    = Nothing+  where+    name = foldShort len ws++-- | Construct a map of type names to 'RRTYPE' from a given+-- 'ResolvSeed' value.  This will include both the names of all+-- the registered known types and the names of all known RRtypes,+-- whether implemented or not.+--+-- The map is is not cached, compute it once and reuse for+-- repeated queries.+--+confTypeNames :: Maybe ResolvSeed -> RRtypeNames+confTypeNames cnf =+    coerce $ maybe M.empty cnfMap cnf <> M.fromList knownNames+  where+    cnfMap ResolvSeed {seedRDataMap = dm} =+        M.fromList $ map (uncurry mkPair) $ IM.toList dm+      where+        mkPair k (RDataCodec p _) =+            (proxyName p, RRTYPE $ fromIntegral k)+        proxyName :: forall a. KnownRData a+                  => Proxy a -> SB.ShortByteString+        proxyName _ = buildShort $ rdTypePres a mempty++    knownNames = [ (name, t)+                 | t <- [A .. rrtypeMax]+                 , let name = buildShort $ present t mempty+                 , not $ SB.isPrefixOf rrtypePrefix name ]++    buildShort = (foldShort <$> LB.length <*> LB.unpack) . buildLazy+    buildLazy = B.toLazyByteStringWith (B.untrimmedStrategy 16 32) mempty++foldShort :: Integral a => a -> [Word8] -> SB.ShortByteString+foldShort len = fst <$> SB.unfoldrN (fromIntegral len) low8+  where+    low8 [] = Nothing+    low8 (w:ws) | w - 0x41 < 26 = Just (w + 0x20, ws)+                | otherwise     = Just (w, ws)++rrtypePrefix :: SB.ShortByteString+rrtypePrefix = fromString "type"++-------------------------------+--- RData and Option codec maps++-- | Placeholder for reserved RRTYPEs.+type Reserved :: Nat -> Type+data Reserved n = Reserved_ Void deriving (Eq, Ord, Show)+instance (Nat16 n) => KnownRData (Reserved n) where+    rdType _ = RRTYPE $ natToWord16 n+    rdTypePres _ = present @String "Reserved" . present (natToWord16 n)+    rdEncode _   = failWith $ ReservedType $ RRTYPE $ natToWord16 n+    rdDecode _ _ = const do+        failSGet $ "Reserved RDATA type: " ++ show (natToWord16 n)+instance (Nat16 n) => Presentable (Reserved n) where+    present _ = undefined++-- Internal helper: build the 'RDataMap' entry for type @a@ from+-- its 'Net.DNSBase.RData.rdataExtensionVal'.+rdataMapEntry :: forall a -> KnownRData a => (Int, RDataCodec)+rdataMapEntry a =+    ( fromIntegral @Word16 . coerce $ rdType a+    , RDataCodec (Proxy @a) (rdataExtensionVal a)+    )++-- | Reserved RR-type slots: codes that the protocol forbids as+-- RDATA (RFC 6895 reserved code 0 and sentinel 65535), that the+-- library handles outside the RDATA codec map (OPT, code 41), or+-- that are meta-query types with no carriable RDATA (NXNAME,+-- TKEY, TSIG, IXFR, AXFR, MAILB, MAILA, ANY).+--+-- The merge step in 'Net.DNSBase.Resolver.makeResolvSeed' protects these entries from+-- user override: any user-supplied registration at one of these+-- codes is dropped in favour of the reserved entry.+reservedCodecs :: RDataMap+reservedCodecs = IM.fromList+    [ rdataMapEntry (Reserved 0)         -- 0 RFC6895+    , rdataMapEntry (Reserved 41)        -- 41 OPT (hardwired)+      ---- Special-use types+    , rdataMapEntry (Reserved 128)       -- NXNAME+    , rdataMapEntry (Reserved 249)       -- TKEY+    , rdataMapEntry (Reserved 250)       -- TSIG+    , rdataMapEntry (Reserved 251)       -- IXFR+    , rdataMapEntry (Reserved 252)       -- AXFR+      ---- Query-only types+    , rdataMapEntry (Reserved 253)       -- MAILB+    , rdataMapEntry (Reserved 254)       -- MAILA+    , rdataMapEntry (Reserved 255)       -- ANY+      ----+    , rdataMapEntry (Reserved 65535)     -- Reserved+    ]++-- | Built-in default codecs for the RR-types the library decodes+-- natively.  Disjoint from 'reservedCodecs'.+--+-- These act as fallbacks: a user-supplied registration for any+-- of these RR-types takes precedence over the built-in entry.+-- The merge step in 'Net.DNSBase.Resolver.makeResolvSeed' resolves overlaps in the+-- user's favour, so a caller can replace a built-in decoder with+-- their own without forking the library.+defaultCodecs :: RDataMap+defaultCodecs = IM.fromList+    [ rdataMapEntry T_a                  -- 1+    , rdataMapEntry T_ns                 -- 2+    , rdataMapEntry T_md                 -- 3+    , rdataMapEntry T_mf                 -- 4+    , rdataMapEntry T_cname              -- 5+    , rdataMapEntry T_soa                -- 6+    , rdataMapEntry T_mb                 -- 7+    , rdataMapEntry T_mg                 -- 8+    , rdataMapEntry T_mr                 -- 9+    , rdataMapEntry T_null               -- 10+    , rdataMapEntry T_wks                -- 11+    , rdataMapEntry T_ptr                -- 12+    , rdataMapEntry T_hinfo              -- 13+    , rdataMapEntry T_minfo              -- 14+    , rdataMapEntry T_mx                 -- 15+    , rdataMapEntry T_txt                -- 16+    , rdataMapEntry T_rp                 -- 17+    , rdataMapEntry T_afsdb              -- 18+    , rdataMapEntry T_x25                -- 19+    , rdataMapEntry T_isdn               -- 20+    , rdataMapEntry T_rt                 -- 21+    , rdataMapEntry T_nsap               -- 22+    , rdataMapEntry T_nsapptr            -- 23+    , rdataMapEntry T_sig                -- 24+    , rdataMapEntry T_key                -- 25+    , rdataMapEntry T_px                 -- 26+    , rdataMapEntry T_gpos               -- 27+    , rdataMapEntry T_aaaa               -- 28+                                         -- 29 LOC+    , rdataMapEntry T_nxt                -- 30+                                         -- 31 EID+                                         -- 32 NIMLOC+    , rdataMapEntry T_srv                -- 33+                                         -- 34 ATMA+    , rdataMapEntry T_naptr              -- 35+    , rdataMapEntry T_kx                 -- 36+                                         -- 37 CERT+    , rdataMapEntry T_a6                 -- 38+    , rdataMapEntry T_dname              -- 39+                                         -- 40 SINK+                                         -- 42 APL+    , rdataMapEntry T_ds                 -- 43+    , rdataMapEntry T_sshfp              -- 44+    , rdataMapEntry T_ipseckey           -- 45 IPSECKEY+    , rdataMapEntry T_rrsig              -- 46+    , rdataMapEntry T_nsec               -- 47+    , rdataMapEntry T_dnskey             -- 48+                                         -- 49 DHCID+    , rdataMapEntry T_nsec3              -- 50+    , rdataMapEntry T_nsec3param         -- 51+    , rdataMapEntry T_tlsa               -- 52+    , rdataMapEntry T_smimea             -- 53+                                         -- 54 Unassigned+                                         -- 55 HIP+                                         -- 56 NINFO+                                         -- 57 RKEY+                                         -- 58 TALINK+    , rdataMapEntry T_cds                -- 59+    , rdataMapEntry T_cdnskey            -- 60+    , rdataMapEntry T_openpgpkey         -- 61+    , rdataMapEntry T_csync              -- 62 CSYNC+    , rdataMapEntry T_zonemd             -- 63+    , rdataMapEntry T_svcb               -- 64+    , rdataMapEntry T_https              -- 65+    , rdataMapEntry T_dsync              -- 66+                                         -- 67 HHIT+                                         -- 68 BRID+                                         -- 99 SPF+    , rdataMapEntry T_nid                -- 104 NID+    , rdataMapEntry T_l32                -- 105 L32+    , rdataMapEntry T_l64                -- 106 L64+    , rdataMapEntry T_lp                 -- 107 LP+                                         -- 108 EUI48 [RFC7043]+                                         -- 109 EUI64 [RFC7043]+    , rdataMapEntry T_caa                -- 257+    , rdataMapEntry T_amtrelay           -- 260+                                         -- 261 RESINFO+                                         -- 262 WALLET+                                         -- 263 CLA+                                         -- 264 IPN+    ]++-- | Built-in EDNS option codecs.  User registrations from+-- 'Net.DNSBase.Resolver.registerEdnsOption' /+-- 'Net.DNSBase.Resolver.extendEdnsOptionWithType' take+-- precedence over entries here after the merge step in+-- 'Net.DNSBase.Resolver.makeResolvSeed'.+baseOptions :: OptionMap+baseOptions = IM.fromList+    [ optMapEntry O_nsid                                 -- 3 NSID+    , optMapEntry O_dau                                  -- 5 DAU+    , optMapEntry O_dhu                                  -- 6 DHU+    , optMapEntry O_n3u                                  -- 7 N3U+    , optMapEntry O_ecs                                  -- 8 ECS+    , optMapEntry O_ede                                  -- 15 EDE+    ]+  where+    optMapEntry :: forall a -> KnownEdnsOption a => (Int, OptionCodec)+    optMapEntry a =+        ( fromIntegral @Word16 . coerce $ optNum a+        , OptionCodec (Proxy @a) (optionExtensionVal a)+        )
+ src/Net/DNSBase/Secalgs.hs view
@@ -0,0 +1,273 @@+{-|+Module      : Net.DNSBase.Secalgs+Description : DNSSEC, DANE, and SSHFP algorithm codepoints+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++Small newtype wrappers for the 8-bit algorithm / hash / usage+codepoints scattered across DNSSEC and DNS-based security RR+types: 'DNSKEYAlg' (DNSKEY/RRSIG signature algorithms),+'DSHashAlg' (DS digest algorithms), 'NSEC3HashAlg' (NSEC3+hashes), the three 'DaneUsage' / 'DaneSelector' / 'DaneMtype'+fields of a TLSA record, and 'SshKeyAlgorithm' /+'SshHashType' for SSHFP.  Each carries pattern synonyms for the+registered values; presentations render the names where known+and fall back to the numeric value otherwise.  See the+[IANA DNS Security Algorithm Numbers registry](https://www.iana.org/assignments/dns-sec-alg-numbers/dns-sec-alg-numbers.xhtml)+and the+[DANE TLSA registry](https://www.iana.org/assignments/dane-parameters/dane-parameters.xhtml)+for the full lists.+-}++module Net.DNSBase.Secalgs+    ( DNSKEYAlg+        ( ..+        , KA_RSAMD5+        , KA_DH+        , KA_DSA+        , KA_RSASHA1+        , KA_DSA_NSEC3_SHA1+        , KA_RSASHA1_NSEC3_SHA1+        , KA_RSASHA256+        , KA_RSASHA512+        , KA_ECC_GOST+        , KA_ECDSAP256SHA256+        , KA_ECDSAP384SHA384+        , KA_ED25519+        , KA_ED448+        )+    , DSHashAlg+        ( ..+        , DS_SHA1+        , DS_SHA256+        , DS_GOST94+        , DS_SHA384+        )+    , NSEC3HashAlg+        ( ..+        , N3_SHA1+        )+    -- | [TLSA Certificate Usages](https://tools.ietf.org/html/rfc7218#section-2.1)+    , DaneUsage+        ( ..+        , PKIX_TA+        , PKIX_EE+        , DANE_TA+        , DANE_EE+        , PrivCert+        )+    -- | [TLSA Selectors](https://tools.ietf.org/html/rfc7218#section-2.2)+    , DaneSelector+        ( ..+        , Cert -- ^ Note: as distinct from the @'CERT'@ @RRTYPE@.+        , SPKI+        , PrivSel+        )+    -- | [TLSA Matching Types](https://tools.ietf.org/html/rfc7218#section-2.3)+    , DaneMtype+        ( ..+        , SHA2_256+        , SHA2_512+        , Full+        , PrivMatch+        )+    , SshKeyAlgorithm+        ( SSHKEYRSA+        , SSHKEYDSA+        , SSHKEYECDSA+        , SSHKEYED25519+        , SSHKEYED448+        )+    , SshHashType+        ( SSHSHA2_256+        , SSHSHA2_512+        )+    ) where++import Net.DNSBase.Internal.Present+import Net.DNSBase.Internal.Util+++-- | DNSKEY algorithm, displayed as a number+newtype DNSKEYAlg = DNSKEYAlg Word8+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++instance Presentable DNSKEYAlg where+    present (DNSKEYAlg ka) = present ka+    {-# INLINE present #-}++-- | DS Hash algorithm, displayed as a number+newtype DSHashAlg = DSHashAlg Word8+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++instance Presentable DSHashAlg where+    present (DSHashAlg ha) = present ha+    {-# INLINE present #-}++-- | NSEC3 Hash algorithm, displayed as a number+newtype NSEC3HashAlg = NSEC3HashAlg Word8+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++instance Presentable NSEC3HashAlg where+    present (NSEC3HashAlg na) = present na+    {-# INLINE present #-}++-- | TLSA certificate usages, displayed as a number+newtype DaneUsage = DaneUsage Word8+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++instance Presentable DaneUsage where+    present (DaneUsage u) = present u+    {-# INLINE present #-}++-- | TLSA selectors, displayed as a number+newtype DaneSelector = DaneSelector Word8+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++instance Presentable DaneSelector where+    present (DaneSelector s) = present s+    {-# INLINE present #-}++-- | TLSA matching types, displayed as a number+newtype DaneMtype = DaneMtype Word8+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++instance Presentable DaneMtype where+    present (DaneMtype m) = present m+    {-# INLINE present #-}++-- | SSH host key algorithms+newtype SshKeyAlgorithm = SshKeyAlgorithm Word8+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++instance Presentable SshKeyAlgorithm where+    present SSHKEYRSA           = present @String "RSA"+    present SSHKEYDSA           = present @String "DSA"+    present SSHKEYECDSA         = present @String "ECDSA"+    present SSHKEYED25519       = present @String "Ed25519"+    present SSHKEYED448         = present @String "Ed448"+    present (SshKeyAlgorithm n) = present @String "SSHKEYTYPE" . present n++-- | SSH hash type+newtype SshHashType = SshHashType Word8+    deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Show, Read)++instance Presentable SshHashType where+    present SSHSHA2_256     = present @String "SHA256"+    present SSHSHA2_512     = present @String "SHA512"+    present (SshHashType n) = present @String "SSHHashTYPE" . present n++-- DNSKEY algorithms++pattern KA_RSAMD5 :: DNSKEYAlg+pattern KA_RSAMD5  = DNSKEYAlg 1++pattern KA_DH :: DNSKEYAlg+pattern KA_DH  = DNSKEYAlg 2++pattern KA_DSA :: DNSKEYAlg+pattern KA_DSA  = DNSKEYAlg 3++pattern KA_RSASHA1 :: DNSKEYAlg+pattern KA_RSASHA1  = DNSKEYAlg 5++pattern KA_DSA_NSEC3_SHA1 :: DNSKEYAlg+pattern KA_DSA_NSEC3_SHA1  = DNSKEYAlg 6++pattern KA_RSASHA1_NSEC3_SHA1 :: DNSKEYAlg+pattern KA_RSASHA1_NSEC3_SHA1  = DNSKEYAlg 7++pattern KA_RSASHA256 :: DNSKEYAlg+pattern KA_RSASHA256  = DNSKEYAlg 8++pattern KA_RSASHA512 :: DNSKEYAlg+pattern KA_RSASHA512  = DNSKEYAlg 10++pattern KA_ECC_GOST :: DNSKEYAlg+pattern KA_ECC_GOST  = DNSKEYAlg 12++pattern KA_ECDSAP256SHA256 :: DNSKEYAlg+pattern KA_ECDSAP256SHA256  = DNSKEYAlg 13++pattern KA_ECDSAP384SHA384 :: DNSKEYAlg+pattern KA_ECDSAP384SHA384  = DNSKEYAlg 14++pattern KA_ED25519 :: DNSKEYAlg+pattern KA_ED25519  = DNSKEYAlg 15++pattern KA_ED448 :: DNSKEYAlg+pattern KA_ED448  = DNSKEYAlg 16++-- DS digest type algorithms++pattern DS_SHA1 :: DSHashAlg+pattern DS_SHA1  = DSHashAlg 1++pattern DS_SHA256 :: DSHashAlg+pattern DS_SHA256  = DSHashAlg 2++pattern DS_GOST94 :: DSHashAlg+pattern DS_GOST94  = DSHashAlg 3++pattern DS_SHA384 :: DSHashAlg+pattern DS_SHA384  = DSHashAlg 4++-- NSEC3 Hash algorithms++pattern N3_SHA1 :: NSEC3HashAlg+pattern N3_SHA1  = NSEC3HashAlg 1++-- DANE TLSA certificate usages++pattern PKIX_TA :: DaneUsage+pattern PKIX_TA  = DaneUsage 0++pattern PKIX_EE :: DaneUsage+pattern PKIX_EE  = DaneUsage 1++pattern DANE_TA :: DaneUsage+pattern DANE_TA  = DaneUsage 2++pattern DANE_EE :: DaneUsage+pattern DANE_EE  = DaneUsage 3++pattern PrivCert :: DaneUsage+pattern PrivCert  = DaneUsage 255++-- DANE TLSA selectors++pattern Cert :: DaneSelector+pattern Cert  = DaneSelector 0++pattern SPKI :: DaneSelector+pattern SPKI  = DaneSelector 1++pattern PrivSel :: DaneSelector+pattern PrivSel  = DaneSelector 255++-- DANE TLSA matching types++pattern Full :: DaneMtype+pattern Full  = DaneMtype 0++pattern SHA2_256 :: DaneMtype+pattern SHA2_256  = DaneMtype 1++pattern SHA2_512 :: DaneMtype+pattern SHA2_512  = DaneMtype 2++pattern PrivMatch :: DaneMtype+pattern PrivMatch  = DaneMtype 255++-- [SSHFP KEY algorithms](https://www.iana.org/assignments/dns-sshfp-rr-parameters/dns-sshfp-rr-parameters.xhtml)++pattern SSHKEYRSA     :: SshKeyAlgorithm;       pattern SSHKEYRSA     = 1+pattern SSHKEYDSA     :: SshKeyAlgorithm;       pattern SSHKEYDSA     = 2+pattern SSHKEYECDSA   :: SshKeyAlgorithm;       pattern SSHKEYECDSA   = 3+pattern SSHKEYED25519 :: SshKeyAlgorithm;       pattern SSHKEYED25519 = 4+pattern SSHKEYED448   :: SshKeyAlgorithm;       pattern SSHKEYED448   = 6++pattern SSHSHA2_256   :: SshHashType;           pattern SSHSHA2_256   = 1+pattern SSHSHA2_512   :: SshHashType;           pattern SSHSHA2_512   = 2
+ src/Net/DNSBase/Text.hs view
@@ -0,0 +1,31 @@+{-|+Module      : Net.DNSBase.Text+Description : Text wrappers and zone-file string-presentation helpers+Copyright   : (c) Viktor Dukhovni, 2026+License     : BSD-3-Clause+Maintainer  : ietf-dane@dukhovni.org+Stability   : unstable++Newtype wrappers that tag a byte string with a particular+text-shaped presentation form: 'DnsText' renders an opaque+byte sequence as a DNS character-string with the standard+@\\DDD@ escaping for non-printable bytes, and 'DnsUtf8Text'+renders a UTF-8 'Data.Text.Text' value with the same escape rules.  The+'presentCharString', 'presentDomainLabel', and+'presentHostLabel' helpers handle the per-context escape sets+(character-strings, domain labels, and the stricter hostname+form respectively).  'presentCSVList' formats a comma-separated+list value as used by multi-valued SVCB parameters.+-}++module Net.DNSBase.Text+    ( DnsText(..)+    , DnsUtf8Text(..)+    , dnsTextCmp+    , presentCharString+    , presentDomainLabel+    , presentHostLabel+    , presentCSVList+    ) where++import Net.DNSBase.Internal.Text
+ tests/LiteralsParser.hs view
@@ -0,0 +1,41 @@+-- |+-- Module      : LiteralsParser+-- Description : Tiny test parser used by the literal-splice tests+-- Copyright   : (c) Viktor Dukhovni, 2026+-- License     : BSD-3-Clause+--+-- Wraps the octet-level 'makeDomain8Str' parser for the dnLit \/+-- mbLit \/ parseMbox tests.  Defined in its own module so the TH+-- splices in @tests\/literals.hs@ can refer to it (Template-Haskell+-- staging forbids splices from referencing same-module top-level+-- bindings).+module LiteralsParser+    ( testParser+    , mkWire+    ) where++import Data.ByteString.Short (ShortByteString)+import qualified Data.ByteString.Short as SB+import Data.Text (Text)+import qualified Data.Text as T++import Net.DNSBase.Domain (Domain8Err, makeDomain8Str, shortBytes)++-- | Domain-name parser used by the dnLit \/ mbLit \/+-- decodePresentationMbox tests.  Wraps the byte-level+-- 'makeDomain8Str' to expose the @'Text' -> 'Either' e+-- 'ShortByteString'@ shape that 'dnLit' \/ 'mbLit' \/+-- 'decodePresentationMbox' expect.  No IDN machinery is involved;+-- this is the simplest real parser the test suite can hand to the+-- TH splices.+testParser :: Text -> Either Domain8Err ShortByteString+testParser = fmap shortBytes . makeDomain8Str . T.unpack++-- | Build a wire-form 'ShortByteString' from a list of unescaped+-- label bytes: each label is prefixed with its length byte and a+-- trailing root NUL closes the name.  Used by the tests to+-- describe expected outputs in label-list form.+mkWire :: [ShortByteString] -> ShortByteString+mkWire = foldr cat (SB.singleton 0)+  where+    cat l acc = SB.singleton (fromIntegral (SB.length l)) <> l <> acc
+ tests/domain.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE+    OverloadedStrings+  , TemplateHaskell+  #-}+module Main (main) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Short as SB+import qualified System.Exit as Sys++import Net.DNSBase.Domain++check :: (B.ByteString -> Either Domain8Err Domain)+      -> SB.ShortByteString+      -> Int+      -> Maybe [SB.ShortByteString]+      -> IO ()+check f bs len labels = do+    case f (SB.fromShort bs) of+        Left _   | Nothing <- labels    -> pure ()+        Right dn | Just (toLabels dn) == labels+                 , SB.length (shortBytes dn) == len+1  -> pure ()+        result  -> do+                   putStrLn $ "Failed: " ++ show bs+                   putStrLn $ "Parsed: " ++ show result+                   putStrLn $ "Labels: " ++ show (toLabels <$> result)+                   putStrLn $ "Wirelen: " ++ show (SB.length . shortBytes <$> result)+                   Sys.exitWith $ Sys.ExitFailure 1++main :: IO ()+main = do+    check makeDomain8 "" 0 $ Just []+    check makeDomain8 "." 0 $ Just []+    check makeDomain8 ".." 0 Nothing++    check makeDomain8 "\\." 2 $ Just ["."]+    check makeDomain8 "\\.." 2 $ Just ["."]+    check makeDomain8 "\\.com" 5 $ Just [".com"]+    check makeDomain8 "\\\\" 2 $ Just ["\\"]+    check makeDomain8 "\\\\." 2 $ Just ["\\"]+    check makeDomain8 "\\x" 2 $ Just ["x"]+    check makeDomain8 "x\\y" 3  $ Just ["xy"]+    check makeDomain8 "x\\y." 3  $ Just ["xy"]+    check makeDomain8 "x.\\" 0 Nothing+    check makeDomain8 "x.com\\" 0 Nothing++    check makeDomain8 ".com" 0 Nothing+    check makeDomain8 "com" 4 $ Just ["com"]+    check makeDomain8 "com." 4 $ Just ["com"]+    check makeDomain8 "example.com" 12 $ Just ["example", "com"]+    check makeDomain8 "example.com." 12 $ Just ["example", "com"]+    check makeDomain8 "exa\\mple.com" 12 $ Just ["example", "com"]+    check makeDomain8 "ex\\097mple.com" 12 $ Just ["example", "com"]+    check makeDomain8 "a..b" 0 $ Nothing++    let a i = SB.replicate i 97+    let dot = SB.singleton 0x2e+    check makeDomain8 (a 63) 64 $ Just [a 63]+    check makeDomain8 ((a 63) <> dot <> (a 63) <> dot <> (a 63) <> dot <> (a 61))+                      254 $ Just [a 63, a 63, a 63, a 61]+    check makeDomain8 ((a 63) <> dot <> (a 63) <> dot <> (a 63) <> dot <> (a 61) <> dot)+                      254 $ Just [a 63, a 63, a 63, a 61]++    let b i = mconcat $ replicate i $ SB.pack [98, 0x2e]+    check makeDomain8 (b 1) 2 $ Just ["b"]+    check makeDomain8 (b 127) 254 $ Just $ replicate 127 "b"+    check makeDomain8 (b 127 <> dot) 0 $ Nothing+    check makeDomain8 (b 128) 0 Nothing++    check makeMbox8 "" 0 $ Just []+    check makeMbox8 "." 0 $ Just []+    check makeMbox8 ".." 0 Nothing+    check makeMbox8 "@." 0 Nothing+    check makeMbox8 "@" 0 $ Just []+    check makeMbox8 "@@" 0 Nothing+    check makeMbox8 ".@" 2 $ Just ["."]+    check makeMbox8 ".@" 2 $ Just ["."]+    check makeMbox8 "a.b@" 4 $ Just ["a.b"]+    check makeMbox8 "a.b@." 4 $ Just ["a.b"]+    check makeMbox8 "example.com" 12 $ Just ["example","com"]+    check makeMbox8 "first.last@example.com" 23 $ Just ["first.last","example","com"]+    check makeMbox8 "first\\.last.example.com" 23 $ Just ["first.last","example","com"]++    check makeMbox8 (b 127) 254 $ Just $ replicate 127 "b"+    check makeMbox8 ("b@" <> b 125 <> SB.singleton 98) 254 $ Just $ replicate 127 "b"+    check makeMbox8 ("b@" <> b 126) 254 $ Just $ replicate 127 "b"+    check makeMbox8 (b 126 <> SB.pack [98, 64]) 0 Nothing+    check makeMbox8 (b 128) 0 Nothing++    check makeMbox8 (a 63) 64 $ Just [a 63]+    check makeMbox8 ((a 63) <> dot <> (a 63) <> dot <> (a 63) <> dot <> (a 61))+                    254 $ Just [a 63, a 63, a 63, a 61]+    check makeMbox8 ((a 63) <> dot <> (a 63) <> dot <> (a 63) <> dot <> (a 61) <> dot)+                    254 $ Just [a 63, a 63, a 63, a 61]
+ tests/extensibility.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE+    OverloadedStrings+  , RecordWildCards+  , TypeApplications+  #-}+module Main (main) where++import Control.Monad.Trans.Except (ExceptT(..))+import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.ByteString as B+import Data.ByteString.Short (ShortByteString)+import Data.Word (Word16)++import Net.DNSBase+import Net.DNSBase.Decode.Internal.Option (T_opt(..))+import Net.DNSBase.Decode.Internal.RData (getRData)+import Net.DNSBase.Resolver.Internal.Types (ResolvSeed(..))++----------------------------------------------------------------------+-- A custom RR-data type that overrides the library's built-in 'T_a'+-- at RRTYPE 1: decodes the four wire bytes verbatim into a+-- 'ShortByteString' instead of parsing them as an IPv4 address.++data T_ext_a = T_EXT_A ShortByteString+    deriving (Eq, Ord, Show)++instance Presentable T_ext_a where+    present _ = present @String "EXT_A"++instance KnownRData T_ext_a where+    rdType _ = A+    rdTypePres _ = present @String "EXT_A"+    rdEncode (T_EXT_A bs) = putShortByteString bs+    rdDecode _ _ = const $ RData . T_EXT_A <$> getShortNByteString 4++----------------------------------------------------------------------+-- A custom SVCB SvcParamValue type that overrides the library's+-- built-in @port@ key (codepoint 3): decodes the 16-bit value into+-- 'SPV_EXT_PORT' instead of 'SPV_PORT'.++data SPV_EXT_port = SPV_EXT_PORT Word16+    deriving (Eq, Ord, Show)++instance Presentable SPV_EXT_port where+    present (SPV_EXT_PORT p) = present @String "ext-port=" . present p++instance KnownSVCParamValue SPV_EXT_port where+    spvKey _ = SVCParamKey 3+    encodeSPV (SPV_EXT_PORT p) = put16 p+    decodeSPV _ _ = SVCParamValue . SPV_EXT_PORT <$> get16++----------------------------------------------------------------------++main :: IO ()+main = do+    (s1, s2, s3) <- getSeeds >>= either (fail . show) pure+    defaultMain $ testGroup "Extensibility"+        [ testCase "override built-in RRTYPE A"           (testOverrideRRtype s1)+        , testCase "override built-in SVCB port"          (testOverrideSvcParam s2)+        , testCase "override built-in EDE info-code name" (testOverrideEdeName s3)+        ]+  where+    ede0Name :: (Word16, ShortByteString)+    ede0Name = (0, "Custom Other Error")+    getSeeds = runDNSIO do+        s1 <- ExceptT (makeResolvSeed (registerRRtype T_ext_a defaultResolvConf))+        s2 <- ExceptT (makeResolvSeed (extendRRwithType T_svcb SPV_EXT_port defaultResolvConf))+        s3 <- ExceptT (makeResolvSeed (extendEdnsOptionWithValue O_ede ede0Name defaultResolvConf))+        pure (s1, s2, s3)++testOverrideRRtype :: ResolvSeed -> Assertion+testOverrideRRtype ResolvSeed {seedRDataMap = dm} = do+    case decodeAtWith 0 False (getRData dm Nothing 1 (B.length aWire)) aWire of+        Left err -> assertFailure $ "decode failed: " ++ show err+        Right rd -> case fromRData rd :: Maybe T_ext_a of+            Just _  -> pure ()+            Nothing -> assertFailure $+                "expected T_ext_a, got " ++ presentString rd mempty+  where+    -- | Wire form for the 4-byte A record @192.0.2.1@.+    aWire :: B.ByteString+    aWire = B.pack [0xC0, 0x00, 0x02, 0x01]++testOverrideSvcParam :: ResolvSeed -> Assertion+testOverrideSvcParam ResolvSeed {seedRDataMap = dm} = do+    case decodeAtWith 0 False (getRData dm Nothing 64 (B.length svcbWire)) svcbWire of+        Left err -> assertFailure $ "decode failed: " ++ show err+        Right rd -> case fromRData rd :: Maybe T_svcb of+            Nothing -> assertFailure $+                "expected T_svcb, got " ++ presentString rd mempty+            Just X_SVCB{..} ->+                case spvLookup @SPV_EXT_port _svcParamValues of+                    Just (SPV_EXT_PORT 80) -> pure ()+                    Just (SPV_EXT_PORT p)  -> assertFailure $+                        "expected port 80, got " ++ show p+                    Nothing -> assertFailure $+                        "no SPV_EXT_port in "+                        ++ presentString _svcParamValues mempty+  where+    -- | Wire form for a minimal SVCB record: priority 1, root target,+    -- one SvcParam (port = 80).+    svcbWire :: B.ByteString+    svcbWire = B.pack+        [ 0x00, 0x01   -- priority 1+        , 0x00         -- target = root+        , 0x00, 0x03   -- SvcParamKey port (3)+        , 0x00, 0x02   -- value length 2+        , 0x00, 0x50   -- port 80+        ]++testOverrideEdeName :: ResolvSeed -> Assertion+testOverrideEdeName ResolvSeed {seedRDataMap = dm, seedOptionMap = om} = do+    case decodeAtWith 0 False (getRData dm (Just om) 41 (B.length optEdeWire)) optEdeWire of+        Left err -> assertFailure $ "decode failed: " ++ show err+        Right rd -> case fromRData rd :: Maybe T_opt of+            Nothing -> assertFailure "expected T_opt for RRTYPE 41"+            Just (T_OPT opts) -> case monoOption @O_ede opts of+                [O_EDE 0 name ""] | name == "Custom Other Error" -> pure ()+                other -> assertFailure $ "wrong EDE list: " ++ show other+  where+    -- | Wire form for an OPT RDATA containing a single EDE option+    -- (option code 15, info-code 0, no extra text).+    optEdeWire :: B.ByteString+    optEdeWire = B.pack+        [ 0x00, 0x0F   -- EDE option code (15)+        , 0x00, 0x02   -- value length 2+        , 0x00, 0x00   -- info-code 0, no text+        ]
+ tests/literals.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Main (main) where++import qualified Data.ByteString.Short as SB+import qualified System.Exit as Sys++import Net.DNSBase.Domain++import LiteralsParser (testParser, mkWire)++----------------------------------------------------------------------+-- Splice values (built at compile time; the @testParser@ runs in+-- the Q monad during these splices, and a build failure here would+-- mean the dnLit / mbLit machinery rejects valid input).+----------------------------------------------------------------------++dnExample :: Domain+dnExample = $$(dnLit testParser "example.org")++mbAt :: Domain+mbAt = $$(mbLit testParser "user@example.org")++mbDot :: Domain+mbDot = $$(mbLit testParser "user.example.org")++mbBare :: Domain+mbBare = $$(mbLit testParser "postmaster")++----------------------------------------------------------------------+-- Test plumbing (plain stdio, matches tests/domain.hs style).+----------------------------------------------------------------------++fatal :: String -> IO ()+fatal msg = do+    putStrLn $ "literals: " ++ msg+    Sys.exitWith (Sys.ExitFailure 1)++eqOrDie :: (Eq a, Show a) => String -> a -> a -> IO ()+eqOrDie name expected actual+    | expected == actual = pure ()+    | otherwise = fatal $ name ++ ": expected " ++ show expected+                               ++ ", got " ++ show actual++leftOrDie :: Show a => String -> Either e a -> IO ()+leftOrDie name r = case r of+    Left _  -> pure ()+    Right x -> fatal $ name ++ ": expected Left, got Right " ++ show x++----------------------------------------------------------------------+-- Tests+----------------------------------------------------------------------++main :: IO ()+main = do+    -- dnLit / mbLit smoke tests.+    eqOrDie "dnLit/example.org"+            (mkWire ["example", "org"])+            (shortBytes dnExample)+    eqOrDie "mbLit/@"+            (mkWire ["user", "example", "org"])+            (shortBytes mbAt)+    eqOrDie "mbLit/."+            (mkWire ["user", "example", "org"])+            (shortBytes mbDot)+    eqOrDie "mbLit/bare"+            (mkWire ["postmaster"])+            (shortBytes mbBare)++    -- decodePresentationMbox positive cases.+    eqOrDie "decodePresentationMbox/@"+            (Right (mkWire ["user", "example", "org"]))+            (shortBytes <$> decodePresentationMbox testParser "user@example.org")+    eqOrDie "decodePresentationMbox/."+            (Right (mkWire ["user", "example", "org"]))+            (shortBytes <$> decodePresentationMbox testParser "user.example.org")+    eqOrDie "decodePresentationMbox/bare"+            (Right (mkWire ["postmaster"]))+            (shortBytes <$> decodePresentationMbox testParser "postmaster")+    eqOrDie "decodePresentationMbox/bare-trailing-dot"+            (Right (mkWire ["postmaster"]))+            (shortBytes <$> decodePresentationMbox testParser "postmaster.")+    eqOrDie "decodePresentationMbox/bare-trailing-at"+            (Right (mkWire ["postmaster"]))+            (shortBytes <$> decodePresentationMbox testParser "postmaster@")+    eqOrDie "decodePresentationMbox/DDD-escape"+            (Right (mkWire ["A.B", "org"]))+            (shortBytes <$> decodePresentationMbox testParser "A\\046B.org")+    eqOrDie "decodePresentationMbox/C-escape-dot"+            (Right (mkWire ["a.b", "org"]))+            (shortBytes <$> decodePresentationMbox testParser "a\\.b.org")+    eqOrDie "decodePresentationMbox/C-escape-at"+            (Right (mkWire ["a@b", "org"]))+            (shortBytes <$> decodePresentationMbox testParser "a\\@b.org")+    eqOrDie "decodePresentationMbox/escaped-@-then-real-@"+            (Right (mkWire ["u@v", "example", "org"]))+            (shortBytes <$> decodePresentationMbox testParser "u\\@v@example.org")+    -- EAI: literal non-ASCII Chars are UTF-8 encoded into the+    -- localpart wire bytes.  "виктор" -> UTF-8 0xD0 B2 D0 B8 D0+    -- BA D1 82 D0 BE D1 80 (12 bytes).  The IsString instance for+    -- ShortByteString does a byte-per-Char Latin-1 truncation, so+    -- the expected-bytes literal below is the literal wire form.+    eqOrDie "decodePresentationMbox/utf8-cyrillic-localpart"+            (Right (mkWire [ "\xD0\xB2\xD0\xB8\xD0\xBA\xD1\x82\xD0\xBE\xD1\x80"+                           , "example", "org" ]))+            (shortBytes <$> decodePresentationMbox testParser "\1074\1080\1082\1090\1086\1088@example.org")++    -- decodePresentationMbox negative cases.+    leftOrDie "decodePresentationMbox/empty-localpart"+              (decodePresentationMbox testParser "@example.org")+    leftOrDie "decodePresentationMbox/bad-escape-truncated"+              (decodePresentationMbox testParser "u\\")+    -- EAI: \DDD with DDD >= 128 is rejected (no raw high octets+    -- in a pure-ASCII-or-UTF-8 localpart).+    leftOrDie "decodePresentationMbox/high-DDD-escape"+              (decodePresentationMbox testParser "u\\200v@example.org")+    -- EAI: \C with non-ASCII C is rejected for the same reason.+    leftOrDie "decodePresentationMbox/high-C-escape"+              (decodePresentationMbox testParser "u\\\233v@example.org")+    leftOrDie "decodePresentationMbox/unknown-domain"+              (decodePresentationMbox testParser "user@bogus\\")  -- malformed escape rejects in Parse8++    -- wireToDomain positive cases.+    eqOrDie "wireToDomain/root"+            (Just (SB.singleton 0))+            (shortBytes <$> wireToDomain (SB.singleton 0))+    eqOrDie "wireToDomain/single"+            (Just (mkWire ["org"]))+            (shortBytes <$> wireToDomain (mkWire ["org"]))+    eqOrDie "wireToDomain/multi"+            (Just (mkWire ["example", "org"]))+            (shortBytes <$> wireToDomain (mkWire ["example", "org"]))++    -- wireToDomain negative cases (raw byte sequences via SB.pack+    -- so the inputs are unambiguous regardless of OverloadedStrings+    -- decoding).+    eqOrDie "wireToDomain/empty"+            Nothing+            (shortBytes <$> wireToDomain SB.empty)+    eqOrDie "wireToDomain/no-terminator"+            Nothing+            (shortBytes <$> wireToDomain (SB.pack [3, 0x6f, 0x72, 0x67]))+    eqOrDie "wireToDomain/extra-bytes-after-root"+            Nothing+            (shortBytes <$> wireToDomain (SB.pack [3, 0x6f, 0x72, 0x67, 0, 0]))+    eqOrDie "wireToDomain/lying-label-length"+            Nothing+            (shortBytes <$> wireToDomain (SB.pack [16, 0x6f, 0x6f, 0x70, 0x73, 0]))++    putStrLn "literals: all tests passed"
+ tests/message.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE+    OverloadedStrings+  , TemplateHaskell+  #-}+module Main (main) where++import qualified Data.Base16.Types as B16+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString as B+import qualified System.Exit as Sys++import Net.DNSBase.Domain+import Net.DNSBase.Message+import Net.DNSBase.Flags+import Net.DNSBase.EDNS+import Net.DNSBase.EDNS.Option+import Net.DNSBase.EDNS.Option.NSID+import Net.DNSBase.Opcode+import Net.DNSBase.RCODE+import Net.DNSBase.RR+import Net.DNSBase.RRCLASS+import Net.DNSBase.RRTYPE+import Net.DNSBase.RData+import Net.DNSBase.RData.A+import Net.DNSBase.RData.SRV+++check :: (Show a, Eq a)+      => Either a B.ByteString+      -> Either a B.ByteString+      -> IO ()+check actual wanted = do+    if actual == wanted+    then pure ()+    else do putStrLn $ "Wanted: " ++ show wanted+            putStrLn $ "Actual: " ++ show actual+            Sys.exitWith $ Sys.ExitFailure 1++-- | Encode a query with given features via the request encoder.+mkReq :: Domain+      -> RRTYPE+      -> DNSFlags+      -> Maybe EDNS+      -> Either (EncodeErr (Maybe RData)) B.ByteString+mkReq qname qtype flags edns =+    fmap (B16.extractBase16 . B16.encodeBase16')+    $ encodeVerbatim+    $ putRequest 0xbeef flags edns (DnsTriple qname qtype IN)+++-- | Encode a query with given features via the generic encoder.+mkQuery :: Domain+        -> RRTYPE+        -> RCODE+        -> DNSFlags+        -> Maybe EDNS+        -> Either (EncodeErr (Maybe RData)) B.ByteString+mkQuery qname qtype rc flags edns =+    fmap (B16.extractBase16 . B16.encodeBase16')+    $ encodeVerbatim+    $ putMessage+    $ DNSMessage 0xbeef Query rc flags edns+                 [DnsTriple qname qtype IN]+                 [] [] []++-- | Create a response message with given features and name compression+mkAnswer :: Domain+         -> RRTYPE+         -> RCODE+         -> DNSFlags+         -> Maybe EDNS+         -> [RR]+         -> [RR]+         -> [RR]+         -> Either (EncodeErr (Maybe RData)) B.ByteString+mkAnswer qname qtype rc flags edns an ns ar =+    fmap (B16.extractBase16 . B16.encodeBase16')+    $ encodeCompressed+    $ putMessage+    $ DNSMessage 0xbeef Query rc (QRflag <> flags) edns+                 [DnsTriple qname qtype IN]+                 an ns ar+++main :: IO ()+main = do+    let rdad = RDflag <> ADflag+    -- Minimal legacy query+    check (mkReq $$(dnLit8 "example.com") MX rdad Nothing) $+        Right $ "beef0120"         -- header+             <> "00010000"         -- qdcount, ancount+             <> "00000000"         -- nscount, arcount+             <> "076578616d706c65" -- "example."+             <> "03636f6d00"       -- "com."+             <> "000f0001"         -- MX IN++    -- Minimal EDNS query+    check (mkReq $$(dnLit8 "example.com") MX rdad (Just defaultEDNS)) $+        Right $ "beef0120"         -- header+             <> "00010000"         -- qdcount, ancount+             <> "00000001"         -- nscount, arcount+             <> "076578616d706c65" -- "example."+             <> "03636f6d00"       -- "com."+             <> "000f0001"         -- MX IN+             <> "000029"           -- . OPT+             <> "0578"             -- buffer size 1400+             <> "0000"             -- extRCODE=0 ednsVERSION=0+             <> "00000000"         -- Flags=0x0000, RDLEN=0++    -- EDNS with NSID option+    let nsid = EdnsOption $ O_NSID ""+        edns = defaultEDNS { ednsOptions = [nsid] }+        dord = DOflag <> RDflag+    check (mkReq $$(dnLit8 "example.com") MX dord (Just edns)) $+        Right $ "beef0100"         -- header+             <> "00010000"         -- qdcount, ancount+             <> "00000001"         -- nscount, arcount+             <> "076578616d706c65" -- "example."+             <> "03636f6d00"       -- "com."+             <> "000f0001"         -- MX IN+             <> "000029"           -- . OPT+             <> "0578"             -- buffer size 1400+             <> "0000"             -- extRCODE=0 ednsVERSION=0+             <> "80000004"         -- Flags=DO, RDLEN=4+             <> "00030000"         -- NSID, length 0++    -- Extended rcode with EDNS disabled+    check (mkReq $$(dnLit8 "example.com") MX (rdad <> DOflag) Nothing) $+        Left EDNSRequired++    -- Extended flags with EDNS disabled+    check (mkQuery $$(dnLit8 "example.com") MX BADVERS rdad Nothing) $+        Left EDNSRequired++    -- Extended RCODE and flags with EDNS enabled+    check (mkQuery $$(dnLit8 "example.com") MX BADVERS (rdad <> DOflag) (Just defaultEDNS)) $+        Right $ "beef0120"         -- header+             <> "00010000"         -- qdcount, ancount+             <> "00000001"         -- nscount, arcount+             <> "076578616d706c65" -- "example."+             <> "03636f6d00"       -- "com."+             <> "000f0001"         -- MX IN+             <> "000029"           -- . OPT+             <> "0578"             -- buffer size 1400+             <> "0100"             -- extRCODE=1 ednsVERSION=0+             <> "80000000"         -- Flags=0x8000, RDLEN=0++    -- EDNS answer with name compression+    let rdraad = RDflag <> RAflag <> ADflag+    check (mkAnswer $$(dnLit8 "example.com") MX NOERROR rdraad (Just defaultEDNS)+           [ RR $$(dnLit8 "example.com") IN 300+                $ RData $ T_MX 10 $$(dnLit8 "mx1.example.com")+           , RR $$(dnLit8 "example.com") IN 300+                $ RData $ T_MX 10 $$(dnLit8 "mx2.example.com") ]+           []+           [ RR $$(dnLit8 "mx1.example.com") IN 300+                $ RData $ T_A "192.0.2.1"+           , RR $$(dnLit8 "mx2.example.com") IN 300+                $ RData $ T_A "192.0.2.2" ]+        ) $+        Right $ "beef81a0"         -- 0. header+             <> "00010002"         -- 4. qdcount, ancount+             <> "00000003"         -- 8. nscount, arcount+             --+             <> "076578616d706c65" -- 12. "example."+             <> "03636f6d00"       -- 20. "com."+             <> "000f0001"         -- 25. MX IN+             --+             <> "c00c"             -- 29. "example.com" compressed+             <> "000f0001"         -- 31. MX IN+             <> "0000012c"         -- 35. TTL = 300+             <> "0008"             -- 39. RDLEN = 8+             <> "000a"             -- 41. pref = 10+             <> "036d7831c00c"     -- 43. exch = "mx1.example.com" compressed+             --+             <> "c00c"             -- 49. "example.com" compressed+             <> "000f0001"         -- 51. MX IN+             <> "0000012c"         -- 55. TTL = 300+             <> "0008"             -- 59. RDLEN = 8+             <> "000a"             -- 61. pref = 10+             <> "036d7832c00c"     -- 63. exch = "mx2.example.com" compressed+             --+             <> "000029"           -- 69. . OPT+             <> "0578"             -- 72. buffer size 1400+             <> "0000"             -- 74. extRCODE=0 ednsVERSION=0+             <> "00000000"         -- 76. Flags=0x0000, RDLEN=0+             --+             <> "c02b"             -- 80. "mx1.example.com" compressed+             <> "00010001"         -- 82. A IN+             <> "0000012c"         -- 86. TTL = 300+             <> "0004"             -- 90. RDLEN = 4+             <> "c0000201"         -- 92. 192.0.2.1+             --+             <> "c03f"             -- 96. "mx2.example.com" compressed+             <> "00010001"         -- 98. A IN+             <> "0000012c"         -- 102. TTL = 300+             <> "0004"             -- 106. RDLEN = 4+             <> "c0000202"         -- 108. 192.0.2.2
+ tests/test.hs view
@@ -0,0 +1,1373 @@+{-# LANGUAGE+    OverloadedStrings+  , OverloadedLists+  , RecordWildCards+  , TemplateHaskell+  #-}+module Main where++import Test.Tasty+import Test.Tasty.QuickCheck hiding ((.&.))++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Lazy.Char8 as LC+import qualified Data.ByteString.Short as SB+import qualified Data.IntMap.Strict as IM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Unsafe as T+import Data.IP (Addr(..))+import Data.Typeable (eqT)+import GHC.IsList(IsList(..))++-- getRR and getMessage are not public APIs, nor rdataEncodeCanonical+import Net.DNSBase.Decode.Internal.Message (getMessage)+import Net.DNSBase.Decode.Internal.Option+import Net.DNSBase.Decode.Internal.RData+import Net.DNSBase.EDNS.Internal.Option (OptionCodec(..))+import Net.DNSBase.Internal.RData+import Net.DNSBase.Internal.Util+import Net.DNSBase.Resolver.Internal.Types (ResolvSeed(..))++import Net.DNSBase+import Net.DNSBase.Nat16+import Net.DNSBase.RData.Obsolete++main :: IO ()+main = do+    seed <- makeResolvSeed conf >>= either (fail . show) pure+    defaultMain $ testGroup "Main"+        [ textTests+        , vectorTests+        , canonOrdTests+        , canonEqTests seed+        , rdataTests seed+        , ednsTests seed+        ]+  where+    localhost = NameserverSpec "::1" Nothing :| []+    conf = setResolverConfSource (HostList localhost) defaultResolvConf++    textTests :: TestTree+    textTests = testGroup "Prerequisite UTF8 support" [ testUtf8 ]++    vectorTests :: TestTree+    vectorTests = testGroup "Presentation and wire test vectors" (testVec <$> testVectors)++    rdataTests :: ResolvSeed -> TestTree+    rdataTests ResolvSeed {..} =+        testGroup "RData codec round-trip tests" $+            rdgens (testRData seedRDataMap)++    canonEqTests :: ResolvSeed -> TestTree+    canonEqTests ResolvSeed {..} =+        testGroup "Decoding canonical encoding equal to input" $+            rdgens (testCnEq seedRDataMap)++    canonOrdTests :: TestTree+    canonOrdTests =+        testGroup "RData Ord is canonical" $+            (rdgens testCnOrd)++    ednsTests :: ResolvSeed -> TestTree+    ednsTests ResolvSeed {..} =+        testGroup "EDNS option codec round-trip tests" $+            optgens (testOption seedRDataMap seedOptionMap)++    optgens f =+        [ f ECS  genECS+        , f NSID genNSID+        , f DAU  genDAU+        , f DHU  genDHU+        , f N3U  genN3U+        , f EDE  genEDE+        , f 0    genOpaqueOpt ]++    rdgens f =+        [ f A          genA+        , f NS         genNS+        , f MD         genMD+        , f MF         genMF+        , f CNAME      genCNAME+        , f SOA        genSOA+        , f MB         genMB+        , f MG         genMG+        , f MR         genMR+        , f NULL       genNULL+        , f WKS        genWKS+        , f PTR        genPTR+        , f HINFO      genHINFO+        , f MINFO      genMINFO+        , f MX         genMX+        , f TXT        genTXT+        , f RP         genRP+        , f AFSDB      genAFSDB+        , f X25        genX25+        , f ISDN       genISDN+        , f RT         genRT+        , f NSAP       genNSAP+        , f NSAPPTR    genNSAPPTR+        , f SIG        genSIG+        , f KEY        genKEY+        , f PX         genPX+        , f GPOS       genGPOS+        , f AAAA       genAAAA+        , f NXT        genNXT+        , f SRV        genSRV+        , f NAPTR      genNAPTR+        , f KX         genKX+        , f A6         genA6+        , f DNAME      genDNAME+        , f DS         genDS+        , f SSHFP      genSSHFP+        , f IPSECKEY   genIPSECKEY+        , f RRSIG      genRRSIG+        , f NSEC       genNSEC+        , f DNSKEY     genDNSKEY+        , f NSEC3      genNSEC3+        , f NSEC3PARAM genNSEC3PARAM+        , f TLSA       genTLSA+        , f SMIMEA     genSMIMEA+        , f CDS        genCDS+        , f CDNSKEY    genCDNSKEY+        , f OPENPGPKEY genOPENPGPKEY+        , f CSYNC      genCSYNC+        , f ZONEMD     genZONEMD+        , f SVCB       genSVCB+        , f HTTPS      genHTTPS+        , f DSYNC      genDSYNC+        , f NID        genNID+        , f L32        genL32+        , f L64        genL64+        , f LP         genLP+        , f CAA        genCAA+        , f AMTRELAY   genAMTRELAY+        , f (RRTYPE 0xfeed) (genOpaque 0xfeed)+        ]++testVec ::  (RR, LB.ByteString, Bytes16) -> TestTree+testVec (rr, pform, wform) =+    testProperty testName $+        if (gotp /= pform)+        then error $ "RR: " ++ show rr +++                ",\nPresentation form delta:\nhave:\t" ++ LC.unpack gotp +++                "\nwant:\t" ++ LC.unpack pform+        else case gotw of+            Left err -> error $ "Failed to encode: " ++ show rr ++ ", reason: " ++ show err+            Right bs | bs /= wform ->+                        error $ "RR: " ++ show rr +++                            ",\nWire form delta:\nhave:\t" ++ show bs +++                            "\nwant:\t" ++ show wform+                     | otherwise -> True+  where+    typeName = case rrData rr of+        RData (_ :: t) -> show $ rdTypePres t mempty+    testName = presentString typeName " presentation and wire form test vector"+    gotp = presentLazy rr mempty+    gotw = Bytes16 . SB.toShort <$> encodeCompressed (putRR rr)++testVectors :: [ (RR, LB.ByteString, Bytes16) ]+testVectors =+    [ ( mkRR zone $ T_A "192.0.2.1"+      , "example.org. 300 IN A 192.0.2.1"+      , "076578616d706c65036f726700"+        <> "0001" <> "0001" <> "0000012c" <> "0004"+        <> "c0000201"+      )+    , ( mkRR zone $ T_NS $$(dnLit8 "nsa.example.org")+      , "example.org. 300 IN NS nsa.example.org."+      , "076578616d706c65036f726700"+        <> "0002" <> "0001" <> "0000012c" <> "0006"+        <> "036e7361c000"+      )+    , ( mkRR zone $ T_MD $$(dnLit8 "madname.example.org")+      , "example.org. 300 IN MD madname.example.org."+      , "076578616d706c65036f726700"+        <> "0003" <> "0001" <> "0000012c" <> "000a"+        <> "076d61646e616d65c000"+      )+    , ( mkRR zone $ T_MF $$(dnLit8 "madname.example.org")+      , "example.org. 300 IN MF madname.example.org."+      , "076578616d706c65036f726700"+        <> "0004" <> "0001" <> "0000012c" <> "000a"+        <> "076d61646e616d65c000"+      )+    , ( mkRR zone $ T_CNAME $$(dnLit8 "cname.example.org")+      , "example.org. 300 IN CNAME cname.example.org."+      , "076578616d706c65036f726700"+        <> "0005" <> "0001" <> "0000012c" <> "0008"+        <> "05636e616d65c000"+      )+    , ( mkRR zone $ T_SOA $$(dnLit8 "dns.example.org") $$(mbLit8 "postmaster@dns.example.org") 2023111301 1800 900 604800 86400+      , "example.org. 300 IN SOA dns.example.org. postmaster.dns.example.org. 2023111301 1800 900 604800 86400"+      , "076578616d706c65036f726700"+        <> "0006" <> "0001" <> "0000012c" <> "0027"+        <> "03646e73c000" <> "0a706f73746d6173746572c017"+        <> "78963a85" <> "00000708" <> "00000384" <> "00093a80" <> "00015180"+      )+    , ( mkRR zone $ T_MB $$(dnLit8 "madname.example.org")+      , "example.org. 300 IN MB madname.example.org."+      , "076578616d706c65036f726700"+        <> "0007" <> "0001" <> "0000012c" <> "000a"+        <> "076d61646e616d65c000"+      )+    , ( mkRR zone $ T_MG $$(mbLit8 "some.name@example.org")+      , "example.org. 300 IN MG some\\.name.example.org."+      , "076578616d706c65036f726700"+        <> "0008" <> "0001" <> "0000012c" <> "000c"+        <> "09736f6d652e6e616d65c000"+      )+    , ( mkRR zone $ T_MR $$(mbLit8 "other.name@example.org")+      , "example.org. 300 IN MR other\\.name.example.org."+      , "076578616d706c65036f726700"+        <> "0009" <> "0001" <> "0000012c" <> "000d"+        <> "0a6f746865722e6e616d65c000"+      )+    , ( mkRR zone $ T_NULL "feedcafedeadbeef"+      , "example.org. 300 IN NULL \\# 8 feedcafedeadbeef"+      , "076578616d706c65036f726700"+        <> "000a" <> "0001" <> "0000012c" <> "0008"+        <> "feedcafedeadbeef"+      )+    , ( mkRR zone $ T_WKS "192.0.2.1" UDP [53]+      , "example.org. 300 IN WKS 192.0.2.1 UDP ( 53 )"+      , "076578616d706c65036f726700"+        <> "000b" <> "0001" <> "0000012c" <> "000c"+        <> "c0000201" <> "11" <> "00000000000004"+      )+    , ( mkRR zone $ T_PTR $$(mbLit8 "ptr.example.org")+      , "example.org. 300 IN PTR ptr.example.org."+      , "076578616d706c65036f726700"+        <> "000c" <> "0001" <> "0000012c" <> "0006"+        <> "03707472c000"+      )+    , ( mkRR zone $ T_HINFO "Some\tCPU" "Some \\ OS"+      , "example.org. 300 IN HINFO \"Some\\009CPU\" \"Some \\\\ OS\""+      , "076578616d706c65036f726700"+        <> "000d" <> "0001" <> "0000012c" <> "0013"+        <> "08536f6d650943505509536f6d65205c204f53"+      )+    , ( mkRR zone $ T_MINFO $$(mbLit8 "list-request.example.org")+                           $$(mbLit8 "owner-list.example.org")+      , "example.org. 300 IN MINFO list-request.example.org." <>+        " owner-list.example.org."+      , "076578616d706c65036f726700"+        <> "000e" <> "0001" <> "0000012c" <> "001c"+        <> "0c6c6973742d72657175657374c000"+        <> "0a6f776e65722d6c697374c000"+      )+    , ( mkRR zone $ T_MX 10 $$(dnLit8 "mx1.example.org")+      , "example.org. 300 IN MX 10 mx1.example.org."+      , "076578616d706c65036f726700"+        <> "000f" <> "0001" <> "0000012c" <> "0008"+        <> "000a" <> "036d7831c000"+      )+    , ( mkRR zone $ T_TXT [ "The \"quick\" brown fox",+                           " jumped over the lazy dog\n" ]+      , "example.org. 300 IN TXT \"The \\\"quick\\\" brown fox\"" <>+        " \" jumped over the lazy dog\\010\""+      , "076578616d706c65036f726700"+        <> "0010" <> "0001" <> "0000012c" <> "0031"+        <> "155468652022717569636b222062726f776e20666f78"+        <> "1a206a756d706564206f76657220746865206c617a7920646f670a"+      )+    , ( mkRR zone $ T_RP $$(mbLit8 "noc@example.org") $$(dnLit8 "contact.example.org")+      , "example.org. 300 IN RP noc.example.org. contact.example.org."+      , "076578616d706c65036f726700"+        <> "0011" <> "0001" <> "0000012c" <> "0026"+        <> "036e6f63076578616d706c65036f726700"+        <> "07636f6e74616374076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_AFSDB 12345 $$(dnLit8 "voldb.example.org")+      , "example.org. 300 IN AFSDB 12345 voldb.example.org."+      , "076578616d706c65036f726700"+        <> "0012" <> "0001" <> "0000012c" <> "0015"+        <> "3039"+        <> "05766f6c6462076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_X25 "1234567890"+      , "example.org. 300 IN X25 \"1234567890\""+      , "076578616d706c65036f726700"+        <> "0013" <> "0001" <> "0000012c" <> "000b"+        <> "0a31323334353637383930"+      )+    , ( mkRR zone $ T_ISDN "1234567890" Nothing+      , "example.org. 300 IN ISDN \"1234567890\""+      , "076578616d706c65036f726700"+        <> "0014" <> "0001" <> "0000012c" <> "000b"+        <> "0a31323334353637383930"+      )+    , ( mkRR zone $ T_ISDN "1234567890" (Just "beef")+      , "example.org. 300 IN ISDN \"1234567890\" \"beef\""+      , "076578616d706c65036f726700"+        <> "0014" <> "0001" <> "0000012c" <> "0010"+        <> "0a31323334353637383930"+        <> "0462656566"+      )+    , ( mkRR zone $ T_RT 12345 $$(dnLit8 "route1.example.org")+      , "example.org. 300 IN RT 12345 route1.example.org."+      , "076578616d706c65036f726700"+        <> "0015" <> "0001" <> "0000012c" <> "0016"+        <> "3039"+        <> "06726f75746531076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_NSAP (coerce @Bytes16 "01e13708002010726e00")+      , "example.org. 300 IN NSAP 0x01e13708002010726e00"+      , "076578616d706c65036f726700"+        <> "0016" <> "0001" <> "0000012c" <> "000a"+        <> "01e13708002010726e00"+      )+    , ( mkRR zone $ T_NSAPPTR zone+      , "example.org. 300 IN NSAP-PTR example.org."+      , "076578616d706c65036f726700"+        <> "0017" <> "0001" <> "0000012c" <> "000d"+        <> "076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_SIG NS 13 1 172800 (coerce @Epoch64 "20231120081211")+                                         (coerce @Epoch64 "20231113070211")+                                         44222 zone sigbytes+      , "example.org. 300 IN SIG NS 13 1 172800 20231120081211 20231113070211 44222 example.org. "+        <> sigchars+      , "076578616d706c65036f726700"+        <> "0018" <> "0001" <> "0000012c" <> "005f"+        <> "0002" <> "0d" <> "01" <> "0002a300"+        <> "655b14db" <> "6551c9f3" <> "acbe"+        <> "076578616d706c65036f726700"+        <> sighex+      )+    , ( mkRR zone $ T_KEY 257 3 13 keybytes+      , "example.org. 300 IN KEY 257 3 13 " <> keychars+      , "076578616d706c65036f726700"+        <> "0019" <> "0001" <> "0000012c" <> "0044"+        <> "0101" <> "03" <> "0d" <> keyhex+      )+    , ( mkRR zone $ T_PX 12345 zone zone+      , "example.org. 300 IN PX 12345 example.org. example.org."+      , "076578616d706c65036f726700"+        <> "001a" <> "0001" <> "0000012c" <> "001c"+        <> "3039"+        <> "076578616d706c65036f726700"+        <> "076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_GPOS "-32.6882" "116.8652" "10.0"+      , "example.org. 300 IN GPOS \"-32.6882\" \"116.8652\" \"10.0\""+      , "076578616d706c65036f726700"+        <> "001b" <> "0001" <> "0000012c" <> "0017"+        <> "082d33322e36383832"+        <> "083131362e38363532"+        <> "0431302e30"+      )+    , ( mkRR zone $ T_AAAA "::192.0.2.1"+      , "example.org. 300 IN AAAA ::192.0.2.1"+      , "076578616d706c65036f726700"+        <> "001c" <> "0001" <> "0000012c" <> "0010"+        <> "000000000000000000000000c0000201"+      )+    , ( mkRR zone $ T_NXT $$(dnLit8 "*.example.org") (toNxtTypes $ NS :| [SOA, KEY, SIG])+      , "example.org. 300 IN NXT *.example.org. NS SOA SIG KEY NXT"+      , "076578616d706c65036f726700"+        <> "001e" <> "0001" <> "0000012c" <> "0013"+        <> "012a076578616d706c65036f726700"+        <> "220000c2"+      )+    , ( mkRR zone $ T_SRV 2000 300 4443 $$(dnLit8 "www.example.org")+      , "example.org. 300 IN SRV 2000 300 4443 www.example.org."+      , "076578616d706c65036f726700"+        <> "0021" <> "0001" <> "0000012c" <> "0017"+        <> "07d0" <> "012c" <> "115b"+        <> "03777777076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_NAPTR 100 10 "" "" "!^urn:cid:.+@([^\\.]+\\.)(.*)$!\\2!i" RootDomain+      , "example.org. 300 IN NAPTR 100 10 \"\" \"\" \"!^urn:cid:.+@([^\\\\.]+\\\\.)(.*)$!\\\\2!i\" ."+      , "076578616d706c65036f726700"+        <> "0023" <> "0001" <> "0000012c" <> "0029"+        <> "0064" <> "000a" <> "00" <> "00"+        <> "21215e75726e3a6369643a2e2b40285b5e5c2e5d2b5c2e29282e2a2924215c322169"+        <> "00"+      )+    , ( mkRR zone $ T_KX 12345 $$(dnLit8 "kx.example.org")+      , "example.org. 300 IN KX 12345 kx.example.org."+      , "076578616d706c65036f726700"+        <> "0024" <> "0001" <> "0000012c" <> "0012"+        <> "3039" <> "026b78076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_A6 0 "::1" Nothing+      , "example.org. 300 IN A6 0 ::1"+      , "076578616d706c65036f726700"+        <> "0026" <> "0001" <> "0000012c" <> "0011"+        <> "00" <> "00000000000000000000000000000001"+      )+    , ( mkRR zone $ T_A6 128 "::" (Just zone)+      , "example.org. 300 IN A6 128 :: example.org."+      , "076578616d706c65036f726700"+        <> "0026" <> "0001" <> "0000012c" <> "000e"+        <> "80" <> "076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_A6 32 "::192.0.2.1" (Just zone)+      , "example.org. 300 IN A6 32 ::192.0.2.1 example.org."+      , "076578616d706c65036f726700"+        <> "0026" <> "0001" <> "0000012c" <> "001a"+        <> "20" <> "0000000000000000c0000201"+        <> "076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_DNAME $$(dnLit8 "sample.org.")+      , "example.org. 300 IN DNAME sample.org."+      , "076578616d706c65036f726700"+        <> "0027" <> "0001" <> "0000012c" <> "000c"+        <> "0673616d706c65036f726700"+      )+    , ( mkRR zone $ T_DS 37331 13 2 shabytes+      , "example.org. 300 IN DS 37331 13 2 " <> shachars+      , "076578616d706c65036f726700"+        <> "002b" <> "0001" <> "0000012c" <> "0024"+        <> "91d3" <> "0d" <> "02" <> shahex+      )+    , ( mkRR zone $ T_SSHFP 4 2 sshkeybytes+      , "example.org. 300 IN SSHFP 4 2 " <> sshkeychars+      , "076578616d706c65036f726700"+        <> "002c" <> "0001" <> "0000012c" <> "0022"+        <> "04" <> "02" <> sshkeyhex+      )+    , ( mkRR zone $ IPSecKey 42 0 0 IPSecKeyGWX keybytes+      , "example.org. 300 IN IPSECKEY 42 0 0 . " <> keychars+      , "076578616d706c65036f726700"+        <> "002d" <> "0001" <> "0000012c" <> "0043"+        <> "2a" <> "00" <> "00" <> keyhex+      )+    , ( mkRR zone $ IPSecKey 42 1 0 (IPSecKeyGW4 "192.0.2.1") keybytes+      , "example.org. 300 IN IPSECKEY 42 1 0 192.0.2.1 " <> keychars+      , "076578616d706c65036f726700"+        <> "002d" <> "0001" <> "0000012c" <> "0047"+        <> "2a" <> "01" <> "00" <> "c0000201" <> keyhex+      )+    , ( mkRR zone $ IPSecKey 42 2 0 (IPSecKeyGW6 "::192.0.2.1") keybytes+      , "example.org. 300 IN IPSECKEY 42 2 0 ::192.0.2.1 " <> keychars+      , "076578616d706c65036f726700"+        <> "002d" <> "0001" <> "0000012c" <> "0053"+        <> "2a" <> "02" <> "00" <> "000000000000000000000000c0000201" <> keyhex+      )+    , ( mkRR zone $ IPSecKey 42 3 0 (IPSecKeyGWD $$(dnLit8 "gw.example.org")) keybytes+      , "example.org. 300 IN IPSECKEY 42 3 0 gw.example.org. " <> keychars+      , "076578616d706c65036f726700"+        <> "002d" <> "0001" <> "0000012c" <> "0053"+        <> "2a" <> "03" <> "00" <> "026777076578616d706c65036f726700" <> keyhex+      )+    , ( mkRR zone $ IPSecKey 42 4 0 (IPSecKeyGWG gwkeybytes) mempty+      , "example.org. 300 IN IPSECKEY \\# 11 2a0400" <> gwkeychars+      , "076578616d706c65036f726700"+        <> "002d" <> "0001" <> "0000012c" <> "000b"+        <> "2a" <> "04" <> "00" <> gwkeyhex+      )+    , ( mkRR zone $ T_RRSIG NS 13 1 172800 (coerce @Epoch64 "20231120081211")+                                           (coerce @Epoch64 "20231113070211")+                                           44222 zone sigbytes+      , "example.org. 300 IN RRSIG NS 13 1 172800 20231120081211 20231113070211 44222 example.org. "+        <> sigchars+      , "076578616d706c65036f726700"+        <> "002e" <> "0001" <> "0000012c" <> "005f"+        <> "0002" <> "0d" <> "01" <> "0002a300"+        <> "655b14db" <> "6551c9f3" <> "acbe"+        <> "076578616d706c65036f726700"+        <> sighex+      )+    , ( mkRR zone $ T_NSEC $$(dnLit8 "*.example.org") [ NS, SOA, DNSKEY, NSEC+                                                    , RRSIG, CAA ]+      , "example.org. 300 IN NSEC *.example.org. NS SOA RRSIG NSEC DNSKEY CAA"+      , "076578616d706c65036f726700"+        <> "002f" <> "0001" <> "0000012c" <> "001b"+        <> "012a076578616d706c65036f726700"+        <> "000722000000000380010140"+      )+    , ( mkRR zone $ T_DNSKEY 257 3 13 keybytes+      , "example.org. 300 IN DNSKEY 257 3 13 " <> keychars+      , "076578616d706c65036f726700"+        <> "0030" <> "0001" <> "0000012c" <> "0044"+        <> "0101" <> "03" <> "0d" <> keyhex+      )+    , ( mkRR zone $ T_NSEC3 1 0 0 nsec3salt nsec3next [ NS, SOA, MX, TXT, DNSKEY+                                                     , NSEC, RRSIG, CAA ]+      , "example.org. 300 IN NSEC3 1 0 0 " <> saltchars <> " "+        <> nextchars <> " NS SOA MX TXT RRSIG NSEC DNSKEY CAA"+      , "076578616d706c65036f726700"+        <> "0032" <> "0001" <> "0000012c" <> "002a"+        <> "01" <> "00" <> "0000" <> salthex+        <> nexthex+        <> "000722018000000380010140"+      )+    , ( mkRR zone $ T_NSEC3PARAM 1 0 0 ""+      , "example.org. 300 IN NSEC3PARAM 1 0 0 -"+      , "076578616d706c65036f726700"+        <> "0033" <> "0001" <> "0000012c" <> "0005"+        <> "01" <> "00" <> "0000" <> "00"+      )+    , ( mkRR zone $ T_TLSA 3 1 1 tlsabytes+      , "example.org. 300 IN TLSA 3 1 1 " <> tlsachars+      , "076578616d706c65036f726700"+        <> "0034" <> "0001" <> "0000012c" <> "0023"+        <> "03" <> "01" <> "01" <> tlsahex+      )+    , ( mkRR zone $ T_SMIMEA 3 1 1 tlsabytes+      , "example.org. 300 IN SMIMEA 3 1 1 " <> tlsachars+      , "076578616d706c65036f726700"+        <> "0035" <> "0001" <> "0000012c" <> "0023"+        <> "03" <> "01" <> "01" <> tlsahex+      )+    , ( mkRR zone $ T_CDS 0 0 0 (coerce @Bytes16 "00")+      , "example.org. 300 IN CDS 0 0 0 00"+      , "076578616d706c65036f726700"+        <> "003b" <> "0001" <> "0000012c" <> "0005"+        <> "0000" <> "00" <> "00" <> "00"+      )+    , ( mkRR zone $ T_CDNSKEY 0 3 0 (coerce @Bytes64 "AA==")+      , "example.org. 300 IN CDNSKEY 0 3 0 AA=="+      , "076578616d706c65036f726700"+        <> "003c" <> "0001" <> "0000012c" <> "0005"+        <> "0000" <> "03" <> "00" <> "00"+      )+    , ( mkRR zone $ T_OPENPGPKEY (coerce @Bytes64 "AA==")+      , "example.org. 300 IN OPENPGPKEY AA=="+      , "076578616d706c65036f726700"+        <> "003d" <> "0001" <> "0000012c" <> "0001"+        <> "00"+      )+    , ( mkRR zone $ T_CSYNC 66 3 [ A, NS, AAAA ]+      , "example.org. 300 IN CSYNC 66 3 A NS AAAA"+      , "076578616d706c65036f726700"+        <> "003e" <> "0001" <> "0000012c" <> "000c"+        <> "00000042" <> "0003" <> "000460000008"+      )+    , ( mkRR zone $ T_DSYNC CDS NOTIFY 5353 $$(dnLit8 "se")+      , "example.org. 300 IN DSYNC CDS NOTIFY 5353 se."+      , "076578616d706c65036f726700"+        <> "0042" <> "0001" <> "0000012c" <> "0009"+        <> "003b" <> "01" <> "14e9" <> "02736500"+      )+    , ( mkRR zone $ T_DSYNC 1024 42 5353 $$(dnLit8 "com")+      , "example.org. 300 IN DSYNC TYPE1024 42 5353 com."+      , "076578616d706c65036f726700"+        <> "0042" <> "0001" <> "0000012c" <> "000a"+        <> "0400" <> "2a" <> "14e9" <> "03636f6d00"+      )+    , ( mkRR zone $ T_ZONEMD 2023111301 1 241 zmdbytes+      , "example.org. 300 IN ZONEMD 2023111301 1 241 " <> zmdchars+      , "076578616d706c65036f726700"+        <> "003f" <> "0001" <> "0000012c" <> "0036"+        <> "78963a85" <> "01" <> "f1" <> zmdhex+      )+    , ( mkRR zone $ T_SVCB 0 $$(dnLit8 "www.example.org") []+      , "example.org. 300 IN SVCB 0 www.example.org."+      , "076578616d706c65036f726700"+        <> "0040" <> "0001" <> "0000012c" <> "0013"+        <> "0000" <> "03777777076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_SVCB 1 RootDomain []+      , "example.org. 300 IN SVCB 1 ."+      , "076578616d706c65036f726700"+        <> "0040" <> "0001" <> "0000012c" <> "0003"+        <> "0001" <> "00"+      )+    , ( mkRR zone $ T_SVCB 1 $$(dnLit8 "www.example.org")+                    [ SVCParamValue $ SPV_IPV6HINT $ ne ["2001:db8::1", "2001:db8::53:1"] ]+      , "example.org. 300 IN SVCB 1 www.example.org. ipv6hint=2001:db8::1,2001:db8::53:1"+      , "076578616d706c65036f726700"+        <> "0040" <> "0001" <> "0000012c" <> "0037"+        <> "0001" <> "03777777076578616d706c65036f726700"+        <> "0006" <> "0020" <> "20010db8000000000000000000000001"+                            <> "20010db8000000000000000000530001"+      )+    , ( mkRR zone $ T_SVCB 1 $$(dnLit8 "www.example.org")+                    [ opaqueSPV 667 "" ]+      , "example.org. 300 IN SVCB 1 www.example.org. key667"+      , "076578616d706c65036f726700"+        <> "0040" <> "0001" <> "0000012c" <> "0017"+        <> "0001" <> "03777777076578616d706c65036f726700"+        <> "029b" <> "0000"+      )+    , ( mkRR zone $ T_SVCB 1 $$(dnLit8 "www.example.org")+                    [ opaqueSPV 667 "hello" ]+      , "example.org. 300 IN SVCB 1 www.example.org. key667=\"hello\""+      , "076578616d706c65036f726700"+        <> "0040" <> "0001" <> "0000012c" <> "001c"+        <> "0001" <> "03777777076578616d706c65036f726700"+        <> "029b" <> "0005" <> "68656c6c6f"+      )+    , ( mkRR zone $ T_HTTPS 1 $$(dnLit8 "www.example.org")+                    [ opaqueSPV 667 "hello\210\&qoo" ]+      , "example.org. 300 IN HTTPS 1 www.example.org. key667=\"hello\\210qoo\""+      , "076578616d706c65036f726700"+        <> "0041" <> "0001" <> "0000012c" <> "0020"+        <> "0001" <> "03777777076578616d706c65036f726700"+        <> "029b" <> "0009" <> "68656c6c6fd2716f6f"+      )+    , ( mkRR zone $ T_HTTPS 16 $$(dnLit8 "www.example.org")+                    [ SVCParamValue $ SPV_ALPN $ ne ["f\\oo,bar", "h2"] ]+      , "example.org. 300 IN HTTPS 16 www.example.org. alpn=" <> alpn1+      , "076578616d706c65036f726700"+        <> "0041" <> "0001" <> "0000012c" <> "0023"+        <> "0010" <> "03777777076578616d706c65036f726700"+        <> "0001" <> "000c" <> "08" <> "665c6f6f2c626172"+                            <> "02" <> "6832"+      )+    , ( mkRR zone $ T_HTTPS 16 $$(dnLit8 "www.example.org")+                    [ SVCParamValue $ SPV_ALPN $ ne ["f\\oo,bar\"", "h2"] ]+      , "example.org. 300 IN HTTPS 16 www.example.org. alpn=" <> alpn2+      , "076578616d706c65036f726700"+        <> "0041" <> "0001" <> "0000012c" <> "0024"+        <> "0010" <> "03777777076578616d706c65036f726700"+        <> "0001" <> "000d" <> "09" <> "665c6f6f2c62617222"+                            <> "02" <> "6832"+      )+    , ( mkRR zone $ T_HTTPS 16 $$(dnLit8 "www.example.org")+                    [ SVCParamValue $ ne @SPV_mandatory [ALPN, IPV4HINT]+                    , SVCParamValue $ SPV_ALPN $ ne ["h2", "h3-19"]+                    , SVCParamValue $ SPV_IPV4HINT $ ne ["192.0.2.1"] ]+      , "example.org. 300 IN HTTPS 16 www.example.org."+         <> " mandatory=alpn,ipv4hint"+         <> " alpn=\"h2,h3-19\""+         <> " ipv4hint=192.0.2.1"+      , "076578616d706c65036f726700"+        <> "0041" <> "0001" <> "0000012c" <> "0030"+        <> "0010" <> "03777777076578616d706c65036f726700"+        <> "0000" <> "0004" <> "0001" <> "0004"+        <> "0001" <> "0009" <> "02" <> "6832"+                            <> "05" <> "68332d3139"+        <> "0004" <> "0004" <> "c0000201"+      )+    , ( mkRR zone $ T_HTTPS 16 $$(dnLit8 "www.example.org")+                    [ SVCParamValue $ SPV_PORT 53 ]+      , "example.org. 300 IN HTTPS 16 www.example.org. port=53"+      , "076578616d706c65036f726700"+        <> "0041" <> "0001" <> "0000012c" <> "0019"+        <> "0010" <> "03777777076578616d706c65036f726700"+        <> "0003" <> "0002" <> "0035"+      )+    , ( mkRR zone $ T_NID 42 0xfeedcafedeadbeef+      , "example.org. 300 IN NID 42 feed:cafe:dead:beef"+      , "076578616d706c65036f726700"+        <> "0068" <> "0001" <> "0000012c" <> "000a"+        <> "002a" <> "feedcafedeadbeef"+      )+    , ( mkRR zone $ T_L32 42 "192.0.2.1"+      , "example.org. 300 IN L32 42 192.0.2.1"+      , "076578616d706c65036f726700"+        <> "0069" <> "0001" <> "0000012c" <> "0006"+        <> "002a" <> "c0000201"+      )+    , ( mkRR zone $ T_L64 42 0xdeadbeeffeedcafe+      , "example.org. 300 IN L64 42 dead:beef:feed:cafe"+      , "076578616d706c65036f726700"+        <> "006a" <> "0001" <> "0000012c" <> "000a"+        <> "002a" <> "deadbeeffeedcafe"+      )+    , ( mkRR zone $ T_LP 42 $$(dnLit8 "www.example.org")+      , "example.org. 300 IN LP 42 www.example.org."+      , "076578616d706c65036f726700"+        <> "006b" <> "0001" <> "0000012c" <> "0013"+        <> "002a" <> "03777777076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_AMTRELAY 255 False Amt_Nil+      , "example.org. 300 IN AMTRELAY 255 0 0 ."+      , "076578616d706c65036f726700"+        <> "0104" <> "0001" <> "0000012c" <> "0002"+        <> "ff00"+      )+    , ( mkRR zone $ T_AMTRELAY 0 False (Amt_A "192.0.2.1")+      , "example.org. 300 IN AMTRELAY 0 0 1 192.0.2.1"+      , "076578616d706c65036f726700"+        <> "0104" <> "0001" <> "0000012c" <> "0006"+        <> "0001" <> "c0000201"+      )+    , ( mkRR zone $ T_AMTRELAY 0 True (Amt_AAAA "2001:db8::1")+      , "example.org. 300 IN AMTRELAY 0 1 2 2001:db8::1"+      , "076578616d706c65036f726700"+        <> "0104" <> "0001" <> "0000012c" <> "0012"+        <> "0082" <> "20010db8000000000000000000000001"+      )+    , ( mkRR zone $ T_AMTRELAY 42 True (Amt_Host $ toHost $$(dnLit8 "www.example.org"))+      , "example.org. 300 IN AMTRELAY 42 1 3 www.example.org."+      , "076578616d706c65036f726700"+        <> "0104" <> "0001" <> "0000012c" <> "0013"+        <> "2a83" <> "03777777076578616d706c65036f726700"+      )+    , ( mkRR zone $ T_AMTRELAY 128 True (Amt_Opaque 4 (coerce @Bytes16 "deadbeef"))+      , "example.org. 300 IN AMTRELAY \\# 6 8084deadbeef"+      , "076578616d706c65036f726700"+        <> "0104" <> "0001" <> "0000012c" <> "0006"+        <> "8084" <> "deadbeef"+      )+    , ( mkRR zone $ OpaqueRData @N_a $ coerce @Bytes16 "feedcafe"+      , "example.org. 300 IN TYPE1 \\# 4 feedcafe"+      , "076578616d706c65036f726700"+        <> "0001" <> "0001" <> "0000012c" <> "0004"+        <> "feedcafe"+      )+    ]+  where+    ne :: IsNonEmptyList i => [Item1 i] -> i+    ne = fromNonEmptyList . fromList++    b, c, d :: String+    b = ['\\']+    c = b <> ","+    d = ['"']+    alpn1, alpn2 :: LC.ByteString+    alpn1 = LC.pack . show $ "f" <> b <> b <> "oo" <> c <> "bar,h2"+    alpn2 = LC.pack . show $ "f" <> b <> b <> "oo" <> c <> "bar" <> d <> ",h2"++    zone :: Domain+    zone = $$(dnLit8 "example.org")++    mkRR :: KnownRData a => Domain -> a -> RR+    mkRR = \ owner -> RR owner IN 300 . RData++    gwkeybytes :: ShortByteString+    gwkeybytes = coerce @Bytes16 "feedcafedeadbeef"+    gwkeyhex :: Bytes16+    gwkeyhex = "feedcafedeadbeef"+    gwkeychars :: LC.ByteString+    gwkeychars = "feedcafedeadbeef"++    salthex :: Bytes16+    salthex = "04" <> "feedcafe"+    nsec3salt :: ShortByteString+    nsec3salt = coerce @Bytes16 "feedcafe"+    saltchars :: LC.ByteString+    saltchars = "feedcafe"++    nexthex :: Bytes16+    nexthex = "14" <> "ada6735ee74b256dfcb46cc81c61f35c637c3160"+    nsec3next :: ShortByteString+    nsec3next = coerce @Bytes32 "LMJ76NN79CIMRV5KDJ41OOFJBHHNOCB0"+    nextchars :: LC.ByteString+    nextchars = "LMJ76NN79CIMRV5KDJ41OOFJBHHNOCB0"++    shahex   :: Bytes16+    shahex   = "2f0bec2d6f79dfbd1d08fd21a3af92d0e39a4b9ef1e3f4111fff282490da453b"+    shabytes :: ShortByteString+    shabytes = coerce @Bytes16 shahex+    shachars :: LC.ByteString+    shachars = "2f0bec2d6f79dfbd1d08fd21a3af92d0e39a4b9ef1e3f4111fff282490da453b"++    keyhex :: Bytes16+    keyhex = "1e20681a9cc344082b0e65175d34a797b8c25fa1f1e5bce45368d2c4c6d5234d" <>+             "724bed771323a08670a27415d4d1b1f6822db0f4685819a72953a0abb70a0536"+    keybytes :: ShortByteString+    keybytes = coerce @Bytes64+        $ "HiBoGpzDRAgrDmUXXTSnl7jCX6Hx5bzkU2jSxMbVI01yS+13" <>+          "EyOghnCidBXU0bH2gi2w9GhYGacpU6CrtwoFNg=="+    keychars :: LC.ByteString+    keychars = "HiBoGpzDRAgrDmUXXTSnl7jCX6Hx5bzkU2jSxMbVI01yS+13" <>+               "EyOghnCidBXU0bH2gi2w9GhYGacpU6CrtwoFNg=="++    sighex :: Bytes16+    sighex = "dd93289363854f0be4afd91bfd9ea5bd39789026606cda627c430a8745afb23c" <>+             "770aeac68fff8aa6c1d3f122f3db0a6efae39dfc128fa743babb860ae631104f"+    sigbytes :: ShortByteString+    sigbytes = coerce @Bytes64+        $ "3ZMok2OFTwvkr9kb/Z6lvTl4kCZgbNpifEMKh0Wvsjx3CurG" <>+          "j/+KpsHT8SLz2wpu+uOd/BKPp0O6u4YK5jEQTw=="+    sigchars :: LC.ByteString+    sigchars = "3ZMok2OFTwvkr9kb/Z6lvTl4kCZgbNpifEMKh0Wvsjx3CurG" <>+               "j/+KpsHT8SLz2wpu+uOd/BKPp0O6u4YK5jEQTw=="++    zmdhex :: Bytes16+    zmdhex =  "eda3998fa398b08b47fbde1f2c0c241d3efddafc31b3a776" <>+              "067d05fcef904643c36553dcf6102c5d0104f78dc0ed8e22"+    zmdbytes :: ShortByteString+    zmdbytes = coerce @Bytes16 zmdhex+    zmdchars :: LC.ByteString+    zmdchars = "eda3998fa398b08b47fbde1f2c0c241d3efddafc31b3a776" <>+               "067d05fcef904643c36553dcf6102c5d0104f78dc0ed8e22"++    tlsahex :: Bytes16+    tlsahex = "a0435521ac1be0ff6a734874bb489a1ce223a67a1049e7b927ddfd431fd850f5"+    tlsabytes :: ShortByteString+    tlsabytes = coerce @Bytes16 tlsahex+    tlsachars :: LC.ByteString+    tlsachars = "a0435521ac1be0ff6a734874bb489a1ce223a67a1049e7b927ddfd431fd850f5"++    sshkeybytes :: ShortByteString+    sshkeybytes  = coerce @Bytes16 "7d52bf15ec9445b5dba496d71f8ddf106b4b7265f4e166fb2c7d4b7831393d77"+    sshkeychars :: LC.ByteString+    sshkeychars  = "7d52bf15ec9445b5dba496d71f8ddf106b4b7265f4e166fb2c7d4b7831393d77"+    sshkeyhex   :: Bytes16+    sshkeyhex    = "7d52bf15ec9445b5dba496d71f8ddf106b4b7265f4e166fb2c7d4b7831393d77"++-----++testUtf8 :: TestTree+testUtf8 = testProperty "Text length matches Utf8 length" $+    forAllShow genText show $ \t ->+        LB.length (B.toLazyByteString (T.encodeUtf8Builder t)) ==+            fromIntegral (T.lengthWord8 t)++-----++boo :: Domain+boo = $$(dnLit8 "boo.example.com")++testRData :: RDataMap -> RRTYPE -> Gen RData -> TestTree+testRData dm ty gen = testProperty (presentString ty " codec round-trip") $+    forAllShow gen (flip presentString mempty) \ rd ->+        let rr = RR boo IN 0 rd+         in case encodeVerbatim $ putRR rr of+                 Left _    -> error "encoding didn't work"+                 Right enc -> case decodeAtWith 0 False (getRR dm Nothing) enc of+                     Left  err -> error $ show err ++ ": " ++ show @Bytes16 (coerce $ SB.toShort enc)+                     Right dec | dec == rr -> True+                               | otherwise -> error $ "got:\t" ++ presentString dec mempty++testCnEq :: RDataMap -> RRTYPE -> Gen RData -> TestTree+testCnEq dm ty gen = testProperty (presentString ty " canonical equality") $+    forAllShow gen (flip presentString mempty) \ rd ->+        case rdataType rd of+            SIG   -> True+            RRSIG -> True+            RRTYPE t | (RData a) <- rd+                     , Right enc <- encodeCompressed $ cnEncode a+                     , len <- B.length enc+                     , Right dec <- decodeAtWith 0 False (getRData dm Nothing t len) enc+                         -> rd == dec+                     | otherwise -> False++-----++testCnOrd :: RRTYPE -> Gen RData -> TestTree+testCnOrd ty gen = testProperty (presentString ty " canonical order") $+    forAllShow gen2 (\ (r1, r2) -> presentString r1 ('\n' : presentString r2 mempty)) \ (rd1, rd2) ->+        case rdataType rd1 of+            SIG   -> True+            RRSIG -> True+            _ | Right enc1 <- encodeCompressed $ rdataEncodeCanonical rd1+              , Right enc2 <- encodeCompressed $ rdataEncodeCanonical rd2+                -> (rd1 `compare` rd2) == (enc1 `compare` enc2)+              | otherwise -> False+  where+    gen2 = (,) <$> gen <*> gen++-----++testOption :: RDataMap+           -> OptionMap+           -> OptNum+           -> (OptionMap -> Gen EdnsOption)+           -> TestTree+testOption dm om onum gen = testProperty (presentString onum " EDNS option codec") $+    forAllShow (gen om) (flip presentString mempty) \ opt ->+        case encodeVerbatim $ encode opt of+            Left _    -> error "encoding didn't work"+            Right buf ->+                case decodeAtWith 0 False (getMessage dm om) buf of+                     Left  err -> error $ show err+                     Right msg+                        | fmap ednsOptions (dnsMsgEx msg) == Just [opt] -> True+                        | otherwise -> False+  where+    encode opt = putRequest 0 mempty (Just edns) q+       where+         q = DnsTriple RootDomain SOA IN+         edns = EDNS 1 1400 [opt]++-----++genText :: Gen T.Text+genText = T.pack <$> listOf arbitrary++genA :: Gen RData+genA = RData . T_A <$> genIPv4++genNS, genMD, genMF, genCNAME, genMB, genMG, genMR :: Gen RData+genNS    = RData . T_NS <$> genDomain+genMD    = RData . T_MD <$> genDomain+genMF    = RData . T_MF <$> genDomain+genCNAME = RData . T_CNAME <$> genDomain+genMB    = RData . T_MB <$> genDomain+genMG    = RData . T_MG <$> genDomain+genMR    = RData . T_MR <$> genDomain++genSOA :: Gen RData+genSOA = RData <$.> T_SOA <$> genDomain+                          <*> genMbox+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> arbitrary++genNULL :: Gen RData+genNULL = RData . T_NULL . coerce <$> genShortByteString++genWKS :: Gen RData+genWKS = do+    wksAddr4 <- genIPv4+    wksProto <- elements [UDP, TCP]+    wksPorts <- fromList <$> listOf arbitrary+    pure $ RData T_WKS{..}++genPTR :: Gen RData+genPTR = RData . T_PTR <$> genDomain++genHINFO :: Gen RData+genHINFO = RData <$.> T_HINFO <$> genCharString <*> genCharString++genMINFO :: Gen RData+genMINFO = RData <$.> T_MINFO <$> genDomain <*> genDomain++genMX :: Gen RData+genMX = RData <$.> T_MX <$> arbitrary <*> genDomain++genTXT :: Gen RData+genTXT = RData . T_TXT <$> genCharStrings+  where+    genCharStrings :: Gen (NonEmpty ShortByteString)+    genCharStrings = (:|) <$> genCharString <*> listOf genCharString++genRP :: Gen RData+genRP = RData <$.> T_RP <$> genDomain <*> genDomain++genAFSDB :: Gen RData+genAFSDB = RData <$.> T_AFSDB <$> arbitrary <*> genDomain++genX25 :: Gen RData+genX25 = RData . T_X25 <$> genDigits+  where+    -- Digit string of at least 4 bytes+    genDigits :: Gen ShortByteString+    genDigits = sized \n -> do+        k <- choose (4, min 255 n)+        SB.pack <$> vectorOf k (elements [0x30..0x39])++genISDN :: Gen RData+genISDN = do+    address <- genCharString+    ddi <- listToMaybe <$> do+        k <- choose (0,1)+        vectorOf k genCharString+    pure $ RData $ T_ISDN address ddi++genRT :: Gen RData+genRT = RData <$.> T_RT <$> arbitrary <*> genDomain++genNSAP :: Gen RData+genNSAP = RData . T_NSAP <$> genCharString++genNSAPPTR :: Gen RData+genNSAPPTR = RData . T_NSAPPTR <$> genDomain++genPX :: Gen RData+genPX = RData <$.> T_PX <$> arbitrary <*> genDomain <*> genDomain++genGPOS :: Gen RData+genGPOS = RData <$.> T_GPOS <$> genCharString <*> genCharString <*> genCharString++genAAAA :: Gen RData+genAAAA = RData . T_AAAA <$> genIPv6++genNXT :: Gen RData+genNXT = do+    nxtNext <- genDomain+    nxtBits <- toNxtTypes . (NXT :|) <$> listOf genRT7+    pure $ RData T_NXT{..}+  where+    genRT7 :: Gen RRTYPE+    genRT7 = RRTYPE <$> chooseBoundedIntegral (1,127)++genSRV :: Gen RData+genSRV = RData <$.> T_SRV <$> arbitrary+                          <*> arbitrary+                          <*> arbitrary+                          <*> genDomain++genNAPTR :: Gen RData+genNAPTR = RData <$.> T_NAPTR <$> arbitrary+                              <*> arbitrary+                              <*> genCharString+                              <*> genCharString+                              <*> genCharString+                              <*> genDomain++genKX :: Gen RData+genKX = RData <$.> T_KX <$> arbitrary <*> genDomain++genA6 :: Gen RData+genA6 = do+    a6 <- T_A6 <$> choose (0, 127) <*> genIPv6 <*> gend+    pure $ RData a6+  where+    gend = Just <$> genDomain++genDNAME :: Gen RData+genDNAME = RData . T_DNAME <$> genDomain++----++_genXDS :: forall (n :: Nat). Nat16 n => Gen (X_ds n)+_genXDS =+  X_DS <$> arbitrary+       <*> (DNSKEYAlg <$> arbitrary)+       <*> (DSHashAlg <$> arbitrary)+       <*> genShortByteString++genDS :: Gen RData+genDS = RData <$> (_genXDS :: Gen T_ds)++genCDS :: Gen RData+genCDS = RData <$> (_genXDS :: Gen T_cds)++genSSHFP :: Gen RData+genSSHFP = RData <$.> T_SSHFP <$> arbitrary+                              <*> arbitrary+                              <*> genShortByteString++genIPSECKEY :: Gen RData+genIPSECKEY = do+    p <- arbitrary+    t <- elements [0..5]+    a <- arbitrary+    case t of+        0 -> pure IPSecKeyGWX                   >>= go p t a genShortByteString+        1 -> IPSecKeyGW4 <$> genIPv4            >>= go p t a genShortByteString+        2 -> IPSecKeyGW6 <$> genIPv6            >>= go p t a genShortByteString+        3 -> IPSecKeyGWD <$> genDomain          >>= go p t a genShortByteString+        _ -> IPSecKeyGWG <$> genShortByteString >>= go p t a (pure mempty)+  where+    go p t a gen g = RData . IPSecKey p t a g <$> gen++_genXSIG :: forall (n :: Nat). Nat16 n => Gen (X_sig n)+_genXSIG =+  X_SIG <$> genRRTYPE+        <*> (DNSKEYAlg <$> arbitrary)+        <*> arbitrary+        <*> arbitrary+        <*> (fromIntegral <$> arbitrary @Int32)+        <*> (fromIntegral <$> arbitrary @Int32)+        <*> arbitrary+        <*> genDomain+        <*> genShortByteString++genSIG :: Gen RData+genSIG = RData <$> (_genXSIG :: Gen T_sig)++genRRSIG :: Gen RData+genRRSIG = RData <$> (_genXSIG :: Gen T_rrsig)++_genXKEY :: forall (n :: Nat). Nat16 n => Gen (X_key n)+_genXKEY =+  X_KEY <$> arbitrary+        <*> arbitrary+        <*> (DNSKEYAlg <$> arbitrary)+        <*> genShortByteString++genKEY :: Gen RData+genKEY = RData <$> (_genXKEY :: Gen T_key)++genDNSKEY :: Gen RData+genDNSKEY = RData <$> (_genXKEY :: Gen T_dnskey)++genCDNSKEY :: Gen RData+genCDNSKEY = RData <$> (_genXKEY :: Gen T_cdnskey)++genNSEC :: Gen RData+genNSEC = RData <$.> T_NSEC <$> genDomain <*> genNsecTypes++genNSEC3 :: Gen RData+genNSEC3 = RData <$.> T_NSEC3 <$> (NSEC3HashAlg <$> arbitrary)+                              <*> arbitrary+                              <*> arbitrary+                              <*> genCharString+                              <*> genCharString+                              <*> genNsecTypes++genNSEC3PARAM :: Gen RData+genNSEC3PARAM = RData <$.> T_NSEC3PARAM <$> (NSEC3HashAlg <$> arbitrary)+                                        <*> arbitrary+                                        <*> arbitrary+                                        <*> genCharString++_genTLSA :: forall (n :: Nat). Nat16 n => Gen (X_tlsa n)+_genTLSA = X_TLSA <$> arbitrary+                  <*> arbitrary+                  <*> arbitrary+                  <*> genShortByteString++genTLSA :: Gen RData+genTLSA = RData <$> (_genTLSA :: Gen T_tlsa)++genSMIMEA :: Gen RData+genSMIMEA = RData <$> (_genTLSA :: Gen T_smimea)++genOPENPGPKEY :: Gen RData+genOPENPGPKEY = RData <$.> T_OPENPGPKEY <$> genShortByteString++genZONEMD :: Gen RData+genZONEMD = RData <$.> T_ZONEMD <$> arbitrary+                                <*> arbitrary+                                <*> arbitrary+                                <*> genDigest+  where+    genDigest :: Gen ShortByteString+    genDigest = sized \n -> do+        k <- choose (12, max 12 n)+        SB.pack <$> vectorOf k arbitrary++genSVCB :: Gen RData+genSVCB = RData <$.> T_SVCB <$> arbitrary <*> genDomain <*> genSVCParamValues++genHTTPS :: Gen RData+genHTTPS = RData <$.> T_HTTPS <$> arbitrary <*> genDomain <*> genSVCParamValues++genCAA :: Gen RData+genCAA = RData <$.> T_CAA <$> arbitrary <*> genTag <*> genShortByteString+  where+    genTag :: Gen ShortByteString+    genTag = sized \n -> do+        k <- choose (1, min 255 $ max 1 n)+        SB.pack <$> vectorOf k genld+    genld :: Gen Word8+    genld = elements $ filter isalnum [0..255]++genAMTRELAY :: Gen RData+genAMTRELAY = RData <$.> T_AMTRELAY <$> arbitrary <*> arbitrary <*> genAmtRelay+  where+    genAmtRelay :: Gen AmtRelay+    genAmtRelay = do+        (t :: Int) <- choose (0, 4)+        case t of+            0 -> pure Amt_Nil+            1 -> Amt_A <$> genIPv4+            2 -> Amt_AAAA <$> genIPv6+            3 -> Amt_Host . toHost <$> genDomain+            _ -> Amt_Opaque <$> choose(4, 127) <*> genShortByteStringMinLen 1++genCSYNC :: Gen RData+genCSYNC = RData <$.> T_CSYNC <$> arbitrary <*> arbitrary <*> genNsecTypes++genDSYNC :: Gen RData+genDSYNC = RData <$.> T_DSYNC <$> genRRTYPE+                              <*> (DSCHEME <$> arbitrary)+                              <*> arbitrary+                              <*> genDomain++genNID :: Gen RData+genNID = RData <$.> T_NID <$> arbitrary <*> arbitrary++genL32 :: Gen RData+genL32 = RData <$.> T_L32 <$> arbitrary <*> genIPv4++genL64 :: Gen RData+genL64 = RData <$.> T_L64 <$> arbitrary <*> arbitrary++genLP :: Gen RData+genLP = RData <$.> T_LP <$> arbitrary <*> genDomain++genOpaque :: Word16 -> Gen RData+genOpaque w = opaqueRData w <$> genShortByteString++----++genDAU, genDHU, genN3U :: OptionMap -> Gen EdnsOption+genDAU _ = EdnsOption . O_DAU <$> listOf (DNSKEYAlg <$> arbitrary)+genDHU _ = EdnsOption . O_DHU <$> listOf (DSHashAlg <$> arbitrary)+genN3U _ = EdnsOption . O_N3U <$> listOf (NSEC3HashAlg <$> arbitrary)++genECS :: OptionMap -> Gen EdnsOption+genECS _ = oneof [ EdnsOption <$> genECSv4, EdnsOption <$> genECSv6 ]+  where+    genECSv4 :: Gen O_ecs+    genECSv4 = do+        src <- genPL+        scp <- genPL+        ip  <- genIPv4+        let mip = maskIPv4 ip src+        return $ O_ECS src scp (IPv4 mip)+      where+        genPL = chooseBoundedIntegral (0, 32)+        maskIPv4 i n = masked i (intToMask $ fromIntegral n)+    genECSv6 :: Gen O_ecs+    genECSv6 = do+        src <- genPL+        scp <- genPL+        ip <- genIPv6+        let mip = maskIPv6 ip src+        return $ O_ECS src scp (IPv6 mip)+      where+        genPL = chooseBoundedIntegral (0, 128)+        maskIPv6 i n = masked i (intToMask $ fromIntegral n)++genNSID :: OptionMap -> Gen EdnsOption+genNSID _ = EdnsOption . O_NSID <$> genShortByteString++-- The wire form for EDE carries only the info-code and the extra+-- text; the friendly @edeName@ is re-injected at decode time from+-- the resolver's name registry (defaulting to 'baseEdeNames').  So+-- a round-trip generator must compute the same lookup the decoder+-- will perform, otherwise the round-tripped value will disagree on+-- the name slot.+genEDE :: OptionMap -> Gen EdnsOption+genEDE (IM.lookup (fromIntegral EDE) -> optcodec) =+    arbitrary >>= \ code -> do+        let name = getName code optcodec+        text <- genShortByteString+        pure $ EdnsOption $ O_EDE code name text+  where+    getName :: Word16 -> Maybe OptionCodec -> ShortByteString+    getName (fromIntegral -> code)+            (Just (OptionCodec (_ :: Proxy b) (v :: OptionExtensionVal b))) =+        case eqT @O_ede @b of+            Just Refl -> IM.findWithDefault mempty code v+            Nothing   -> mempty+    getName _ _ = mempty++genOpaqueOpt :: OptionMap -> Gen EdnsOption+genOpaqueOpt _ =+    opaqueEdnsOption <$> chooseBoundedIntegral (65001,65534)+                     <*> genShortByteString++-- low-level generators for parameter types++genSVCParamValues :: Gen SPVSet+genSVCParamValues = fromList <$> genList+  where+    genList = join $ sequence <$>+        sublistOf [ genMANDATORY+                  , genALPN+                  , genNDALPN+                  , genPORT+                  , genIPV4HINT+                  , genECH+                  , genIPV6HINT+                  , genDOHPATH+                  , genTLSGROUPS+                  , genDOCPATH+                  , genPVD+                  , genOpaqueSPV+                  ]++    genMANDATORY :: Gen SVCParamValue+    genMANDATORY =+        SVCParamValue . fromNonEmptyList @SPV_mandatory <$> genSVCParamKeys+      where+        genSVCParamKeys :: Gen (NonEmpty SVCParamKey)+        genSVCParamKeys = listOf' $ SVCParamKey <$> arbitrary++    genALPN :: Gen SVCParamValue+    genALPN = SVCParamValue . SPV_ALPN <$> listOf' genCharString++    genNDALPN :: Gen SVCParamValue+    genNDALPN = pure $ SVCParamValue SPV_NDALPN++    genPORT :: Gen SVCParamValue+    genPORT = SVCParamValue . SPV_PORT <$> arbitrary++    genIPV4HINT :: Gen SVCParamValue+    genIPV4HINT = SVCParamValue . SPV_IPV4HINT <$> listOf' genIPv4++    genIPV6HINT :: Gen SVCParamValue+    genIPV6HINT = SVCParamValue . SPV_IPV6HINT <$> listOf' genIPv6++    genECH :: Gen SVCParamValue+    genECH = SVCParamValue . SPV_ECH <$> genShortByteStringMinLen 4++    genDOHPATH :: Gen SVCParamValue+    genDOHPATH = SVCParamValue . SPV_DOHPATH <$> genText++    genDOCPATH :: Gen SVCParamValue+    genDOCPATH = SVCParamValue . SPV_DOCPATH <$> listOf genDocpathSegment+      where+        -- Per RFC 9953 ABNF: each segment is 1..255 octets.+        genDocpathSegment :: Gen ShortByteString+        genDocpathSegment = sized \n -> do+            k <- choose (1, max 1 (min 255 n))+            SB.pack <$> vectorOf k arbitrary++    -- Non-empty list of Word16 group codepoints.  The codec does not+    -- enforce dedup, so any duplicates the generator produces will+    -- round-trip verbatim; the spec-level "no duplicates" rule is on+    -- the caller, not the wire codec.+    genTLSGROUPS :: Gen SVCParamValue+    genTLSGROUPS = SVCParamValue . SPV_TLSGROUPS <$> listOf' arbitrary++    genPVD :: Gen SVCParamValue+    genPVD = pure $ SVCParamValue SPV_PVD++    genOpaqueSPV :: Gen SVCParamValue+    genOpaqueSPV = opaqueSPV <$> chooseBoundedIntegral (65280,65534) <*> genShortByteString++uniqueOrdList :: (Ord a, Arbitrary a) => Gen [a]+uniqueOrdList = dedup <$> orderedList++dedup :: Ord a => [a] -> [a]+dedup [] = []+dedup (a:as) = a : go a as+  where+    go _ [] = []+    go x (y:ys)+      | x < y = y : go y ys+      | otherwise = go x ys++listOf' :: Gen a -> Gen (NonEmpty a)+listOf' g = nonEmpty g (listOf g)++nonEmpty :: Gen a -> Gen [a] -> Gen (NonEmpty a)+nonEmpty g gs = (:|) <$> g <*> gs++isalnum :: Word8 -> Bool+isalnum w = w - 0x30 < 10 || w .&. 0xdf - 0x41 < 26++genNsecTypes :: Gen NsecTypes+genNsecTypes = fromList <$> listOf genRRTYPE++genRRTYPE :: Gen RRTYPE+genRRTYPE = RRTYPE <$> arbitrary++genIPv4 :: Gen IPv4+genIPv4 = toIPv4w <$> arbitrary++genIPv6 :: Gen IPv6+genIPv6 = toIPv6w <$> arbitrary++genByteString :: Gen ByteString+genByteString = B.pack <$> listOf (arbitrary :: Gen Word8)++genShortByteString :: Gen ShortByteString+genShortByteString = SB.pack <$> listOf (arbitrary :: Gen Word8)++genByteStringMinLen :: Int -> Gen ByteString+genByteStringMinLen 0 = genByteString+genByteStringMinLen n = do+    mx <- max n <$> getSize+    l  <- chooseInt (n,mx)+    B.pack <$> vectorOf l (arbitrary @Word8)++genShortByteStringMinLen :: Int -> Gen ShortByteString+genShortByteStringMinLen 0 = genShortByteString+genShortByteStringMinLen n = do+    mx <- max n <$> getSize+    l  <- chooseInt (n,mx)+    SB.pack <$> vectorOf l (arbitrary @Word8)++-- | DNS /character-string/ of at most 255 bytes+genCharString :: Gen ShortByteString+genCharString = sized \n -> do+    k <- choose (0, min 255 n)+    SB.pack <$> vectorOf k arbitrary++genDomain :: Gen Domain+genDomain =+  elements [ $$(dnLit8 ".")+           , $$(dnLit8 "com")+           , $$(dnLit8 "example.org")+           , $$(dnLit8 "foo.example.com")+           , $$(dnLit8 "bar.example.com")+           , $$(dnLit8 "something.foo.example.com")+           ]++genMbox :: Gen Domain+genMbox =+  elements [ $$(mbLit8 "a@b")+           , $$(mbLit8 "first.last@example.com")+           , $$(mbLit8 "first.last@foo.example.com")+           , $$(mbLit8 "admin@com")+           ]