diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 +() 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. diff --git a/LICENSE.dns b/LICENSE.dns new file mode 100644 --- /dev/null +++ b/LICENSE.dns @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -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 diff --git a/dnsbase.cabal b/dnsbase.cabal new file mode 100644 --- /dev/null +++ b/dnsbase.cabal @@ -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 + + module for + + . + 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 + + 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 diff --git a/internal/Net/DNSBase/Decode/Internal/Domain.hs b/internal/Net/DNSBase/Decode/Internal/Domain.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Decode/Internal/Domain.hs @@ -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) diff --git a/internal/Net/DNSBase/Decode/Internal/Message.hs b/internal/Net/DNSBase/Decode/Internal/Message.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Decode/Internal/Message.hs @@ -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 diff --git a/internal/Net/DNSBase/Decode/Internal/Option.hs b/internal/Net/DNSBase/Decode/Internal/Option.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Decode/Internal/Option.hs @@ -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)) diff --git a/internal/Net/DNSBase/Decode/Internal/RData.hs b/internal/Net/DNSBase/Decode/Internal/RData.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Decode/Internal/RData.hs @@ -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 diff --git a/internal/Net/DNSBase/Decode/Internal/State.hs b/internal/Net/DNSBase/Decode/Internal/State.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Decode/Internal/State.hs @@ -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 #-} diff --git a/internal/Net/DNSBase/EDNS/Internal/OptNum.hs b/internal/Net/DNSBase/EDNS/Internal/OptNum.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/EDNS/Internal/OptNum.hs @@ -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) diff --git a/internal/Net/DNSBase/EDNS/Internal/Option.hs b/internal/Net/DNSBase/EDNS/Internal/Option.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/EDNS/Internal/Option.hs @@ -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) diff --git a/internal/Net/DNSBase/EDNS/Internal/Option/Opaque.hs b/internal/Net/DNSBase/EDNS/Internal/Option/Opaque.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/EDNS/Internal/Option/Opaque.hs @@ -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 diff --git a/internal/Net/DNSBase/Encode/Internal/Metric.hs b/internal/Net/DNSBase/Encode/Internal/Metric.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Encode/Internal/Metric.hs @@ -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 diff --git a/internal/Net/DNSBase/Encode/Internal/State.hs b/internal/Net/DNSBase/Encode/Internal/State.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Encode/Internal/State.hs @@ -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 #-} diff --git a/internal/Net/DNSBase/Internal/Bytes.hs b/internal/Net/DNSBase/Internal/Bytes.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Bytes.hs @@ -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 diff --git a/internal/Net/DNSBase/Internal/Domain.hs b/internal/Net/DNSBase/Internal/Domain.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Domain.hs @@ -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: +-- . 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 @\\@ 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 diff --git a/internal/Net/DNSBase/Internal/EDNS.hs b/internal/Net/DNSBase/Internal/EDNS.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/EDNS.hs @@ -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]()): +-- +-- > +------------+--------------+------------------------------+ +-- > | 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]()): +-- +-- > +---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+ +-- > | 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 diff --git a/internal/Net/DNSBase/Internal/Error.hs b/internal/Net/DNSBase/Internal/Error.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Error.hs @@ -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 diff --git a/internal/Net/DNSBase/Internal/Flags.hs b/internal/Net/DNSBase/Internal/Flags.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Flags.hs @@ -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, +-- . +-- +-- 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: +-- . +-- +-- 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 diff --git a/internal/Net/DNSBase/Internal/Message.hs b/internal/Net/DNSBase/Internal/Message.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Message.hs @@ -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 diff --git a/internal/Net/DNSBase/Internal/NameComp.hs b/internal/Net/DNSBase/Internal/NameComp.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/NameComp.hs @@ -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) diff --git a/internal/Net/DNSBase/Internal/Nat16.hs b/internal/Net/DNSBase/Internal/Nat16.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Nat16.hs @@ -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 #-} diff --git a/internal/Net/DNSBase/Internal/Opcode.hs b/internal/Net/DNSBase/Internal/Opcode.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Opcode.hs @@ -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 diff --git a/internal/Net/DNSBase/Internal/Peer.hs b/internal/Net/DNSBase/Internal/Peer.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Peer.hs @@ -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 diff --git a/internal/Net/DNSBase/Internal/Present.hs b/internal/Net/DNSBase/Internal/Present.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Present.hs @@ -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 + -- + -- (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 diff --git a/internal/Net/DNSBase/Internal/RCODE.hs b/internal/Net/DNSBase/Internal/RCODE.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/RCODE.hs @@ -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 diff --git a/internal/Net/DNSBase/Internal/RData.hs b/internal/Net/DNSBase/Internal/RData.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/RData.hs @@ -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)) diff --git a/internal/Net/DNSBase/Internal/RR.hs b/internal/Net/DNSBase/Internal/RR.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/RR.hs @@ -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 diff --git a/internal/Net/DNSBase/Internal/RRCLASS.hs b/internal/Net/DNSBase/Internal/RRCLASS.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/RRCLASS.hs @@ -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, +pattern IN :: RRCLASS; pattern IN = RRCLASS 1 + +-- | CS class (obsolete), +pattern CS :: RRCLASS; pattern CS = RRCLASS 2 + +-- | CHAOS class, +pattern CHAOS :: RRCLASS; pattern CHAOS = RRCLASS 3 + +-- | HESIOD class, +pattern HESIOD :: RRCLASS; pattern HESIOD = RRCLASS 4 + +-- | NONE class (Only used in the update protocol), +-- +pattern NONE :: RRCLASS; pattern NONE = RRCLASS 254 + +-- | ANYCLASS (valid only as a query class), +-- +pattern ANYCLASS :: RRCLASS; pattern ANYCLASS = RRCLASS 255 diff --git a/internal/Net/DNSBase/Internal/RRTYPE.hs b/internal/Net/DNSBase/Internal/RRTYPE.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/RRTYPE.hs @@ -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 #-} diff --git a/internal/Net/DNSBase/Internal/SockIO.hs b/internal/Net/DNSBase/Internal/SockIO.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/SockIO.hs @@ -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 diff --git a/internal/Net/DNSBase/Internal/Text.hs b/internal/Net/DNSBase/Internal/Text.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Text.hs @@ -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: + -- > " -> \" + -- > -> \\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) diff --git a/internal/Net/DNSBase/Internal/Transport.hs b/internal/Net/DNSBase/Internal/Transport.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Transport.hs @@ -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) diff --git a/internal/Net/DNSBase/Internal/Util.hs b/internal/Net/DNSBase/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Internal/Util.hs @@ -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) diff --git a/internal/Net/DNSBase/RData/Internal/XNAME.hs b/internal/Net/DNSBase/RData/Internal/XNAME.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/RData/Internal/XNAME.hs @@ -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 diff --git a/internal/Net/DNSBase/Resolver/Internal/Encoding.hs b/internal/Net/DNSBase/Resolver/Internal/Encoding.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Resolver/Internal/Encoding.hs @@ -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 diff --git a/internal/Net/DNSBase/Resolver/Internal/Parser.hs b/internal/Net/DNSBase/Resolver/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Resolver/Internal/Parser.hs @@ -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 diff --git a/internal/Net/DNSBase/Resolver/Internal/Types.hs b/internal/Net/DNSBase/Resolver/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/internal/Net/DNSBase/Resolver/Internal/Types.hs @@ -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 #-} diff --git a/src/Net/DNSBase.hs b/src/Net/DNSBase.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase.hs @@ -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 diff --git a/src/Net/DNSBase/Bytes.hs b/src/Net/DNSBase/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Bytes.hs @@ -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 diff --git a/src/Net/DNSBase/Decode/Domain.hs b/src/Net/DNSBase/Decode/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Decode/Domain.hs @@ -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 diff --git a/src/Net/DNSBase/Decode/State.hs b/src/Net/DNSBase/Decode/State.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Decode/State.hs @@ -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 diff --git a/src/Net/DNSBase/Domain.hs b/src/Net/DNSBase/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Domain.hs @@ -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: @\\@ is the start of a 4-byte +-- @\\DDD@ form; @\\@ 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 diff --git a/src/Net/DNSBase/EDNS.hs b/src/Net/DNSBase/EDNS.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/EDNS.hs @@ -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 diff --git a/src/Net/DNSBase/EDNS/OptNum.hs b/src/Net/DNSBase/EDNS/OptNum.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/EDNS/OptNum.hs @@ -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 diff --git a/src/Net/DNSBase/EDNS/Option.hs b/src/Net/DNSBase/EDNS/Option.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/EDNS/Option.hs @@ -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 diff --git a/src/Net/DNSBase/EDNS/Option/ECS.hs b/src/Net/DNSBase/EDNS/Option/ECS.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/EDNS/Option/ECS.hs @@ -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 diff --git a/src/Net/DNSBase/EDNS/Option/EDE.hs b/src/Net/DNSBase/EDNS/Option/EDE.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/EDNS/Option/EDE.hs @@ -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") + ] diff --git a/src/Net/DNSBase/EDNS/Option/NSID.hs b/src/Net/DNSBase/EDNS/Option/NSID.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/EDNS/Option/NSID.hs @@ -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 diff --git a/src/Net/DNSBase/EDNS/Option/Opaque.hs b/src/Net/DNSBase/EDNS/Option/Opaque.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/EDNS/Option/Opaque.hs @@ -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 diff --git a/src/Net/DNSBase/EDNS/Option/Secalgs.hs b/src/Net/DNSBase/EDNS/Option/Secalgs.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/EDNS/Option/Secalgs.hs @@ -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 diff --git a/src/Net/DNSBase/Encode/Metric.hs b/src/Net/DNSBase/Encode/Metric.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Encode/Metric.hs @@ -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 diff --git a/src/Net/DNSBase/Encode/State.hs b/src/Net/DNSBase/Encode/State.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Encode/State.hs @@ -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 diff --git a/src/Net/DNSBase/Error.hs b/src/Net/DNSBase/Error.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Error.hs @@ -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 diff --git a/src/Net/DNSBase/Extensible.hs b/src/Net/DNSBase/Extensible.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Extensible.hs @@ -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'. diff --git a/src/Net/DNSBase/Flags.hs b/src/Net/DNSBase/Flags.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Flags.hs @@ -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 diff --git a/src/Net/DNSBase/Lookup.hs b/src/Net/DNSBase/Lookup.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Lookup.hs @@ -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 diff --git a/src/Net/DNSBase/Message.hs b/src/Net/DNSBase/Message.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Message.hs @@ -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 diff --git a/src/Net/DNSBase/Nat16.hs b/src/Net/DNSBase/Nat16.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Nat16.hs @@ -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 diff --git a/src/Net/DNSBase/NonEmpty.hs b/src/Net/DNSBase/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/NonEmpty.hs @@ -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 diff --git a/src/Net/DNSBase/NsecTypes.hs b/src/Net/DNSBase/NsecTypes.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/NsecTypes.hs @@ -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 + +-- +-- 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 diff --git a/src/Net/DNSBase/Opcode.hs b/src/Net/DNSBase/Opcode.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Opcode.hs @@ -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 diff --git a/src/Net/DNSBase/Present.hs b/src/Net/DNSBase/Present.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Present.hs @@ -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 diff --git a/src/Net/DNSBase/RCODE.hs b/src/Net/DNSBase/RCODE.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RCODE.hs @@ -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 diff --git a/src/Net/DNSBase/RData.hs b/src/Net/DNSBase/RData.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData.hs @@ -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 diff --git a/src/Net/DNSBase/RData/A.hs b/src/Net/DNSBase/RData/A.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/A.hs @@ -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 diff --git a/src/Net/DNSBase/RData/CAA.hs b/src/Net/DNSBase/RData/CAA.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/CAA.hs @@ -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 diff --git a/src/Net/DNSBase/RData/CSYNC.hs b/src/Net/DNSBase/RData/CSYNC.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/CSYNC.hs @@ -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{..} diff --git a/src/Net/DNSBase/RData/Dnssec.hs b/src/Net/DNSBase/RData/Dnssec.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/Dnssec.hs @@ -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 diff --git a/src/Net/DNSBase/RData/NSEC.hs b/src/Net/DNSBase/RData/NSEC.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/NSEC.hs @@ -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{..} diff --git a/src/Net/DNSBase/RData/Obsolete.hs b/src/Net/DNSBase/RData/Obsolete.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/Obsolete.hs @@ -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 diff --git a/src/Net/DNSBase/RData/SOA.hs b/src/Net/DNSBase/RData/SOA.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/SOA.hs @@ -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{..} diff --git a/src/Net/DNSBase/RData/SRV.hs b/src/Net/DNSBase/RData/SRV.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/SRV.hs @@ -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{..} diff --git a/src/Net/DNSBase/RData/SVCB.hs b/src/Net/DNSBase/RData/SVCB.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/SVCB.hs @@ -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 diff --git a/src/Net/DNSBase/RData/SVCB/SPV.hs b/src/Net/DNSBase/RData/SVCB/SPV.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/SVCB/SPV.hs @@ -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: + -- , + -- + -- + -- 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 diff --git a/src/Net/DNSBase/RData/SVCB/SPVList.hs b/src/Net/DNSBase/RData/SVCB/SPVList.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/SVCB/SPVList.hs @@ -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) diff --git a/src/Net/DNSBase/RData/SVCB/SPVSet.hs b/src/Net/DNSBase/RData/SVCB/SPVSet.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/SVCB/SPVSet.hs @@ -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) diff --git a/src/Net/DNSBase/RData/SVCB/SVCParamKey.hs b/src/Net/DNSBase/RData/SVCB/SVCParamKey.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/SVCB/SVCParamKey.hs @@ -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 diff --git a/src/Net/DNSBase/RData/SVCB/SVCParamValue.hs b/src/Net/DNSBase/RData/SVCB/SVCParamValue.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/SVCB/SVCParamValue.hs @@ -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)) diff --git a/src/Net/DNSBase/RData/TLSA.hs b/src/Net/DNSBase/RData/TLSA.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/TLSA.hs @@ -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 diff --git a/src/Net/DNSBase/RData/TXT.hs b/src/Net/DNSBase/RData/TXT.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/TXT.hs @@ -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/@). +-- +-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- > / / +-- > / / +-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- +-- 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 diff --git a/src/Net/DNSBase/RData/WKS.hs b/src/Net/DNSBase/RData/WKS.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/WKS.hs @@ -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 | | +-- > +--+--+--+--+--+--+--+--+ | +-- > | | +-- > / / +-- > / / +-- > +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- +-- 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 diff --git a/src/Net/DNSBase/RData/XNAME.hs b/src/Net/DNSBase/RData/XNAME.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RData/XNAME.hs @@ -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 diff --git a/src/Net/DNSBase/RR.hs b/src/Net/DNSBase/RR.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RR.hs @@ -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 diff --git a/src/Net/DNSBase/RRCLASS.hs b/src/Net/DNSBase/RRCLASS.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RRCLASS.hs @@ -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 diff --git a/src/Net/DNSBase/RRSet.hs b/src/Net/DNSBase/RRSet.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RRSet.hs @@ -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} diff --git a/src/Net/DNSBase/RRTYPE.hs b/src/Net/DNSBase/RRTYPE.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/RRTYPE.hs @@ -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 diff --git a/src/Net/DNSBase/Resolver.hs b/src/Net/DNSBase/Resolver.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Resolver.hs @@ -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) + ) diff --git a/src/Net/DNSBase/Secalgs.hs b/src/Net/DNSBase/Secalgs.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Secalgs.hs @@ -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 diff --git a/src/Net/DNSBase/Text.hs b/src/Net/DNSBase/Text.hs new file mode 100644 --- /dev/null +++ b/src/Net/DNSBase/Text.hs @@ -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 diff --git a/tests/LiteralsParser.hs b/tests/LiteralsParser.hs new file mode 100644 --- /dev/null +++ b/tests/LiteralsParser.hs @@ -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 diff --git a/tests/domain.hs b/tests/domain.hs new file mode 100644 --- /dev/null +++ b/tests/domain.hs @@ -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] diff --git a/tests/extensibility.hs b/tests/extensibility.hs new file mode 100644 --- /dev/null +++ b/tests/extensibility.hs @@ -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 + ] diff --git a/tests/literals.hs b/tests/literals.hs new file mode 100644 --- /dev/null +++ b/tests/literals.hs @@ -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" diff --git a/tests/message.hs b/tests/message.hs new file mode 100644 --- /dev/null +++ b/tests/message.hs @@ -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 diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -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") + ]