From b13c5f9657a10b98c9972289a5951723cc23332a Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 19 Feb 2026 07:53:22 +0900 Subject: [PATCH 01/74] clove: a toy DNS authoritative server --- dnsext-bowline/clove/Config.hs | 47 +++++++++ dnsext-bowline/clove/clove.conf | 5 + dnsext-bowline/clove/clove.hs | 150 ++++++++++++++++++++++++++++ dnsext-bowline/dnsext-bowline.cabal | 25 +++++ 4 files changed, 227 insertions(+) create mode 100644 dnsext-bowline/clove/Config.hs create mode 100644 dnsext-bowline/clove/clove.conf create mode 100644 dnsext-bowline/clove/clove.hs diff --git a/dnsext-bowline/clove/Config.hs b/dnsext-bowline/clove/Config.hs new file mode 100644 index 000000000..f9596daa6 --- /dev/null +++ b/dnsext-bowline/clove/Config.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE RecordWildCards #-} + +module Config ( + Config (..), + loadConfig, +) where + +import DNS.Config +import Network.Socket (PortNumber) +import System.IO.Error (ioeGetErrorString, ioeSetErrorString, tryIOError) + +data Config = Config + { cnf_zone_name :: String + , cnf_zone_file :: FilePath + , cnf_dns_addrs :: [String] + , cnf_udp :: Bool + , cnf_udp_port :: PortNumber + } + +defaultConfig :: Config +defaultConfig = + Config + { cnf_zone_name = "example.org" + , cnf_zone_file = "example.conf" + , cnf_dns_addrs = ["127.0.0.1", "::1"] + , cnf_udp = True + , cnf_udp_port = 53 + } + +makeConfig :: Config -> [Conf] -> IO Config +makeConfig def conf = do + cnf_zone_name <- get "zone-name" cnf_zone_name + cnf_zone_file <- get "zone-file" cnf_zone_file + cnf_dns_addrs <- get "dns-addrs" cnf_dns_addrs + cnf_udp <- get "udp" cnf_udp + cnf_udp_port <- get "udp-port" cnf_udp_port + pure Config{..} + where + get k func = do + et <- tryIOError $ maybe (pure $ func def) fromConf $ lookup k conf + let left e = do + let e' = ioeSetErrorString e (k ++ ": " ++ ioeGetErrorString e) + ioError e' + either left pure et + +loadConfig :: FilePath -> IO Config +loadConfig file = loadFile file >>= makeConfig defaultConfig diff --git a/dnsext-bowline/clove/clove.conf b/dnsext-bowline/clove/clove.conf new file mode 100644 index 000000000..451593704 --- /dev/null +++ b/dnsext-bowline/clove/clove.conf @@ -0,0 +1,5 @@ +zone-name: edu +zone-file: zone/edu.zone +dns-addrs: 127.0.0.1,::1 +udp: yes +udp-port: 53 diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs new file mode 100644 index 000000000..6063bb75a --- /dev/null +++ b/dnsext-bowline/clove/clove.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Control.Concurrent.Async +import qualified Control.Exception as E +import Control.Monad +import Data.Function (on) +import Data.List (groupBy, sort) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes) +import Network.Socket +import qualified Network.Socket.ByteString as NSB +import System.Environment (getArgs) + +import DNS.Types +import DNS.Types.Decode +import DNS.Types.Encode +import qualified DNS.ZoneFile as ZF + +import Config + +---------------------------------------------------------------- + +type DB = M.Map Domain RRsets + +---------------------------------------------------------------- + +main :: IO () +main = do + [conffile] <- getArgs + Config{..} <- loadConfig conffile + let zone = fromRepresentation cnf_zone_name + rrs <- catMaybes . map fromResource <$> ZF.parseFile' cnf_zone_file zone + let gs = groupBy ((==) `on` rrname) $ sort rrs + ks = map (rrname . head) gs + vs = map makeRRsets gs + let kvs = zip ks vs + m = M.fromList kvs + ais <- mapM (serverResolve cnf_udp_port) cnf_dns_addrs + ss <- mapM serverSocket ais + mapConcurrently_ (clove zone m) ss + +---------------------------------------------------------------- + +clove :: Domain -> DB -> Socket -> IO () +clove zone m s = loop + where + loop = do + (bs, sa) <- NSB.recvFrom s 2048 + case decode bs of + -- fixme: which RFC? + Left _e -> return () + Right query -> replyQuery zone m s sa query + loop + +replyQuery :: Domain -> DB -> Socket -> SockAddr -> DNSMessage -> IO () +replyQuery zone m s sa query = void $ NSB.sendTo s bs sa + where + bs = encode $ processQuery zone m query + +-- RFC 8906: Sec 3.1.3.1 +-- +-- A non-recursive server is supposed to respond to recursive +-- queries as if the Recursion Desired (RD) bit is not set +processQuery :: Domain -> DB -> DNSMessage -> DNSMessage +processQuery zone m query + -- RFC 8906: Sec 3.1.4 + | opcode query /= OP_STD = reply{rcode = NotImpl} + | otherwise = case question query of + [Question{..}] + | not (qname `isSubDomainOf` zone) -> reply{rcode = Refused} + | otherwise -> + let as = case M.lookup qname m of + Nothing -> [] + Just x -> case qtype of + A -> rrsetA x + AAAA -> rrsetAAAA x + NS -> rrsetNS x + _ -> filter (\r -> rrtype r == qtype) $ rrsetOthers x + in reply{answer = as} + -- RFC 9619: "In the DNS, QDCOUNT Is (Usually) One" + _ -> reply{rcode = FormatErr} + where + -- RFC 6891: Sec 6.1.1 + ednsH = case ednsHeader query of + EDNSheader _ -> EDNSheader defaultEDNS + _ -> NoEDNS + flgs = + DNSFlags + { isResponse = True + , authAnswer = True + , trunCation = False + , -- RFC 1035 Sec 4.1.1 -- just copy + recDesired = recDesired $ flags query + , recAvailable = False + , authenData = False + , chkDisable = False + } + reply = query{flags = flgs, ednsHeader = ednsH} + +---------------------------------------------------------------- + +serverResolve :: PortNumber -> HostName -> IO AddrInfo +serverResolve pn addr = NE.head <$> getAddrInfo (Just hints) (Just addr) (Just port) + where + port = show pn + hints = + defaultHints + { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE] + , addrSocketType = Datagram + } + +serverSocket :: AddrInfo -> IO Socket +serverSocket ai = E.bracketOnError (openSocket ai) close $ \s -> do + setSocketOption s ReuseAddr 1 + bind s $ addrAddress ai + return s + +---------------------------------------------------------------- + +fromResource :: ZF.Record -> Maybe ResourceRecord +fromResource (ZF.R_RR r) = Just r +fromResource _ = Nothing + +data RRsets = RRsets + { rrsetA :: [ResourceRecord] + , rrsetAAAA :: [ResourceRecord] + , rrsetNS :: [ResourceRecord] + , rrsetOthers :: [ResourceRecord] + } + +makeRRsets :: [ResourceRecord] -> RRsets +makeRRsets rs0 = + let (as, aaaas, nss, others) = loop id id id id rs0 + in RRsets + { rrsetA = as + , rrsetAAAA = aaaas + , rrsetNS = nss + , rrsetOthers = others + } + where + loop a b c d [] = (a [], b [], c [], d []) + loop a b c d (r : rs) = case rrtype r of + A -> loop (a . (r :)) b c d rs + AAAA -> loop a (b . (r :)) c d rs + NS -> loop a b (c . (r :)) d rs + _ -> loop a b c (d . (r :)) rs diff --git a/dnsext-bowline/dnsext-bowline.cabal b/dnsext-bowline/dnsext-bowline.cabal index 9f0facd6f..cd514fad5 100644 --- a/dnsext-bowline/dnsext-bowline.cabal +++ b/dnsext-bowline/dnsext-bowline.cabal @@ -145,6 +145,31 @@ executable ddrd if impl(ghc >=8) default-extensions: Strict StrictData +executable clove + main-is: clove.hs + hs-source-dirs: clove + other-modules: Config + + default-language: Haskell2010 + ghc-options: -Wall -threaded + build-depends: + -- GHC bundled + base, + async, + network, + containers, + -- dnsext packages + dnsext-dnssec, + dnsext-svcb, + dnsext-types, + dnsext-utils + + if (os(windows) && impl(ghc >=9.0)) + ghc-options: -with-rtsopts=--io-manager=native + + if impl(ghc >=8) + default-extensions: Strict StrictData + executable dump main-is: dump.hs hs-source-dirs: dump From 1d0b6e6137d010c5385ff1a82eec2b7fbaa14cc6 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 3 Feb 2026 15:47:33 +0900 Subject: [PATCH 02/74] returning authority section --- dnsext-bowline/clove/clove.hs | 32 +++++++++++++++++++++----------- 1 file changed, 21 insertions(+), 11 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 6063bb75a..cc59496e5 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -70,17 +70,9 @@ processQuery zone m query -- RFC 8906: Sec 3.1.4 | opcode query /= OP_STD = reply{rcode = NotImpl} | otherwise = case question query of - [Question{..}] - | not (qname `isSubDomainOf` zone) -> reply{rcode = Refused} - | otherwise -> - let as = case M.lookup qname m of - Nothing -> [] - Just x -> case qtype of - A -> rrsetA x - AAAA -> rrsetAAAA x - NS -> rrsetNS x - _ -> filter (\r -> rrtype r == qtype) $ rrsetOthers x - in reply{answer = as} + [q] + | not (qname q `isSubDomainOf` zone) -> reply{rcode = Refused} + | otherwise -> positiveProcess m q reply -- RFC 9619: "In the DNS, QDCOUNT Is (Usually) One" _ -> reply{rcode = FormatErr} where @@ -101,6 +93,24 @@ processQuery zone m query } reply = query{flags = flgs, ednsHeader = ednsH} +positiveProcess :: DB -> Question -> DNSMessage -> DNSMessage +positiveProcess m Question{..} reply = + reply + { answer = ans + , authority = auth + } + where + (ans, auth) = case M.lookup qname m of + Nothing -> ([], []) + Just x -> + let ans' = case qtype of + A -> rrsetA x + AAAA -> rrsetAAAA x + NS -> rrsetNS x + _ -> filter (\r -> rrtype r == qtype) $ rrsetOthers x + auth' = if null ans' && qtype /= NS then rrsetNS x else [] + in (ans', auth') + ---------------------------------------------------------------- serverResolve :: PortNumber -> HostName -> IO AddrInfo From 9efc6a3c0ae7b4cd72def97143d3e81ccc5161a3 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 3 Feb 2026 16:04:24 +0900 Subject: [PATCH 03/74] returning addtional section --- dnsext-bowline/clove/clove.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index cc59496e5..3bd07c8f7 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -7,7 +7,7 @@ import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad import Data.Function (on) -import Data.List (groupBy, sort) +import Data.List (groupBy, nub, sort) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import Data.Maybe (catMaybes) @@ -98,10 +98,11 @@ positiveProcess m Question{..} reply = reply { answer = ans , authority = auth + , additional = add } where - (ans, auth) = case M.lookup qname m of - Nothing -> ([], []) + (ans, auth, add) = case M.lookup qname m of + Nothing -> ([], [], []) Just x -> let ans' = case qtype of A -> rrsetA x @@ -109,7 +110,15 @@ positiveProcess m Question{..} reply = NS -> rrsetNS x _ -> filter (\r -> rrtype r == qtype) $ rrsetOthers x auth' = if null ans' && qtype /= NS then rrsetNS x else [] - in (ans', auth') + ns' = nub $ sort $ catMaybes $ map extractNS auth' + add' = concat $ map lookupAdd ns' + in (ans', auth', add') + extractNS rr = case fromRData $ rdata rr of + Nothing -> Nothing + Just ns -> Just $ ns_domain ns + lookupAdd dom = case M.lookup dom m of + Nothing -> [] + Just x -> rrsetA x ++ rrsetAAAA x ---------------------------------------------------------------- From cc3da9b92bdf4a27828d3100c510d12c5aaf8944 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 4 Feb 2026 10:50:37 +0900 Subject: [PATCH 04/74] returning NSDomain --- dnsext-bowline/clove/clove.hs | 47 +++++++++++++++++++++++------------ 1 file changed, 31 insertions(+), 16 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 3bd07c8f7..ce5babdb5 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -24,7 +24,12 @@ import Config ---------------------------------------------------------------- -type DB = M.Map Domain RRsets +data DB = DB + { dbSOA :: ResourceRecord + , dbMap :: M.Map Domain RRsets + } + +-- type DB = M.Map Domain RRsets ---------------------------------------------------------------- @@ -37,42 +42,50 @@ main = do let gs = groupBy ((==) `on` rrname) $ sort rrs ks = map (rrname . head) gs vs = map makeRRsets gs - let kvs = zip ks vs + -- RFC 1035 Sec 5.2 + -- Exactly one SOA RR should be present at the top of the zone. + soa = head rrs -- checkme + kvs = zip ks vs m = M.fromList kvs + db = + DB + { dbSOA = soa + , dbMap = m + } ais <- mapM (serverResolve cnf_udp_port) cnf_dns_addrs ss <- mapM serverSocket ais - mapConcurrently_ (clove zone m) ss + mapConcurrently_ (clove zone db) ss ---------------------------------------------------------------- clove :: Domain -> DB -> Socket -> IO () -clove zone m s = loop +clove zone db s = loop where loop = do (bs, sa) <- NSB.recvFrom s 2048 case decode bs of -- fixme: which RFC? Left _e -> return () - Right query -> replyQuery zone m s sa query + Right query -> replyQuery zone db s sa query loop replyQuery :: Domain -> DB -> Socket -> SockAddr -> DNSMessage -> IO () replyQuery zone m s sa query = void $ NSB.sendTo s bs sa where - bs = encode $ processQuery zone m query + bs = encode $ guardNegative zone m query -- RFC 8906: Sec 3.1.3.1 -- -- A non-recursive server is supposed to respond to recursive -- queries as if the Recursion Desired (RD) bit is not set -processQuery :: Domain -> DB -> DNSMessage -> DNSMessage -processQuery zone m query +guardNegative :: Domain -> DB -> DNSMessage -> DNSMessage +guardNegative zone m query -- RFC 8906: Sec 3.1.4 | opcode query /= OP_STD = reply{rcode = NotImpl} | otherwise = case question query of [q] | not (qname q `isSubDomainOf` zone) -> reply{rcode = Refused} - | otherwise -> positiveProcess m q reply + | otherwise -> processPositive m q reply -- RFC 9619: "In the DNS, QDCOUNT Is (Usually) One" _ -> reply{rcode = FormatErr} where @@ -87,22 +100,24 @@ processQuery zone m query , trunCation = False , -- RFC 1035 Sec 4.1.1 -- just copy recDesired = recDesired $ flags query - , recAvailable = False + , -- RFC 1034 Sec 4.3.1 + recAvailable = False , authenData = False , chkDisable = False } reply = query{flags = flgs, ednsHeader = ednsH} -positiveProcess :: DB -> Question -> DNSMessage -> DNSMessage -positiveProcess m Question{..} reply = +processPositive :: DB -> Question -> DNSMessage -> DNSMessage +processPositive DB{..} Question{..} reply = reply { answer = ans , authority = auth , additional = add + , rcode = code } where - (ans, auth, add) = case M.lookup qname m of - Nothing -> ([], [], []) + (ans, auth, add, code) = case M.lookup qname dbMap of + Nothing -> ([], [dbSOA], [], NXDomain) Just x -> let ans' = case qtype of A -> rrsetA x @@ -112,11 +127,11 @@ positiveProcess m Question{..} reply = auth' = if null ans' && qtype /= NS then rrsetNS x else [] ns' = nub $ sort $ catMaybes $ map extractNS auth' add' = concat $ map lookupAdd ns' - in (ans', auth', add') + in (ans', auth', add', NoErr) extractNS rr = case fromRData $ rdata rr of Nothing -> Nothing Just ns -> Just $ ns_domain ns - lookupAdd dom = case M.lookup dom m of + lookupAdd dom = case M.lookup dom dbMap of Nothing -> [] Just x -> rrsetA x ++ rrsetAAAA x From 6e13e5d32ed65f84d691e6cf924e3b34c93f9e00 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 4 Feb 2026 11:06:29 +0900 Subject: [PATCH 05/74] removing warnings --- dnsext-bowline/clove/clove.hs | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index ce5babdb5..0a0b1c164 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -14,6 +15,7 @@ import Data.Maybe (catMaybes) import Network.Socket import qualified Network.Socket.ByteString as NSB import System.Environment (getArgs) +import System.Exit import DNS.Types import DNS.Types.Decode @@ -39,12 +41,16 @@ main = do Config{..} <- loadConfig conffile let zone = fromRepresentation cnf_zone_name rrs <- catMaybes . map fromResource <$> ZF.parseFile' cnf_zone_file zone + soa <- case rrs of + soa' : _ -> case fromRData $ rdata soa' of + Just (_ :: RD_SOA) -> return soa' + Nothing -> die "SOA does not exit (1)" + _ -> die "SOA does not exit (2)" let gs = groupBy ((==) `on` rrname) $ sort rrs - ks = map (rrname . head) gs + ks = map (rrname . unsafeHead) gs vs = map makeRRsets gs -- RFC 1035 Sec 5.2 -- Exactly one SOA RR should be present at the top of the zone. - soa = head rrs -- checkme kvs = zip ks vs m = M.fromList kvs db = @@ -56,6 +62,10 @@ main = do ss <- mapM serverSocket ais mapConcurrently_ (clove zone db) ss +unsafeHead :: [a] -> a +unsafeHead (x : _) = x +unsafeHead _ = error "unsafeHead" + ---------------------------------------------------------------- clove :: Domain -> DB -> Socket -> IO () From 9ee40bd30b6a0d85e9382df25d7ed3a26f8a5846 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 4 Feb 2026 11:37:47 +0900 Subject: [PATCH 06/74] supporting NoError --- dnsext-bowline/clove/clove.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 0a0b1c164..a5c01d1df 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -137,7 +137,11 @@ processPositive DB{..} Question{..} reply = auth' = if null ans' && qtype /= NS then rrsetNS x else [] ns' = nub $ sort $ catMaybes $ map extractNS auth' add' = concat $ map lookupAdd ns' - in (ans', auth', add', NoErr) + in if null ans' && null auth' && null add' + then + ([], [dbSOA], [], NoErr) + else + (ans', auth', add', NoErr) extractNS rr = case fromRData $ rdata rr of Nothing -> Nothing Just ns -> Just $ ns_domain ns From 7076a49174f34a27a1fc130e524054e23f0f1289 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 4 Feb 2026 12:44:03 +0900 Subject: [PATCH 07/74] looping with subdomains --- dnsext-bowline/clove/clove.hs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index a5c01d1df..30f6b211f 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -94,11 +94,12 @@ guardNegative zone m query | opcode query /= OP_STD = reply{rcode = NotImpl} | otherwise = case question query of [q] - | not (qname q `isSubDomainOf` zone) -> reply{rcode = Refused} - | otherwise -> processPositive m q reply + | not (check $ qname q) -> reply{rcode = Refused} + | otherwise -> processPositive m q check reply -- RFC 9619: "In the DNS, QDCOUNT Is (Usually) One" _ -> reply{rcode = FormatErr} where + check = (`isSubDomainOf` zone) -- RFC 6891: Sec 6.1.1 ednsH = case ednsHeader query of EDNSheader _ -> EDNSheader defaultEDNS @@ -117,8 +118,8 @@ guardNegative zone m query } reply = query{flags = flgs, ednsHeader = ednsH} -processPositive :: DB -> Question -> DNSMessage -> DNSMessage -processPositive DB{..} Question{..} reply = +processPositive :: DB -> Question -> (Domain -> Bool) -> DNSMessage -> DNSMessage +processPositive DB{..} Question{..} check reply = reply { answer = ans , authority = auth @@ -126,8 +127,13 @@ processPositive DB{..} Question{..} reply = , rcode = code } where - (ans, auth, add, code) = case M.lookup qname dbMap of - Nothing -> ([], [dbSOA], [], NXDomain) + (ans, auth, add, code) = loop qname + loop dom = case M.lookup dom dbMap of + Nothing -> case unconsDomain dom of + Nothing -> ([], [dbSOA], [], NXDomain) + Just (_, dom') + | check dom' -> loop dom' + | otherwise -> ([], [dbSOA], [], NXDomain) Just x -> let ans' = case qtype of A -> rrsetA x From 062233ecc730abc9aa21568630c3df64de9aa48a Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 4 Feb 2026 16:53:26 +0900 Subject: [PATCH 08/74] number of question is 1 --- dnsext-bowline/clove/clove.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 30f6b211f..4ae2f2da9 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -92,13 +92,10 @@ guardNegative :: Domain -> DB -> DNSMessage -> DNSMessage guardNegative zone m query -- RFC 8906: Sec 3.1.4 | opcode query /= OP_STD = reply{rcode = NotImpl} - | otherwise = case question query of - [q] - | not (check $ qname q) -> reply{rcode = Refused} - | otherwise -> processPositive m q check reply - -- RFC 9619: "In the DNS, QDCOUNT Is (Usually) One" - _ -> reply{rcode = FormatErr} + | not (check $ qname q) = reply{rcode = Refused} + | otherwise = processPositive m q check reply where + q = question query check = (`isSubDomainOf` zone) -- RFC 6891: Sec 6.1.1 ednsH = case ednsHeader query of From 96bb3647ee7e0d4e5fe9f470566c1e476a1aeaab Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 4 Feb 2026 17:30:19 +0900 Subject: [PATCH 09/74] defining findDelegation --- dnsext-bowline/clove/clove.hs | 59 ++++++++++++++++++++++++----------- 1 file changed, 40 insertions(+), 19 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 4ae2f2da9..1b806b77a 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -92,11 +92,10 @@ guardNegative :: Domain -> DB -> DNSMessage -> DNSMessage guardNegative zone m query -- RFC 8906: Sec 3.1.4 | opcode query /= OP_STD = reply{rcode = NotImpl} - | not (check $ qname q) = reply{rcode = Refused} - | otherwise = processPositive m q check reply + | not (qname q `isSubDomainOf` zone) = reply{rcode = Refused} + | otherwise = processPositive m q zone reply where q = question query - check = (`isSubDomainOf` zone) -- RFC 6891: Sec 6.1.1 ednsH = case ednsHeader query of EDNSheader _ -> EDNSheader defaultEDNS @@ -115,8 +114,8 @@ guardNegative zone m query } reply = query{flags = flgs, ednsHeader = ednsH} -processPositive :: DB -> Question -> (Domain -> Bool) -> DNSMessage -> DNSMessage -processPositive DB{..} Question{..} check reply = +processPositive :: DB -> Question -> Domain -> DNSMessage -> DNSMessage +processPositive db@DB{..} q@Question{..} zone reply = reply { answer = ans , authority = auth @@ -124,13 +123,8 @@ processPositive DB{..} Question{..} check reply = , rcode = code } where - (ans, auth, add, code) = loop qname - loop dom = case M.lookup dom dbMap of - Nothing -> case unconsDomain dom of - Nothing -> ([], [dbSOA], [], NXDomain) - Just (_, dom') - | check dom' -> loop dom' - | otherwise -> ([], [dbSOA], [], NXDomain) + (ans, auth, add, code) = case M.lookup qname dbMap of + Nothing -> findDelegation db q zone Just x -> let ans' = case qtype of A -> rrsetA x @@ -138,19 +132,46 @@ processPositive DB{..} Question{..} check reply = NS -> rrsetNS x _ -> filter (\r -> rrtype r == qtype) $ rrsetOthers x auth' = if null ans' && qtype /= NS then rrsetNS x else [] - ns' = nub $ sort $ catMaybes $ map extractNS auth' - add' = concat $ map lookupAdd ns' - in if null ans' && null auth' && null add' + in if null ans' && null auth' then ([], [dbSOA], [], NoErr) else - (ans', auth', add', NoErr) - extractNS rr = case fromRData $ rdata rr of - Nothing -> Nothing - Just ns -> Just $ ns_domain ns + let add' = findAdditional db auth' + in (ans', auth', add', NoErr) + +findDelegation + :: DB + -> Question + -> Domain + -> ([ResourceRecord], [ResourceRecord], [ResourceRecord], RCODE) +findDelegation db@DB{..} Question{..} zone = loop qname + where + loop dom + | dom == zone = ([], [dbSOA], [], NXDomain) + | otherwise = case unconsDomain dom of + Nothing -> ([], [dbSOA], [], NXDomain) + Just (_, dom') -> case M.lookup dom dbMap of + Nothing -> loop dom' + Just x -> + let auth = rrsetNS x + in if null auth + then + ([], [dbSOA], [], NoErr) + else + let add = findAdditional db auth + in ([], auth, add, NoErr) + +findAdditional :: DB -> [ResourceRecord] -> [ResourceRecord] +findAdditional DB{..} auth' = add' + where + ns' = nub $ sort $ catMaybes $ map extractNS auth' + add' = concat $ map lookupAdd ns' lookupAdd dom = case M.lookup dom dbMap of Nothing -> [] Just x -> rrsetA x ++ rrsetAAAA x + extractNS rr = case fromRData $ rdata rr of + Nothing -> Nothing + Just ns -> Just $ ns_domain ns ---------------------------------------------------------------- From a7d2e5a2c9f942b152f3a723a64dccdee7ce297a Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 8 Feb 2026 11:34:32 +0900 Subject: [PATCH 10/74] in-domain and sibling glue only. --- dnsext-bowline/clove/clove.hs | 86 +++++++++++++++++++++++++---------- 1 file changed, 63 insertions(+), 23 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 1b806b77a..5979832d2 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -8,14 +8,14 @@ import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad import Data.Function (on) -import Data.List (groupBy, nub, sort) +import Data.List (groupBy, nub, partition, sort) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import Data.Maybe (catMaybes) +import qualified Data.Set as Set import Network.Socket import qualified Network.Socket.ByteString as NSB import System.Environment (getArgs) -import System.Exit import DNS.Types import DNS.Types.Decode @@ -29,6 +29,7 @@ import Config data DB = DB { dbSOA :: ResourceRecord , dbMap :: M.Map Domain RRsets + , dbGlue :: M.Map Domain [ResourceRecord] } -- type DB = M.Map Domain RRsets @@ -39,25 +40,8 @@ main :: IO () main = do [conffile] <- getArgs Config{..} <- loadConfig conffile - let zone = fromRepresentation cnf_zone_name - rrs <- catMaybes . map fromResource <$> ZF.parseFile' cnf_zone_file zone - soa <- case rrs of - soa' : _ -> case fromRData $ rdata soa' of - Just (_ :: RD_SOA) -> return soa' - Nothing -> die "SOA does not exit (1)" - _ -> die "SOA does not exit (2)" - let gs = groupBy ((==) `on` rrname) $ sort rrs - ks = map (rrname . unsafeHead) gs - vs = map makeRRsets gs - -- RFC 1035 Sec 5.2 - -- Exactly one SOA RR should be present at the top of the zone. - kvs = zip ks vs - m = M.fromList kvs - db = - DB - { dbSOA = soa - , dbMap = m - } + (zone, rrs) <- loadZoneFile cnf_zone_name cnf_zone_file + let db = make zone rrs ais <- mapM (serverResolve cnf_udp_port) cnf_dns_addrs ss <- mapM serverSocket ais mapConcurrently_ (clove zone db) ss @@ -68,6 +52,62 @@ unsafeHead _ = error "unsafeHead" ---------------------------------------------------------------- +loadZoneFile :: String -> FilePath -> IO (Domain, [ResourceRecord]) +loadZoneFile zone file = do + rrs <- catMaybes . map fromResource <$> ZF.parseFile' file dom + return (dom, rrs) + where + dom = fromRepresentation zone + +partition3 :: Domain -> [ResourceRecord] -> ([ResourceRecord], [ResourceRecord], [ResourceRecord]) +partition3 dom rrs0 = loop rrs0 [] [] [] + where + loop [] as ns os = (as, ns, os) + loop (r : rs) as ns os + | rrname r `isSubDomainOf` dom = + if rrtype r == NS && rrname r /= dom + then loop rs as (r : ns) os + else loop rs (r : as) ns os + | otherwise = loop rs as ns (r : os) + +makeIsDelegated :: [ResourceRecord] -> (Domain -> Bool) +makeIsDelegated rrs = \dom -> or (map (\f -> f dom) ps) + where + s = Set.fromList $ map rrname rrs + ps = map (\x -> (`isSubDomainOf` x)) $ Set.toList s + +make :: Domain -> [ResourceRecord] -> DB +make _ [] = error "make: no resource records" +-- RFC 1035 Sec 5.2 +-- Exactly one SOA RR should be present at the top of the zone. +make zone (soa : rrs) + | rrtype soa /= SOA = error "make: no SOA" + | otherwise = + DB + { dbSOA = soa + , dbMap = m + , dbGlue = g + } + where + -- RFC 9471 + -- In-domain and sibling glues only. + -- Unrelated glues are ignored. + (as, ns, _os) = partition3 zone rrs + isDelegated = makeIsDelegated ns + (glue, inzone) = partition (\r -> isDelegated (rrname r)) as + m = makeMap makeRRsets $ [soa] ++ ns ++ inzone + g = makeMap id glue + +makeMap :: ([ResourceRecord] -> v) -> [ResourceRecord] -> M.Map Domain v +makeMap conv rrs = M.fromList kvs + where + gs = groupBy ((==) `on` rrname) $ sort rrs + ks = map (rrname . unsafeHead) gs + vs = map conv gs + kvs = zip ks vs + +---------------------------------------------------------------- + clove :: Domain -> DB -> Socket -> IO () clove zone db s = loop where @@ -166,9 +206,9 @@ findAdditional DB{..} auth' = add' where ns' = nub $ sort $ catMaybes $ map extractNS auth' add' = concat $ map lookupAdd ns' - lookupAdd dom = case M.lookup dom dbMap of + lookupAdd dom = case M.lookup dom dbGlue of Nothing -> [] - Just x -> rrsetA x ++ rrsetAAAA x + Just rs -> rs extractNS rr = case fromRData $ rdata rr of Nothing -> Nothing Just ns -> Just $ ns_domain ns From 34d0b7b8f086e5b9db848d72dbe5ce610fbdbbfb Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 8 Feb 2026 15:40:08 +0900 Subject: [PATCH 11/74] refactoring --- dnsext-bowline/clove/clove.hs | 51 ++++++++++++++++++----------------- 1 file changed, 27 insertions(+), 24 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 5979832d2..7cdd6fa37 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -27,7 +27,8 @@ import Config ---------------------------------------------------------------- data DB = DB - { dbSOA :: ResourceRecord + { dbZone :: Domain + , dbSOA :: ResourceRecord , dbMap :: M.Map Domain RRsets , dbGlue :: M.Map Domain [ResourceRecord] } @@ -40,11 +41,10 @@ main :: IO () main = do [conffile] <- getArgs Config{..} <- loadConfig conffile - (zone, rrs) <- loadZoneFile cnf_zone_name cnf_zone_file - let db = make zone rrs + db <- loadDB cnf_zone_name cnf_zone_file ais <- mapM (serverResolve cnf_udp_port) cnf_dns_addrs ss <- mapM serverSocket ais - mapConcurrently_ (clove zone db) ss + mapConcurrently_ (clove db) ss unsafeHead :: [a] -> a unsafeHead (x : _) = x @@ -52,6 +52,9 @@ unsafeHead _ = error "unsafeHead" ---------------------------------------------------------------- +loadDB :: String -> FilePath -> IO DB +loadDB zone file = make <$> loadZoneFile zone file + loadZoneFile :: String -> FilePath -> IO (Domain, [ResourceRecord]) loadZoneFile zone file = do rrs <- catMaybes . map fromResource <$> ZF.parseFile' file dom @@ -76,15 +79,16 @@ makeIsDelegated rrs = \dom -> or (map (\f -> f dom) ps) s = Set.fromList $ map rrname rrs ps = map (\x -> (`isSubDomainOf` x)) $ Set.toList s -make :: Domain -> [ResourceRecord] -> DB -make _ [] = error "make: no resource records" +make :: (Domain, [ResourceRecord]) -> DB +make (_, []) = error "make: no resource records" -- RFC 1035 Sec 5.2 -- Exactly one SOA RR should be present at the top of the zone. -make zone (soa : rrs) +make (zone, soa : rrs) | rrtype soa /= SOA = error "make: no SOA" | otherwise = DB - { dbSOA = soa + { dbZone = zone + , dbSOA = soa , dbMap = m , dbGlue = g } @@ -108,32 +112,32 @@ makeMap conv rrs = M.fromList kvs ---------------------------------------------------------------- -clove :: Domain -> DB -> Socket -> IO () -clove zone db s = loop +clove :: DB -> Socket -> IO () +clove db s = loop where loop = do (bs, sa) <- NSB.recvFrom s 2048 case decode bs of -- fixme: which RFC? Left _e -> return () - Right query -> replyQuery zone db s sa query + Right query -> replyQuery db s sa query loop -replyQuery :: Domain -> DB -> Socket -> SockAddr -> DNSMessage -> IO () -replyQuery zone m s sa query = void $ NSB.sendTo s bs sa +replyQuery :: DB -> Socket -> SockAddr -> DNSMessage -> IO () +replyQuery db s sa query = void $ NSB.sendTo s bs sa where - bs = encode $ guardNegative zone m query + bs = encode $ guardNegative db query -- RFC 8906: Sec 3.1.3.1 -- -- A non-recursive server is supposed to respond to recursive -- queries as if the Recursion Desired (RD) bit is not set -guardNegative :: Domain -> DB -> DNSMessage -> DNSMessage -guardNegative zone m query +guardNegative :: DB -> DNSMessage -> DNSMessage +guardNegative db query -- RFC 8906: Sec 3.1.4 | opcode query /= OP_STD = reply{rcode = NotImpl} - | not (qname q `isSubDomainOf` zone) = reply{rcode = Refused} - | otherwise = processPositive m q zone reply + | not (qname q `isSubDomainOf` dbZone db) = reply{rcode = Refused} + | otherwise = processPositive db q reply where q = question query -- RFC 6891: Sec 6.1.1 @@ -154,8 +158,8 @@ guardNegative zone m query } reply = query{flags = flgs, ednsHeader = ednsH} -processPositive :: DB -> Question -> Domain -> DNSMessage -> DNSMessage -processPositive db@DB{..} q@Question{..} zone reply = +processPositive :: DB -> Question -> DNSMessage -> DNSMessage +processPositive db@DB{..} q@Question{..} reply = reply { answer = ans , authority = auth @@ -164,7 +168,7 @@ processPositive db@DB{..} q@Question{..} zone reply = } where (ans, auth, add, code) = case M.lookup qname dbMap of - Nothing -> findDelegation db q zone + Nothing -> findDelegation db q Just x -> let ans' = case qtype of A -> rrsetA x @@ -182,12 +186,11 @@ processPositive db@DB{..} q@Question{..} zone reply = findDelegation :: DB -> Question - -> Domain -> ([ResourceRecord], [ResourceRecord], [ResourceRecord], RCODE) -findDelegation db@DB{..} Question{..} zone = loop qname +findDelegation db@DB{..} Question{..} = loop qname where loop dom - | dom == zone = ([], [dbSOA], [], NXDomain) + | dom == dbZone = ([], [dbSOA], [], NXDomain) | otherwise = case unconsDomain dom of Nothing -> ([], [dbSOA], [], NXDomain) Just (_, dom') -> case M.lookup dom dbMap of From 37bb9478819a42d615c7fa3c516d67c26b492a7c Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 8 Feb 2026 15:45:12 +0900 Subject: [PATCH 12/74] refactoring with Either --- dnsext-bowline/clove/clove.hs | 41 ++++++++++++++++++++--------------- 1 file changed, 23 insertions(+), 18 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 7cdd6fa37..568ab9d0d 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -16,6 +16,7 @@ import qualified Data.Set as Set import Network.Socket import qualified Network.Socket.ByteString as NSB import System.Environment (getArgs) +import System.Exit import DNS.Types import DNS.Types.Decode @@ -41,18 +42,17 @@ main :: IO () main = do [conffile] <- getArgs Config{..} <- loadConfig conffile - db <- loadDB cnf_zone_name cnf_zone_file - ais <- mapM (serverResolve cnf_udp_port) cnf_dns_addrs - ss <- mapM serverSocket ais - mapConcurrently_ (clove db) ss - -unsafeHead :: [a] -> a -unsafeHead (x : _) = x -unsafeHead _ = error "unsafeHead" + edb <- loadDB cnf_zone_name cnf_zone_file + case edb of + Left emsg -> die emsg + Right db -> do + ais <- mapM (serverResolve cnf_udp_port) cnf_dns_addrs + ss <- mapM serverSocket ais + mapConcurrently_ (clove db) ss ---------------------------------------------------------------- -loadDB :: String -> FilePath -> IO DB +loadDB :: String -> FilePath -> IO (Either String DB) loadDB zone file = make <$> loadZoneFile zone file loadZoneFile :: String -> FilePath -> IO (Domain, [ResourceRecord]) @@ -79,19 +79,20 @@ makeIsDelegated rrs = \dom -> or (map (\f -> f dom) ps) s = Set.fromList $ map rrname rrs ps = map (\x -> (`isSubDomainOf` x)) $ Set.toList s -make :: (Domain, [ResourceRecord]) -> DB -make (_, []) = error "make: no resource records" +make :: (Domain, [ResourceRecord]) -> Either String DB +make (_, []) = Left "make: no resource records" -- RFC 1035 Sec 5.2 -- Exactly one SOA RR should be present at the top of the zone. make (zone, soa : rrs) - | rrtype soa /= SOA = error "make: no SOA" + | rrtype soa /= SOA = Left "make: no SOA" | otherwise = - DB - { dbZone = zone - , dbSOA = soa - , dbMap = m - , dbGlue = g - } + Right $ + DB + { dbZone = zone + , dbSOA = soa + , dbMap = m + , dbGlue = g + } where -- RFC 9471 -- In-domain and sibling glues only. @@ -110,6 +111,10 @@ makeMap conv rrs = M.fromList kvs vs = map conv gs kvs = zip ks vs +unsafeHead :: [a] -> a +unsafeHead (x : _) = x +unsafeHead _ = error "unsafeHead" + ---------------------------------------------------------------- clove :: DB -> Socket -> IO () From e54088ead7563fadd7acb4f3cfadae00bcc24442 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 8 Feb 2026 16:10:59 +0900 Subject: [PATCH 13/74] creating dnsext-auth --- build.sh | 2 +- dnsext-auth/DNS/Auth/Algorithm.hs | 100 ++++++++++++++ dnsext-auth/DNS/Auth/DB.hs | 120 ++++++++++++++++ dnsext-auth/LICENSE | 29 ++++ dnsext-auth/dnsext-auth.cabal | 24 ++++ dnsext-bowline/clove/clove.hs | 204 +--------------------------- dnsext-bowline/dnsext-bowline.cabal | 4 +- test.sh | 2 +- 8 files changed, 279 insertions(+), 206 deletions(-) create mode 100644 dnsext-auth/DNS/Auth/Algorithm.hs create mode 100644 dnsext-auth/DNS/Auth/DB.hs create mode 100644 dnsext-auth/LICENSE create mode 100644 dnsext-auth/dnsext-auth.cabal diff --git a/build.sh b/build.sh index f21a297e3..d1d526daa 100644 --- a/build.sh +++ b/build.sh @@ -1,5 +1,5 @@ cab delete -r dnsext-types -for pkg in dnsext-types dnsext-dnssec dnsext-svcb dnsext-utils dnsext-do53 dnsext-dox dnsext-iterative +for pkg in dnsext-types dnsext-dnssec dnsext-svcb dnsext-utils dnsext-do53 dnsext-dox dnsext-iterative dnsext-auth do (cd $pkg; cab clean; cab install -d; cab conf; cab build; cab install) done diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs new file mode 100644 index 000000000..17dfdebed --- /dev/null +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE RecordWildCards #-} + +module DNS.Auth.Algorithm ( + getReply, +) where + +import Data.List (nub, sort) +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes) + +import DNS.Auth.DB +import DNS.Types + +-- RFC 8906: Sec 3.1.3.1 +-- +-- A non-recursive server is supposed to respond to recursive +-- queries as if the Recursion Desired (RD) bit is not set +getReply :: DB -> DNSMessage -> DNSMessage +getReply db query + -- RFC 8906: Sec 3.1.4 + | opcode query /= OP_STD = reply{rcode = NotImpl} + | not (qname q `isSubDomainOf` dbZone db) = reply{rcode = Refused} + | otherwise = processPositive db q reply + where + q = question query + -- RFC 6891: Sec 6.1.1 + ednsH = case ednsHeader query of + EDNSheader _ -> EDNSheader defaultEDNS + _ -> NoEDNS + flgs = + DNSFlags + { isResponse = True + , authAnswer = True + , trunCation = False + , -- RFC 1035 Sec 4.1.1 -- just copy + recDesired = recDesired $ flags query + , -- RFC 1034 Sec 4.3.1 + recAvailable = False + , authenData = False + , chkDisable = False + } + reply = query{flags = flgs, ednsHeader = ednsH} + +processPositive :: DB -> Question -> DNSMessage -> DNSMessage +processPositive db@DB{..} q@Question{..} reply = + reply + { answer = ans + , authority = auth + , additional = add + , rcode = code + } + where + (ans, auth, add, code) = case M.lookup qname dbMap of + Nothing -> findDelegation db q + Just x -> + let ans' = case qtype of + A -> rrsetA x + AAAA -> rrsetAAAA x + NS -> rrsetNS x + _ -> filter (\r -> rrtype r == qtype) $ rrsetOthers x + auth' = if null ans' && qtype /= NS then rrsetNS x else [] + in if null ans' && null auth' + then + ([], [dbSOA], [], NoErr) + else + let add' = findAdditional db auth' + in (ans', auth', add', NoErr) + +findDelegation + :: DB + -> Question + -> ([ResourceRecord], [ResourceRecord], [ResourceRecord], RCODE) +findDelegation db@DB{..} Question{..} = loop qname + where + loop dom + | dom == dbZone = ([], [dbSOA], [], NXDomain) + | otherwise = case unconsDomain dom of + Nothing -> ([], [dbSOA], [], NXDomain) + Just (_, dom') -> case M.lookup dom dbMap of + Nothing -> loop dom' + Just x -> + let auth = rrsetNS x + in if null auth + then + ([], [dbSOA], [], NoErr) + else + let add = findAdditional db auth + in ([], auth, add, NoErr) + +findAdditional :: DB -> [ResourceRecord] -> [ResourceRecord] +findAdditional DB{..} auth' = add' + where + ns' = nub $ sort $ catMaybes $ map extractNS auth' + add' = concat $ map lookupAdd ns' + lookupAdd dom = case M.lookup dom dbGlue of + Nothing -> [] + Just rs -> rs + extractNS rr = case fromRData $ rdata rr of + Nothing -> Nothing + Just ns -> Just $ ns_domain ns diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs new file mode 100644 index 000000000..2f1a59e86 --- /dev/null +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -0,0 +1,120 @@ +module DNS.Auth.DB ( + DB (..), + RRsets (..), + loadDB, +) where + +import Data.Function (on) +import Data.List (groupBy, partition, sort) +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes) +import qualified Data.Set as Set + +import DNS.Types +import qualified DNS.ZoneFile as ZF + +---------------------------------------------------------------- + +data DB = DB + { dbZone :: Domain + , dbSOA :: ResourceRecord + , dbMap :: M.Map Domain RRsets + , dbGlue :: M.Map Domain [ResourceRecord] + } + +data RRsets = RRsets + { rrsetA :: [ResourceRecord] + , rrsetAAAA :: [ResourceRecord] + , rrsetNS :: [ResourceRecord] + , rrsetOthers :: [ResourceRecord] + } + +---------------------------------------------------------------- + +loadDB :: String -> FilePath -> IO (Either String DB) +loadDB zone file = make <$> loadZoneFile zone file + +loadZoneFile :: String -> FilePath -> IO (Domain, [ResourceRecord]) +loadZoneFile zone file = do + rrs <- catMaybes . map fromResource <$> ZF.parseFile file dom + return (dom, rrs) + where + dom = fromRepresentation zone + +---------------------------------------------------------------- + +make :: (Domain, [ResourceRecord]) -> Either String DB +make (_, []) = Left "make: no resource records" +-- RFC 1035 Sec 5.2 +-- Exactly one SOA RR should be present at the top of the zone. +make (zone, soa : rrs) + | rrtype soa /= SOA = Left "make: no SOA" + | otherwise = + Right $ + DB + { dbZone = zone + , dbSOA = soa + , dbMap = m + , dbGlue = g + } + where + -- RFC 9471 + -- In-domain and sibling glues only. + -- Unrelated glues are ignored. + (as, ns, _os) = partition3 zone rrs + isDelegated = makeIsDelegated ns + (glue, inzone) = partition (\r -> isDelegated (rrname r)) as + m = makeMap makeRRsets $ [soa] ++ ns ++ inzone + g = makeMap id glue + +partition3 :: Domain -> [ResourceRecord] -> ([ResourceRecord], [ResourceRecord], [ResourceRecord]) +partition3 dom rrs0 = loop rrs0 [] [] [] + where + loop [] as ns os = (as, ns, os) + loop (r : rs) as ns os + | rrname r `isSubDomainOf` dom = + if rrtype r == NS && rrname r /= dom + then loop rs as (r : ns) os + else loop rs (r : as) ns os + | otherwise = loop rs as ns (r : os) + +makeIsDelegated :: [ResourceRecord] -> (Domain -> Bool) +makeIsDelegated rrs = \dom -> or (map (\f -> f dom) ps) + where + s = Set.fromList $ map rrname rrs + ps = map (\x -> (`isSubDomainOf` x)) $ Set.toList s + +makeMap :: ([ResourceRecord] -> v) -> [ResourceRecord] -> M.Map Domain v +makeMap conv rrs = M.fromList kvs + where + gs = groupBy ((==) `on` rrname) $ sort rrs + ks = map (rrname . unsafeHead) gs + vs = map conv gs + kvs = zip ks vs + +unsafeHead :: [a] -> a +unsafeHead (x : _) = x +unsafeHead _ = error "unsafeHead" + +---------------------------------------------------------------- + +fromResource :: ZF.Record -> Maybe ResourceRecord +fromResource (ZF.R_RR r) = Just r +fromResource _ = Nothing + +makeRRsets :: [ResourceRecord] -> RRsets +makeRRsets rs0 = + let (as, aaaas, nss, others) = loop id id id id rs0 + in RRsets + { rrsetA = as + , rrsetAAAA = aaaas + , rrsetNS = nss + , rrsetOthers = others + } + where + loop a b c d [] = (a [], b [], c [], d []) + loop a b c d (r : rs) = case rrtype r of + A -> loop (a . (r :)) b c d rs + AAAA -> loop a (b . (r :)) c d rs + NS -> loop a b (c . (r :)) d rs + _ -> loop a b c (d . (r :)) rs diff --git a/dnsext-auth/LICENSE b/dnsext-auth/LICENSE new file mode 100644 index 000000000..d8a85445c --- /dev/null +++ b/dnsext-auth/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2026, Internet Initiative Japan 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/dnsext-auth/dnsext-auth.cabal b/dnsext-auth/dnsext-auth.cabal new file mode 100644 index 000000000..a31cd3f81 --- /dev/null +++ b/dnsext-auth/dnsext-auth.cabal @@ -0,0 +1,24 @@ +cabal-version: >=1.10 +name: dnsext-auth +version: 0.0.0 +license-file: LICENSE +maintainer: kazu@iij.ad.jp +author: Kazu Yamamoto +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: + DNS.Auth.DB + DNS.Auth.Algorithm + + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4 && <5, + containers, + dnsext-types, + dnsext-utils + + if impl(ghc >=8) + default-extensions: Strict StrictData diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 568ab9d0d..0a2feb414 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -7,37 +7,22 @@ module Main where import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad -import Data.Function (on) -import Data.List (groupBy, nub, partition, sort) import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes) -import qualified Data.Set as Set import Network.Socket import qualified Network.Socket.ByteString as NSB import System.Environment (getArgs) import System.Exit +import DNS.Auth.Algorithm +import DNS.Auth.DB import DNS.Types import DNS.Types.Decode import DNS.Types.Encode -import qualified DNS.ZoneFile as ZF import Config ---------------------------------------------------------------- -data DB = DB - { dbZone :: Domain - , dbSOA :: ResourceRecord - , dbMap :: M.Map Domain RRsets - , dbGlue :: M.Map Domain [ResourceRecord] - } - --- type DB = M.Map Domain RRsets - ----------------------------------------------------------------- - main :: IO () main = do [conffile] <- getArgs @@ -52,71 +37,6 @@ main = do ---------------------------------------------------------------- -loadDB :: String -> FilePath -> IO (Either String DB) -loadDB zone file = make <$> loadZoneFile zone file - -loadZoneFile :: String -> FilePath -> IO (Domain, [ResourceRecord]) -loadZoneFile zone file = do - rrs <- catMaybes . map fromResource <$> ZF.parseFile' file dom - return (dom, rrs) - where - dom = fromRepresentation zone - -partition3 :: Domain -> [ResourceRecord] -> ([ResourceRecord], [ResourceRecord], [ResourceRecord]) -partition3 dom rrs0 = loop rrs0 [] [] [] - where - loop [] as ns os = (as, ns, os) - loop (r : rs) as ns os - | rrname r `isSubDomainOf` dom = - if rrtype r == NS && rrname r /= dom - then loop rs as (r : ns) os - else loop rs (r : as) ns os - | otherwise = loop rs as ns (r : os) - -makeIsDelegated :: [ResourceRecord] -> (Domain -> Bool) -makeIsDelegated rrs = \dom -> or (map (\f -> f dom) ps) - where - s = Set.fromList $ map rrname rrs - ps = map (\x -> (`isSubDomainOf` x)) $ Set.toList s - -make :: (Domain, [ResourceRecord]) -> Either String DB -make (_, []) = Left "make: no resource records" --- RFC 1035 Sec 5.2 --- Exactly one SOA RR should be present at the top of the zone. -make (zone, soa : rrs) - | rrtype soa /= SOA = Left "make: no SOA" - | otherwise = - Right $ - DB - { dbZone = zone - , dbSOA = soa - , dbMap = m - , dbGlue = g - } - where - -- RFC 9471 - -- In-domain and sibling glues only. - -- Unrelated glues are ignored. - (as, ns, _os) = partition3 zone rrs - isDelegated = makeIsDelegated ns - (glue, inzone) = partition (\r -> isDelegated (rrname r)) as - m = makeMap makeRRsets $ [soa] ++ ns ++ inzone - g = makeMap id glue - -makeMap :: ([ResourceRecord] -> v) -> [ResourceRecord] -> M.Map Domain v -makeMap conv rrs = M.fromList kvs - where - gs = groupBy ((==) `on` rrname) $ sort rrs - ks = map (rrname . unsafeHead) gs - vs = map conv gs - kvs = zip ks vs - -unsafeHead :: [a] -> a -unsafeHead (x : _) = x -unsafeHead _ = error "unsafeHead" - ----------------------------------------------------------------- - clove :: DB -> Socket -> IO () clove db s = loop where @@ -131,95 +51,7 @@ clove db s = loop replyQuery :: DB -> Socket -> SockAddr -> DNSMessage -> IO () replyQuery db s sa query = void $ NSB.sendTo s bs sa where - bs = encode $ guardNegative db query - --- RFC 8906: Sec 3.1.3.1 --- --- A non-recursive server is supposed to respond to recursive --- queries as if the Recursion Desired (RD) bit is not set -guardNegative :: DB -> DNSMessage -> DNSMessage -guardNegative db query - -- RFC 8906: Sec 3.1.4 - | opcode query /= OP_STD = reply{rcode = NotImpl} - | not (qname q `isSubDomainOf` dbZone db) = reply{rcode = Refused} - | otherwise = processPositive db q reply - where - q = question query - -- RFC 6891: Sec 6.1.1 - ednsH = case ednsHeader query of - EDNSheader _ -> EDNSheader defaultEDNS - _ -> NoEDNS - flgs = - DNSFlags - { isResponse = True - , authAnswer = True - , trunCation = False - , -- RFC 1035 Sec 4.1.1 -- just copy - recDesired = recDesired $ flags query - , -- RFC 1034 Sec 4.3.1 - recAvailable = False - , authenData = False - , chkDisable = False - } - reply = query{flags = flgs, ednsHeader = ednsH} - -processPositive :: DB -> Question -> DNSMessage -> DNSMessage -processPositive db@DB{..} q@Question{..} reply = - reply - { answer = ans - , authority = auth - , additional = add - , rcode = code - } - where - (ans, auth, add, code) = case M.lookup qname dbMap of - Nothing -> findDelegation db q - Just x -> - let ans' = case qtype of - A -> rrsetA x - AAAA -> rrsetAAAA x - NS -> rrsetNS x - _ -> filter (\r -> rrtype r == qtype) $ rrsetOthers x - auth' = if null ans' && qtype /= NS then rrsetNS x else [] - in if null ans' && null auth' - then - ([], [dbSOA], [], NoErr) - else - let add' = findAdditional db auth' - in (ans', auth', add', NoErr) - -findDelegation - :: DB - -> Question - -> ([ResourceRecord], [ResourceRecord], [ResourceRecord], RCODE) -findDelegation db@DB{..} Question{..} = loop qname - where - loop dom - | dom == dbZone = ([], [dbSOA], [], NXDomain) - | otherwise = case unconsDomain dom of - Nothing -> ([], [dbSOA], [], NXDomain) - Just (_, dom') -> case M.lookup dom dbMap of - Nothing -> loop dom' - Just x -> - let auth = rrsetNS x - in if null auth - then - ([], [dbSOA], [], NoErr) - else - let add = findAdditional db auth - in ([], auth, add, NoErr) - -findAdditional :: DB -> [ResourceRecord] -> [ResourceRecord] -findAdditional DB{..} auth' = add' - where - ns' = nub $ sort $ catMaybes $ map extractNS auth' - add' = concat $ map lookupAdd ns' - lookupAdd dom = case M.lookup dom dbGlue of - Nothing -> [] - Just rs -> rs - extractNS rr = case fromRData $ rdata rr of - Nothing -> Nothing - Just ns -> Just $ ns_domain ns + bs = encode $ getReply db query ---------------------------------------------------------------- @@ -238,33 +70,3 @@ serverSocket ai = E.bracketOnError (openSocket ai) close $ \s -> do setSocketOption s ReuseAddr 1 bind s $ addrAddress ai return s - ----------------------------------------------------------------- - -fromResource :: ZF.Record -> Maybe ResourceRecord -fromResource (ZF.R_RR r) = Just r -fromResource _ = Nothing - -data RRsets = RRsets - { rrsetA :: [ResourceRecord] - , rrsetAAAA :: [ResourceRecord] - , rrsetNS :: [ResourceRecord] - , rrsetOthers :: [ResourceRecord] - } - -makeRRsets :: [ResourceRecord] -> RRsets -makeRRsets rs0 = - let (as, aaaas, nss, others) = loop id id id id rs0 - in RRsets - { rrsetA = as - , rrsetAAAA = aaaas - , rrsetNS = nss - , rrsetOthers = others - } - where - loop a b c d [] = (a [], b [], c [], d []) - loop a b c d (r : rs) = case rrtype r of - A -> loop (a . (r :)) b c d rs - AAAA -> loop a (b . (r :)) c d rs - NS -> loop a b (c . (r :)) d rs - _ -> loop a b c (d . (r :)) rs diff --git a/dnsext-bowline/dnsext-bowline.cabal b/dnsext-bowline/dnsext-bowline.cabal index cd514fad5..ea8c21d01 100644 --- a/dnsext-bowline/dnsext-bowline.cabal +++ b/dnsext-bowline/dnsext-bowline.cabal @@ -157,10 +157,8 @@ executable clove base, async, network, - containers, -- dnsext packages - dnsext-dnssec, - dnsext-svcb, + dnsext-auth, dnsext-types, dnsext-utils diff --git a/test.sh b/test.sh index fe5576f50..247e42d80 100644 --- a/test.sh +++ b/test.sh @@ -1,6 +1,6 @@ cab delete -r dnsext-types -for pkg in dnsext-types dnsext-dnssec dnsext-svcb dnsext-utils dnsext-do53 dnsext-dox dnsext-iterative +for pkg in dnsext-types dnsext-dnssec dnsext-svcb dnsext-utils dnsext-do53 dnsext-dox dnsext-iterative dnsext-auth do (cd $pkg; cab install -d -t; cab clean; cab conf -t; cab build; cab test; cab doctest $pkg; cab install) done From c5b4c9bb6cc5ff407317187e0c28bc3b06c1acc7 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 8 Feb 2026 17:18:41 +0900 Subject: [PATCH 14/74] adding test cases for authoritative algorithm --- dnsext-auth/DNS/Auth/Algorithm.hs | 6 +-- dnsext-auth/dnsext-auth.cabal | 21 +++++++++++ dnsext-auth/test/AlgorithmSpec.hs | 61 +++++++++++++++++++++++++++++++ dnsext-auth/test/Spec.hs | 1 + dnsext-auth/test/example.zone | 19 ++++++++++ dnsext-bowline/clove/clove.hs | 2 +- 6 files changed, 106 insertions(+), 4 deletions(-) create mode 100644 dnsext-auth/test/AlgorithmSpec.hs create mode 100644 dnsext-auth/test/Spec.hs create mode 100644 dnsext-auth/test/example.zone diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 17dfdebed..49342125c 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards #-} module DNS.Auth.Algorithm ( - getReply, + getAnswer, ) where import Data.List (nub, sort) @@ -15,8 +15,8 @@ import DNS.Types -- -- A non-recursive server is supposed to respond to recursive -- queries as if the Recursion Desired (RD) bit is not set -getReply :: DB -> DNSMessage -> DNSMessage -getReply db query +getAnswer :: DB -> DNSMessage -> DNSMessage +getAnswer db query -- RFC 8906: Sec 3.1.4 | opcode query /= OP_STD = reply{rcode = NotImpl} | not (qname q `isSubDomainOf` dbZone db) = reply{rcode = Refused} diff --git a/dnsext-auth/dnsext-auth.cabal b/dnsext-auth/dnsext-auth.cabal index a31cd3f81..ab742f443 100644 --- a/dnsext-auth/dnsext-auth.cabal +++ b/dnsext-auth/dnsext-auth.cabal @@ -22,3 +22,24 @@ library if impl(ghc >=8) default-extensions: Strict StrictData + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover + hs-source-dirs: test + other-modules: AlgorithmSpec + default-language: Haskell2010 + ghc-options: -Wall -threaded + build-depends: + base, + bytestring, + dnsext-auth, + dnsext-types, + hspec + + if (os(windows) && impl(ghc >=9.0)) + ghc-options: -with-rtsopts=--io-manager=native + + if impl(ghc >=8) + default-extensions: Strict StrictData diff --git a/dnsext-auth/test/AlgorithmSpec.hs b/dnsext-auth/test/AlgorithmSpec.hs new file mode 100644 index 000000000..0909d5b20 --- /dev/null +++ b/dnsext-auth/test/AlgorithmSpec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +module AlgorithmSpec where + +import Test.Hspec + +import DNS.Auth.Algorithm +import DNS.Auth.DB +import DNS.Types + +spec :: Spec +spec = describe "authoritative algorithm" $ do + edb <- runIO $ loadDB "example.jp." "test/example.zone" + let db = case edb of + Left _ -> error "DB" + Right db' -> db' + it "can answer an exiting domain" $ do + let query = defaultQuery{question = Question "exist.example.jp." A IN} + ans = getAnswer db query + rcode ans `shouldBe` NoErr + answer ans `shouldSatisfy` include "exist.example.jp." A + length (authority ans) `shouldBe` 0 + length (additional ans) `shouldBe` 0 + it "can answer an non-exiting domain" $ do + let query = defaultQuery{question = Question "nonexist.example.jp." A IN} + ans = getAnswer db query + rcode ans `shouldBe` NXDomain + length (answer ans) `shouldBe` 0 + authority ans `shouldSatisfy` include "example.jp." SOA + length (additional ans) `shouldBe` 0 + it "can refuse unrelated domains" $ do + let query = defaultQuery{question = Question "unrelated.com." A IN} + ans = getAnswer db query + rcode ans `shouldBe` Refused + length (answer ans) `shouldBe` 0 + length (authority ans) `shouldBe` 0 + length (additional ans) `shouldBe` 0 + it "can answer referrals" $ do + let query = defaultQuery{question = Question "foo.in.example.jp." A IN} + ans = getAnswer db query + rcode ans `shouldBe` NoErr + length (answer ans) `shouldBe` 0 + length (authority ans) `shouldBe` 3 + authority ans `shouldSatisfy` includeNS "ns.in.example.jp." + authority ans `shouldSatisfy` includeNS "ns.sibling.example.jp." + authority ans `shouldSatisfy` includeNS "unrelated.com." + length (additional ans) `shouldBe` 2 + additional ans `shouldSatisfy` include "ns.in.example.jp." A + additional ans `shouldSatisfy` include "ns.sibling.example.jp." A + +includeNS :: Domain -> [ResourceRecord] -> Bool +includeNS dom rs = any has rs + where + has r = case fromRData $ rdata r of + Nothing -> False + Just rd -> ns_domain rd == dom + +include :: Domain -> TYPE -> [ResourceRecord] -> Bool +include dom typ rs = any has rs + where + has r = rrname r == dom && rrtype r == typ diff --git a/dnsext-auth/test/Spec.hs b/dnsext-auth/test/Spec.hs new file mode 100644 index 000000000..a824f8c30 --- /dev/null +++ b/dnsext-auth/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/dnsext-auth/test/example.zone b/dnsext-auth/test/example.zone new file mode 100644 index 000000000..b2b44827c --- /dev/null +++ b/dnsext-auth/test/example.zone @@ -0,0 +1,19 @@ +@ IN SOA ns.example.jp. hostmaster.example.jp. ( + 870769 ;serial + 1800 ;refresh every 30 minutes + 300 ;retry every 5 minutes + 604800 ;expire after a week + 86400 ;minimum of a day + ) + NS ns.example.jp. + +ns.example.jp. 3600 A 192.0.2.1 +exist.example.jp. 3600 A 192.0.2.2 + 3600 AAAA 2001:0db8::2 +in.example.jp. 3600 NS ns.in.example.jp. + 3600 NS ns.sibling.example.jp. + 3600 NS unrelated.com. +ns.in.example.jp. 3600 A 192.0.2.3 ; glue +sibling.example.jp. 3600 NS ns.sibling.example.jp. +ns.sibling.example.jp. 3600 A 192.0.2.4 ; glue +unrelated.com. 3609 A 192.0.2.10 ; glue diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 0a2feb414..d92139b50 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -51,7 +51,7 @@ clove db s = loop replyQuery :: DB -> Socket -> SockAddr -> DNSMessage -> IO () replyQuery db s sa query = void $ NSB.sendTo s bs sa where - bs = encode $ getReply db query + bs = encode $ getAnswer db query ---------------------------------------------------------------- From d681123aef8c4ae6c1b6999b99f3a68999f733a8 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 8 Feb 2026 17:56:36 +0900 Subject: [PATCH 15/74] testing AA --- dnsext-auth/DNS/Auth/Algorithm.hs | 35 +++++++++++++++++++++---------- dnsext-auth/test/AlgorithmSpec.hs | 4 ++++ 2 files changed, 28 insertions(+), 11 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 49342125c..fc636c41d 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -19,7 +19,11 @@ getAnswer :: DB -> DNSMessage -> DNSMessage getAnswer db query -- RFC 8906: Sec 3.1.4 | opcode query /= OP_STD = reply{rcode = NotImpl} - | not (qname q `isSubDomainOf` dbZone db) = reply{rcode = Refused} + | not (qname q `isSubDomainOf` dbZone db) = + reply + { rcode = Refused + , flags = flgs{authAnswer = False} + } | otherwise = processPositive db q reply where q = question query @@ -48,9 +52,10 @@ processPositive db@DB{..} q@Question{..} reply = , authority = auth , additional = add , rcode = code + , flags = (flags reply){authAnswer = aa} } where - (ans, auth, add, code) = case M.lookup qname dbMap of + (ans, auth, add, code, aa) = case M.lookup qname dbMap of Nothing -> findDelegation db q Just x -> let ans' = case qtype of @@ -59,33 +64,41 @@ processPositive db@DB{..} q@Question{..} reply = NS -> rrsetNS x _ -> filter (\r -> rrtype r == qtype) $ rrsetOthers x auth' = if null ans' && qtype /= NS then rrsetNS x else [] - in if null ans' && null auth' + in if null ans' then - ([], [dbSOA], [], NoErr) + if null auth' + then + ([], [dbSOA], [], NoErr, True) + else + let add' = findAdditional db auth' + in (ans', auth', add', NoErr, False) else - let add' = findAdditional db auth' - in (ans', auth', add', NoErr) + if qtype == NS + then + (ans', [], [], NoErr, False) + else + (ans', [], [], NoErr, True) findDelegation :: DB -> Question - -> ([ResourceRecord], [ResourceRecord], [ResourceRecord], RCODE) + -> ([ResourceRecord], [ResourceRecord], [ResourceRecord], RCODE, Bool) findDelegation db@DB{..} Question{..} = loop qname where loop dom - | dom == dbZone = ([], [dbSOA], [], NXDomain) + | dom == dbZone = ([], [dbSOA], [], NXDomain, True) | otherwise = case unconsDomain dom of - Nothing -> ([], [dbSOA], [], NXDomain) + Nothing -> ([], [dbSOA], [], NXDomain, True) Just (_, dom') -> case M.lookup dom dbMap of Nothing -> loop dom' Just x -> let auth = rrsetNS x in if null auth then - ([], [dbSOA], [], NoErr) + ([], [dbSOA], [], NoErr, True) else let add = findAdditional db auth - in ([], auth, add, NoErr) + in ([], auth, add, NoErr, False) findAdditional :: DB -> [ResourceRecord] -> [ResourceRecord] findAdditional DB{..} auth' = add' diff --git a/dnsext-auth/test/AlgorithmSpec.hs b/dnsext-auth/test/AlgorithmSpec.hs index 0909d5b20..44015a360 100644 --- a/dnsext-auth/test/AlgorithmSpec.hs +++ b/dnsext-auth/test/AlgorithmSpec.hs @@ -21,6 +21,7 @@ spec = describe "authoritative algorithm" $ do answer ans `shouldSatisfy` include "exist.example.jp." A length (authority ans) `shouldBe` 0 length (additional ans) `shouldBe` 0 + flags ans `shouldSatisfy` authAnswer it "can answer an non-exiting domain" $ do let query = defaultQuery{question = Question "nonexist.example.jp." A IN} ans = getAnswer db query @@ -28,6 +29,7 @@ spec = describe "authoritative algorithm" $ do length (answer ans) `shouldBe` 0 authority ans `shouldSatisfy` include "example.jp." SOA length (additional ans) `shouldBe` 0 + flags ans `shouldSatisfy` authAnswer it "can refuse unrelated domains" $ do let query = defaultQuery{question = Question "unrelated.com." A IN} ans = getAnswer db query @@ -35,6 +37,7 @@ spec = describe "authoritative algorithm" $ do length (answer ans) `shouldBe` 0 length (authority ans) `shouldBe` 0 length (additional ans) `shouldBe` 0 + flags ans `shouldSatisfy` not . authAnswer it "can answer referrals" $ do let query = defaultQuery{question = Question "foo.in.example.jp." A IN} ans = getAnswer db query @@ -47,6 +50,7 @@ spec = describe "authoritative algorithm" $ do length (additional ans) `shouldBe` 2 additional ans `shouldSatisfy` include "ns.in.example.jp." A additional ans `shouldSatisfy` include "ns.sibling.example.jp." A + flags ans `shouldSatisfy` not . authAnswer includeNS :: Domain -> [ResourceRecord] -> Bool includeNS dom rs = any has rs From bb899abd64ecb2d41200e6d03967525fca07bf39 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 8 Feb 2026 20:41:05 +0900 Subject: [PATCH 16/74] DB now has three Maps --- dnsext-auth/DNS/Auth/Algorithm.hs | 47 +++++++++------------------- dnsext-auth/DNS/Auth/DB.hs | 52 +++++++++---------------------- 2 files changed, 30 insertions(+), 69 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index fc636c41d..64dd8797f 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -55,29 +55,15 @@ processPositive db@DB{..} q@Question{..} reply = , flags = (flags reply){authAnswer = aa} } where - (ans, auth, add, code, aa) = case M.lookup qname dbMap of + (ans, auth, add, code, aa) = case M.lookup qname dbAnswer of Nothing -> findDelegation db q - Just x -> - let ans' = case qtype of - A -> rrsetA x - AAAA -> rrsetAAAA x - NS -> rrsetNS x - _ -> filter (\r -> rrtype r == qtype) $ rrsetOthers x - auth' = if null ans' && qtype /= NS then rrsetNS x else [] + Just rs -> + let ans' = filter (\r -> rrtype r == qtype) rs in if null ans' then - if null auth' - then - ([], [dbSOA], [], NoErr, True) - else - let add' = findAdditional db auth' - in (ans', auth', add', NoErr, False) + ([], [dbSOA], [], NoErr, True) else - if qtype == NS - then - (ans', [], [], NoErr, False) - else - (ans', [], [], NoErr, True) + (ans', [], [], NoErr, True) findDelegation :: DB @@ -89,23 +75,20 @@ findDelegation db@DB{..} Question{..} = loop qname | dom == dbZone = ([], [dbSOA], [], NXDomain, True) | otherwise = case unconsDomain dom of Nothing -> ([], [dbSOA], [], NXDomain, True) - Just (_, dom') -> case M.lookup dom dbMap of + Just (_, dom') -> case M.lookup dom dbAuthority of Nothing -> loop dom' - Just x -> - let auth = rrsetNS x - in if null auth - then - ([], [dbSOA], [], NoErr, True) - else - let add = findAdditional db auth - in ([], auth, add, NoErr, False) + Just auth + | null auth -> ([], [dbSOA], [], NoErr, True) + | otherwise -> + let add = findAdditional db auth + in ([], auth, add, NoErr, False) findAdditional :: DB -> [ResourceRecord] -> [ResourceRecord] -findAdditional DB{..} auth' = add' +findAdditional DB{..} auth0 = add where - ns' = nub $ sort $ catMaybes $ map extractNS auth' - add' = concat $ map lookupAdd ns' - lookupAdd dom = case M.lookup dom dbGlue of + doms = nub $ sort $ catMaybes $ map extractNS auth0 + add = concat $ map lookupAdd doms + lookupAdd dom = case M.lookup dom dbAdditiona of Nothing -> [] Just rs -> rs extractNS rr = case fromRData $ rdata rr of diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs index 2f1a59e86..b25646c97 100644 --- a/dnsext-auth/DNS/Auth/DB.hs +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -1,6 +1,5 @@ module DNS.Auth.DB ( DB (..), - RRsets (..), loadDB, ) where @@ -18,16 +17,11 @@ import qualified DNS.ZoneFile as ZF data DB = DB { dbZone :: Domain , dbSOA :: ResourceRecord - , dbMap :: M.Map Domain RRsets - , dbGlue :: M.Map Domain [ResourceRecord] - } - -data RRsets = RRsets - { rrsetA :: [ResourceRecord] - , rrsetAAAA :: [ResourceRecord] - , rrsetNS :: [ResourceRecord] - , rrsetOthers :: [ResourceRecord] + , dbAnswer :: M.Map Domain [ResourceRecord] + , dbAuthority :: M.Map Domain [ResourceRecord] + , dbAdditiona :: M.Map Domain [ResourceRecord] } + deriving (Show) ---------------------------------------------------------------- @@ -54,8 +48,9 @@ make (zone, soa : rrs) DB { dbZone = zone , dbSOA = soa - , dbMap = m - , dbGlue = g + , dbAnswer = ans + , dbAuthority = auth + , dbAdditiona = add } where -- RFC 9471 @@ -63,9 +58,10 @@ make (zone, soa : rrs) -- Unrelated glues are ignored. (as, ns, _os) = partition3 zone rrs isDelegated = makeIsDelegated ns - (glue, inzone) = partition (\r -> isDelegated (rrname r)) as - m = makeMap makeRRsets $ [soa] ++ ns ++ inzone - g = makeMap id glue + (gs, zs) = partition (\r -> isDelegated (rrname r)) as + ans = makeMap $ [soa] ++ zs + auth = makeMap ns + add = makeMap gs partition3 :: Domain -> [ResourceRecord] -> ([ResourceRecord], [ResourceRecord], [ResourceRecord]) partition3 dom rrs0 = loop rrs0 [] [] [] @@ -84,12 +80,11 @@ makeIsDelegated rrs = \dom -> or (map (\f -> f dom) ps) s = Set.fromList $ map rrname rrs ps = map (\x -> (`isSubDomainOf` x)) $ Set.toList s -makeMap :: ([ResourceRecord] -> v) -> [ResourceRecord] -> M.Map Domain v -makeMap conv rrs = M.fromList kvs +makeMap :: [ResourceRecord] -> M.Map Domain [ResourceRecord] +makeMap rrs = M.fromList kvs where - gs = groupBy ((==) `on` rrname) $ sort rrs - ks = map (rrname . unsafeHead) gs - vs = map conv gs + vs = groupBy ((==) `on` rrname) $ sort rrs + ks = map (rrname . unsafeHead) vs kvs = zip ks vs unsafeHead :: [a] -> a @@ -101,20 +96,3 @@ unsafeHead _ = error "unsafeHead" fromResource :: ZF.Record -> Maybe ResourceRecord fromResource (ZF.R_RR r) = Just r fromResource _ = Nothing - -makeRRsets :: [ResourceRecord] -> RRsets -makeRRsets rs0 = - let (as, aaaas, nss, others) = loop id id id id rs0 - in RRsets - { rrsetA = as - , rrsetAAAA = aaaas - , rrsetNS = nss - , rrsetOthers = others - } - where - loop a b c d [] = (a [], b [], c [], d []) - loop a b c d (r : rs) = case rrtype r of - A -> loop (a . (r :)) b c d rs - AAAA -> loop a (b . (r :)) c d rs - NS -> loop a b (c . (r :)) d rs - _ -> loop a b c (d . (r :)) rs From 9822da6aa33e4678c4090a1cfff7b397ce7866b6 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 8 Feb 2026 20:52:48 +0900 Subject: [PATCH 17/74] refactoring --- dnsext-auth/DNS/Auth/Algorithm.hs | 47 +++++++++++++++---------------- 1 file changed, 23 insertions(+), 24 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 64dd8797f..ccdac9b42 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -46,42 +46,31 @@ getAnswer db query reply = query{flags = flgs, ednsHeader = ednsH} processPositive :: DB -> Question -> DNSMessage -> DNSMessage -processPositive db@DB{..} q@Question{..} reply = - reply - { answer = ans - , authority = auth - , additional = add - , rcode = code - , flags = (flags reply){authAnswer = aa} - } +processPositive db@DB{..} q@Question{..} reply = case M.lookup qname dbAnswer of + Nothing -> findAuthority db q reply + Just rs -> makeAnswer $ filter (\r -> rrtype r == qtype) rs where - (ans, auth, add, code, aa) = case M.lookup qname dbAnswer of - Nothing -> findDelegation db q - Just rs -> - let ans' = filter (\r -> rrtype r == qtype) rs - in if null ans' - then - ([], [dbSOA], [], NoErr, True) - else - (ans', [], [], NoErr, True) + makeAnswer [] = makeReply reply [] [dbSOA] [] NoErr True + makeAnswer ans = makeReply reply ans [] [] NoErr True -findDelegation +findAuthority :: DB -> Question - -> ([ResourceRecord], [ResourceRecord], [ResourceRecord], RCODE, Bool) -findDelegation db@DB{..} Question{..} = loop qname + -> DNSMessage + -> DNSMessage +findAuthority db@DB{..} Question{..} reply = loop qname where loop dom - | dom == dbZone = ([], [dbSOA], [], NXDomain, True) + | dom == dbZone = makeReply reply [] [dbSOA] [] NXDomain True | otherwise = case unconsDomain dom of - Nothing -> ([], [dbSOA], [], NXDomain, True) + Nothing -> makeReply reply [] [dbSOA] [] NXDomain True Just (_, dom') -> case M.lookup dom dbAuthority of Nothing -> loop dom' Just auth - | null auth -> ([], [dbSOA], [], NoErr, True) + | null auth -> makeReply reply [] [dbSOA] [] NoErr True | otherwise -> let add = findAdditional db auth - in ([], auth, add, NoErr, False) + in makeReply reply [] auth add NoErr False findAdditional :: DB -> [ResourceRecord] -> [ResourceRecord] findAdditional DB{..} auth0 = add @@ -94,3 +83,13 @@ findAdditional DB{..} auth0 = add extractNS rr = case fromRData $ rdata rr of Nothing -> Nothing Just ns -> Just $ ns_domain ns + +makeReply :: DNSMessage -> Answers -> AuthorityRecords -> AdditionalRecords -> RCODE -> Bool -> DNSMessage +makeReply reply ans auth add code aa = + reply + { answer = ans + , authority = auth + , additional = add + , rcode = code + , flags = (flags reply){authAnswer = aa} + } From c3cb25f071ef5337310772949bda014884ad2d68 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 8 Feb 2026 20:57:12 +0900 Subject: [PATCH 18/74] comments --- dnsext-auth/DNS/Auth/DB.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs index b25646c97..62fc53d0a 100644 --- a/dnsext-auth/DNS/Auth/DB.hs +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -59,11 +59,19 @@ make (zone, soa : rrs) (as, ns, _os) = partition3 zone rrs isDelegated = makeIsDelegated ns (gs, zs) = partition (\r -> isDelegated (rrname r)) as + -- gs: glue (in delegated domain) + -- zs: in-domain ans = makeMap $ [soa] ++ zs auth = makeMap ns add = makeMap gs -partition3 :: Domain -> [ResourceRecord] -> ([ResourceRecord], [ResourceRecord], [ResourceRecord]) +partition3 + :: Domain + -> [ResourceRecord] + -> ( [ResourceRecord] -- Possible in-domain + , [ResourceRecord] -- NS except this domain + , [ResourceRecord] -- Unrelated, ignored + ) partition3 dom rrs0 = loop rrs0 [] [] [] where loop [] as ns os = (as, ns, os) From ba0003828accc6b621dddacb55b1acc47b717724 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Feb 2026 09:20:06 +0900 Subject: [PATCH 19/74] fixing typo --- dnsext-auth/DNS/Auth/Algorithm.hs | 2 +- dnsext-auth/DNS/Auth/DB.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index ccdac9b42..62f993694 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -77,7 +77,7 @@ findAdditional DB{..} auth0 = add where doms = nub $ sort $ catMaybes $ map extractNS auth0 add = concat $ map lookupAdd doms - lookupAdd dom = case M.lookup dom dbAdditiona of + lookupAdd dom = case M.lookup dom dbAdditional of Nothing -> [] Just rs -> rs extractNS rr = case fromRData $ rdata rr of diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs index 62fc53d0a..ac0a92a16 100644 --- a/dnsext-auth/DNS/Auth/DB.hs +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -19,7 +19,7 @@ data DB = DB , dbSOA :: ResourceRecord , dbAnswer :: M.Map Domain [ResourceRecord] , dbAuthority :: M.Map Domain [ResourceRecord] - , dbAdditiona :: M.Map Domain [ResourceRecord] + , dbAdditional :: M.Map Domain [ResourceRecord] } deriving (Show) @@ -50,7 +50,7 @@ make (zone, soa : rrs) , dbSOA = soa , dbAnswer = ans , dbAuthority = auth - , dbAdditiona = add + , dbAdditional = add } where -- RFC 9471 From 90193d9524ac9434a838b3c2242bb47fbfae0733 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Feb 2026 09:15:06 +0900 Subject: [PATCH 20/74] answering NS of this zone correctly --- dnsext-auth/DNS/Auth/Algorithm.hs | 20 ++++++++++++++------ dnsext-auth/DNS/Auth/DB.hs | 3 ++- dnsext-auth/test/AlgorithmSpec.hs | 10 ++++++++++ 3 files changed, 26 insertions(+), 7 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 62f993694..0f6aa1241 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -48,10 +48,15 @@ getAnswer db query processPositive :: DB -> Question -> DNSMessage -> DNSMessage processPositive db@DB{..} q@Question{..} reply = case M.lookup qname dbAnswer of Nothing -> findAuthority db q reply - Just rs -> makeAnswer $ filter (\r -> rrtype r == qtype) rs + Just rs -> + let ans = filter (\r -> rrtype r == qtype) rs + add + | qtype == NS = findAdditional db rs + | otherwise = [] + in makeAnswer ans add where - makeAnswer [] = makeReply reply [] [dbSOA] [] NoErr True - makeAnswer ans = makeReply reply ans [] [] NoErr True + makeAnswer [] add = makeReply reply [] [dbSOA] add NoErr True + makeAnswer ans add = makeReply reply ans [] add NoErr True findAuthority :: DB @@ -72,10 +77,13 @@ findAuthority db@DB{..} Question{..} reply = loop qname let add = findAdditional db auth in makeReply reply [] auth add NoErr False -findAdditional :: DB -> [ResourceRecord] -> [ResourceRecord] -findAdditional DB{..} auth0 = add +findAdditional + :: DB + -> [ResourceRecord] -- NSs in Answer or Authority + -> [ResourceRecord] +findAdditional DB{..} rs0 = add where - doms = nub $ sort $ catMaybes $ map extractNS auth0 + doms = nub $ sort $ catMaybes $ map extractNS rs0 add = concat $ map lookupAdd doms lookupAdd dom = case M.lookup dom dbAdditional of Nothing -> [] diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs index ac0a92a16..1edd7749f 100644 --- a/dnsext-auth/DNS/Auth/DB.hs +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -63,7 +63,8 @@ make (zone, soa : rrs) -- zs: in-domain ans = makeMap $ [soa] ++ zs auth = makeMap ns - add = makeMap gs + xs = filter (\r -> rrtype r == A || rrtype r == AAAA) zs + add = makeMap $ xs ++ gs partition3 :: Domain diff --git a/dnsext-auth/test/AlgorithmSpec.hs b/dnsext-auth/test/AlgorithmSpec.hs index 44015a360..7cd284e61 100644 --- a/dnsext-auth/test/AlgorithmSpec.hs +++ b/dnsext-auth/test/AlgorithmSpec.hs @@ -51,6 +51,16 @@ spec = describe "authoritative algorithm" $ do additional ans `shouldSatisfy` include "ns.in.example.jp." A additional ans `shouldSatisfy` include "ns.sibling.example.jp." A flags ans `shouldSatisfy` not . authAnswer + it "returns AA for NS of this domain" $ do + let query = defaultQuery{question = Question "example.jp." NS IN} + ans = getAnswer db query + rcode ans `shouldBe` NoErr + length (answer ans) `shouldBe` 1 + answer ans `shouldSatisfy` includeNS "ns.example.jp." + length (authority ans) `shouldBe` 0 + length (additional ans) `shouldBe` 1 + additional ans `shouldSatisfy` include "ns.example.jp." A + flags ans `shouldSatisfy` authAnswer includeNS :: Domain -> [ResourceRecord] -> Bool includeNS dom rs = any has rs From d41638fb49747e35b2e4fb1d940c66f37aca6a64 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Feb 2026 09:33:50 +0900 Subject: [PATCH 21/74] comments --- dnsext-auth/DNS/Auth/Algorithm.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 0f6aa1241..3227b3b65 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -55,6 +55,7 @@ processPositive db@DB{..} q@Question{..} reply = case M.lookup qname dbAnswer of | otherwise = [] in makeAnswer ans add where + -- RFC2308 Sec 2.2 No Data makeAnswer [] add = makeReply reply [] [dbSOA] add NoErr True makeAnswer ans add = makeReply reply ans [] add NoErr True From 76a4a11c720c3f47addc3ac2351cf5467190c3ca Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Feb 2026 09:41:44 +0900 Subject: [PATCH 22/74] implementing RFC 8482 (QTYPE=ANY) --- dnsext-auth/DNS/Auth/Algorithm.hs | 6 +++++- dnsext-auth/test/AlgorithmSpec.hs | 9 +++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 3227b3b65..1693869bb 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -49,7 +49,11 @@ processPositive :: DB -> Question -> DNSMessage -> DNSMessage processPositive db@DB{..} q@Question{..} reply = case M.lookup qname dbAnswer of Nothing -> findAuthority db q reply Just rs -> - let ans = filter (\r -> rrtype r == qtype) rs + let ans + -- RFC 8482 Sec 4.1 + -- Answer with a Subset of Available RRsets + | qtype == ANY = take 1 rs + | otherwise = filter (\r -> rrtype r == qtype) rs add | qtype == NS = findAdditional db rs | otherwise = [] diff --git a/dnsext-auth/test/AlgorithmSpec.hs b/dnsext-auth/test/AlgorithmSpec.hs index 7cd284e61..b159ea62b 100644 --- a/dnsext-auth/test/AlgorithmSpec.hs +++ b/dnsext-auth/test/AlgorithmSpec.hs @@ -61,6 +61,15 @@ spec = describe "authoritative algorithm" $ do length (additional ans) `shouldBe` 1 additional ans `shouldSatisfy` include "ns.example.jp." A flags ans `shouldSatisfy` authAnswer + it "returns a single minimum RR for ANY" $ do + let query = defaultQuery{question = Question "exist.example.jp." ANY IN} + ans = getAnswer db query + rcode ans `shouldBe` NoErr + length (answer ans) `shouldBe` 1 + answer ans `shouldSatisfy` include "exist.example.jp." A + length (authority ans) `shouldBe` 0 + length (additional ans) `shouldBe` 0 + flags ans `shouldSatisfy` authAnswer includeNS :: Domain -> [ResourceRecord] -> Bool includeNS dom rs = any has rs From 62e7386c73fcefb5e8ffccaee332e1223a8e2de2 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Feb 2026 10:21:07 +0900 Subject: [PATCH 23/74] refactoring --- dnsext-auth/DNS/Auth/Algorithm.hs | 18 ++++++++---------- dnsext-auth/test/example.zone | 23 ++++++++++++----------- 2 files changed, 20 insertions(+), 21 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 1693869bb..fa530df64 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -48,16 +48,14 @@ getAnswer db query processPositive :: DB -> Question -> DNSMessage -> DNSMessage processPositive db@DB{..} q@Question{..} reply = case M.lookup qname dbAnswer of Nothing -> findAuthority db q reply - Just rs -> - let ans - -- RFC 8482 Sec 4.1 - -- Answer with a Subset of Available RRsets - | qtype == ANY = take 1 rs - | otherwise = filter (\r -> rrtype r == qtype) rs - add - | qtype == NS = findAdditional db rs - | otherwise = [] - in makeAnswer ans add + Just rs -> case qtype of + -- RFC 8482 Sec 4.1 + -- Answer with a Subset of Available RRsets + ANY -> makeAnswer (take 1 rs) [] + _ -> + let ans = filter (\r -> rrtype r == qtype) rs + add = if qtype == NS then findAdditional db ans else [] + in makeAnswer ans add where -- RFC2308 Sec 2.2 No Data makeAnswer [] add = makeReply reply [] [dbSOA] add NoErr True diff --git a/dnsext-auth/test/example.zone b/dnsext-auth/test/example.zone index b2b44827c..6ee79d1aa 100644 --- a/dnsext-auth/test/example.zone +++ b/dnsext-auth/test/example.zone @@ -1,5 +1,5 @@ @ IN SOA ns.example.jp. hostmaster.example.jp. ( - 870769 ;serial + 870771 ;serial 1800 ;refresh every 30 minutes 300 ;retry every 5 minutes 604800 ;expire after a week @@ -7,13 +7,14 @@ ) NS ns.example.jp. -ns.example.jp. 3600 A 192.0.2.1 -exist.example.jp. 3600 A 192.0.2.2 - 3600 AAAA 2001:0db8::2 -in.example.jp. 3600 NS ns.in.example.jp. - 3600 NS ns.sibling.example.jp. - 3600 NS unrelated.com. -ns.in.example.jp. 3600 A 192.0.2.3 ; glue -sibling.example.jp. 3600 NS ns.sibling.example.jp. -ns.sibling.example.jp. 3600 A 192.0.2.4 ; glue -unrelated.com. 3609 A 192.0.2.10 ; glue +ns.example.jp. 3600 A 192.0.2.1 +exist.example.jp. 3600 A 192.0.2.2 + 3600 AAAA 2001:0db8::2 +in.example.jp. 3600 NS ns.in.example.jp. + 3600 NS ns.sibling.example.jp. + 3600 NS unrelated.com. +ns.in.example.jp. 3600 A 192.0.2.3 ; glue +sibling.example.jp. 3600 NS ns.sibling.example.jp. +ns.sibling.example.jp. 3600 A 192.0.2.4 ; glue +unrelated.com. 3600 A 192.0.2.10 ; glue +exist-cname.example.jp 3600 CNAME exist.example.jp. From 4bf3775e13ec9fb9ad576e397b023b939715672d Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Feb 2026 10:23:43 +0900 Subject: [PATCH 24/74] refactoring --- dnsext-auth/DNS/Auth/Algorithm.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index fa530df64..f45008b3e 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -48,11 +48,11 @@ getAnswer db query processPositive :: DB -> Question -> DNSMessage -> DNSMessage processPositive db@DB{..} q@Question{..} reply = case M.lookup qname dbAnswer of Nothing -> findAuthority db q reply - Just rs -> case qtype of + Just rs -- RFC 8482 Sec 4.1 -- Answer with a Subset of Available RRsets - ANY -> makeAnswer (take 1 rs) [] - _ -> + | qtype == ANY -> makeAnswer (take 1 rs) [] + | otherwise -> let ans = filter (\r -> rrtype r == qtype) rs add = if qtype == NS then findAdditional db ans else [] in makeAnswer ans add From 5d6e7a2231f77feb86c9ffde8f5791bc6ee20d06 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Feb 2026 10:36:44 +0900 Subject: [PATCH 25/74] handling CNAME --- dnsext-auth/DNS/Auth/Algorithm.hs | 34 ++++++++++++++++++--------- dnsext-auth/test/AlgorithmSpec.hs | 39 +++++++++++++++++++++++++++++++ dnsext-auth/test/example.zone | 26 +++++++++++---------- 3 files changed, 76 insertions(+), 23 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index f45008b3e..49738256c 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -6,7 +6,7 @@ module DNS.Auth.Algorithm ( import Data.List (nub, sort) import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe) import DNS.Auth.DB import DNS.Types @@ -52,15 +52,31 @@ processPositive db@DB{..} q@Question{..} reply = case M.lookup qname dbAnswer of -- RFC 8482 Sec 4.1 -- Answer with a Subset of Available RRsets | qtype == ANY -> makeAnswer (take 1 rs) [] - | otherwise -> - let ans = filter (\r -> rrtype r == qtype) rs - add = if qtype == NS then findAdditional db ans else [] - in makeAnswer ans add + | otherwise -> case filter (\r -> rrtype r == CNAME) rs of + [] -> + let ans = filter (\r -> rrtype r == qtype) rs + add = if qtype == NS then findAdditional db ans else [] + in makeAnswer ans add + [c] | length rs == 1 -> case fromRData $ rdata c of + Nothing -> error "processPositive: never reached" + Just cname -> processCNAME db q reply c $ cname_domain cname + _ -> error "processPositive: multiple CNAMEs" where -- RFC2308 Sec 2.2 No Data makeAnswer [] add = makeReply reply [] [dbSOA] add NoErr True makeAnswer ans add = makeReply reply ans [] add NoErr True +processCNAME :: DB -> Question -> DNSMessage -> ResourceRecord -> Domain -> DNSMessage +processCNAME DB{..} Question{..} reply c cname + | qtype == CNAME = makeReply reply [c] [] add NoErr True + where + add = fromMaybe [] $ M.lookup cname dbAdditional +processCNAME DB{..} Question{..} reply c cname = makeReply reply ans [] [] NoErr True + where + ans = case M.lookup cname dbAnswer of + Nothing -> [c] + Just rs -> [c] ++ filter (\r -> rrtype r == qtype) rs + findAuthority :: DB -> Question @@ -88,12 +104,8 @@ findAdditional DB{..} rs0 = add where doms = nub $ sort $ catMaybes $ map extractNS rs0 add = concat $ map lookupAdd doms - lookupAdd dom = case M.lookup dom dbAdditional of - Nothing -> [] - Just rs -> rs - extractNS rr = case fromRData $ rdata rr of - Nothing -> Nothing - Just ns -> Just $ ns_domain ns + lookupAdd dom = fromMaybe [] $ M.lookup dom dbAdditional + extractNS rr = ns_domain <$> fromRData (rdata rr) makeReply :: DNSMessage -> Answers -> AuthorityRecords -> AdditionalRecords -> RCODE -> Bool -> DNSMessage makeReply reply ans auth add code aa = diff --git a/dnsext-auth/test/AlgorithmSpec.hs b/dnsext-auth/test/AlgorithmSpec.hs index b159ea62b..e9f9d0473 100644 --- a/dnsext-auth/test/AlgorithmSpec.hs +++ b/dnsext-auth/test/AlgorithmSpec.hs @@ -70,6 +70,45 @@ spec = describe "authoritative algorithm" $ do length (authority ans) `shouldBe` 0 length (additional ans) `shouldBe` 0 flags ans `shouldSatisfy` authAnswer + it "can handle existing CNAME" $ do + let query = defaultQuery{question = Question "exist-cname.example.jp." A IN} + ans = getAnswer db query + rcode ans `shouldBe` NoErr + length (answer ans) `shouldBe` 2 + answer ans `shouldSatisfy` include "exist-cname.example.jp." CNAME + answer ans `shouldSatisfy` include "exist.example.jp." A + length (authority ans) `shouldBe` 0 + length (additional ans) `shouldBe` 0 + flags ans `shouldSatisfy` authAnswer + it "can handle non-existing CNAME" $ do + let query = defaultQuery{question = Question "fault-cname.example.jp." A IN} + ans = getAnswer db query + rcode ans `shouldBe` NoErr + length (answer ans) `shouldBe` 1 + answer ans `shouldSatisfy` include "fault-cname.example.jp." CNAME + length (authority ans) `shouldBe` 0 + length (additional ans) `shouldBe` 0 + flags ans `shouldSatisfy` authAnswer + it "can handle unrelated CNAME" $ do + let query = defaultQuery{question = Question "ext-cname.example.jp." A IN} + ans = getAnswer db query + rcode ans `shouldBe` NoErr + length (answer ans) `shouldBe` 1 + answer ans `shouldSatisfy` include "ext-cname.example.jp." CNAME + length (authority ans) `shouldBe` 0 + length (additional ans) `shouldBe` 0 + flags ans `shouldSatisfy` authAnswer + it "can handle existing CNAME for CNAME query" $ do + let query = defaultQuery{question = Question "exist-cname.example.jp." CNAME IN} + ans = getAnswer db query + rcode ans `shouldBe` NoErr + length (answer ans) `shouldBe` 1 + answer ans `shouldSatisfy` include "exist-cname.example.jp." CNAME + length (authority ans) `shouldBe` 0 + length (additional ans) `shouldBe` 2 + additional ans `shouldSatisfy` include "exist.example.jp." A + additional ans `shouldSatisfy` include "exist.example.jp." AAAA + flags ans `shouldSatisfy` authAnswer includeNS :: Domain -> [ResourceRecord] -> Bool includeNS dom rs = any has rs diff --git a/dnsext-auth/test/example.zone b/dnsext-auth/test/example.zone index 6ee79d1aa..781d195a8 100644 --- a/dnsext-auth/test/example.zone +++ b/dnsext-auth/test/example.zone @@ -1,5 +1,5 @@ @ IN SOA ns.example.jp. hostmaster.example.jp. ( - 870771 ;serial + 870776 ;serial 1800 ;refresh every 30 minutes 300 ;retry every 5 minutes 604800 ;expire after a week @@ -7,14 +7,16 @@ ) NS ns.example.jp. -ns.example.jp. 3600 A 192.0.2.1 -exist.example.jp. 3600 A 192.0.2.2 - 3600 AAAA 2001:0db8::2 -in.example.jp. 3600 NS ns.in.example.jp. - 3600 NS ns.sibling.example.jp. - 3600 NS unrelated.com. -ns.in.example.jp. 3600 A 192.0.2.3 ; glue -sibling.example.jp. 3600 NS ns.sibling.example.jp. -ns.sibling.example.jp. 3600 A 192.0.2.4 ; glue -unrelated.com. 3600 A 192.0.2.10 ; glue -exist-cname.example.jp 3600 CNAME exist.example.jp. +ns.example.jp. 3600 A 192.0.2.1 +exist.example.jp. 3600 A 192.0.2.2 + 3600 AAAA 2001:0db8::2 +in.example.jp. 3600 NS ns.in.example.jp. + 3600 NS ns.sibling.example.jp. + 3600 NS unrelated.com. +ns.in.example.jp. 3600 A 192.0.2.3 ; glue +sibling.example.jp. 3600 NS ns.sibling.example.jp. +ns.sibling.example.jp. 3600 A 192.0.2.4 ; glue +unrelated.com. 3600 A 192.0.2.10 ; glue +exist-cname.example.jp. 3600 CNAME exist.example.jp. +fault-cname.example.jp. 3600 CNAME nonexist.example.jp. +ext-cname.example.jp. 3600 CNAME foo.unrelated.com. From e91a11e9e1aab1d7249f0a16e1f391c6490475fb Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Feb 2026 12:52:48 +0900 Subject: [PATCH 26/74] comment --- dnsext-auth/DNS/Auth/Algorithm.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 49738256c..303d5e2ea 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -66,6 +66,8 @@ processPositive db@DB{..} q@Question{..} reply = case M.lookup qname dbAnswer of makeAnswer [] add = makeReply reply [] [dbSOA] add NoErr True makeAnswer ans add = makeReply reply ans [] add NoErr True +-- RFC 1912 Sec 2.4 CNAME records +-- This function does not follow CNAME of CNAME. processCNAME :: DB -> Question -> DNSMessage -> ResourceRecord -> Domain -> DNSMessage processCNAME DB{..} Question{..} reply c cname | qtype == CNAME = makeReply reply [c] [] add NoErr True From 1cf8bc324c3e90e7a517f8a5e553ff9ac8c6c918 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Feb 2026 12:53:41 +0900 Subject: [PATCH 27/74] using example.zone --- dnsext-bowline/clove/clove.conf | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dnsext-bowline/clove/clove.conf b/dnsext-bowline/clove/clove.conf index 451593704..0f8ea7c6e 100644 --- a/dnsext-bowline/clove/clove.conf +++ b/dnsext-bowline/clove/clove.conf @@ -1,5 +1,5 @@ -zone-name: edu -zone-file: zone/edu.zone +zone-name: example.jp +zone-file: zone/example.zone dns-addrs: 127.0.0.1,::1 udp: yes udp-port: 53 From 0bf2bc741b6438e519168a761f45047f3f94bd6c Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 9 Feb 2026 18:12:20 +0900 Subject: [PATCH 28/74] using isSubDomainOf --- dnsext-auth/DNS/Auth/Algorithm.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 303d5e2ea..69640f4d5 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -72,7 +72,10 @@ processCNAME :: DB -> Question -> DNSMessage -> ResourceRecord -> Domain -> DNSM processCNAME DB{..} Question{..} reply c cname | qtype == CNAME = makeReply reply [c] [] add NoErr True where - add = fromMaybe [] $ M.lookup cname dbAdditional + add + | cname `isSubDomainOf` dbZone = + fromMaybe [] $ M.lookup cname dbAdditional + | otherwise = [] processCNAME DB{..} Question{..} reply c cname = makeReply reply ans [] [] NoErr True where ans = case M.lookup cname dbAnswer of @@ -104,7 +107,8 @@ findAdditional -> [ResourceRecord] findAdditional DB{..} rs0 = add where - doms = nub $ sort $ catMaybes $ map extractNS rs0 + doms0 = nub $ sort $ catMaybes $ map extractNS rs0 + doms = filter (\d -> d `isSubDomainOf` dbZone) doms0 add = concat $ map lookupAdd doms lookupAdd dom = fromMaybe [] $ M.lookup dom dbAdditional extractNS rr = ns_domain <$> fromRData (rdata rr) From 572417be0ed0d609f2b0ae79ad43f0ce3db1fe9f Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 10 Feb 2026 14:50:42 +0900 Subject: [PATCH 29/74] guarding getAnswer --- dnsext-auth/DNS/Auth/Algorithm.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 69640f4d5..4a8f7afd2 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -19,11 +19,16 @@ getAnswer :: DB -> DNSMessage -> DNSMessage getAnswer db query -- RFC 8906: Sec 3.1.4 | opcode query /= OP_STD = reply{rcode = NotImpl} + | isResponse (flags query) = reply{rcode = Refused} + | qtype q `elem` [AXFR, IXFR] = reply{rcode = Refused} | not (qname q `isSubDomainOf` dbZone db) = reply { rcode = Refused , flags = flgs{authAnswer = False} } + -- RFC 8906 Sec3.1.3.1. Recursive Queries + -- A non-recursive server is supposed to respond to recursive + -- queries as if the Recursion Desired (RD) bit is not set. | otherwise = processPositive db q reply where q = question query From 144920dcee243f5290c43d449c2d1dac25abf2f4 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 10 Feb 2026 16:15:28 +0900 Subject: [PATCH 30/74] setting identifier correctly --- dnsext-auth/DNS/Auth/Algorithm.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 4a8f7afd2..f9247c5f8 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -48,7 +48,12 @@ getAnswer db query , authenData = False , chkDisable = False } - reply = query{flags = flgs, ednsHeader = ednsH} + reply = + query + { identifier = identifier query + , flags = flgs + , ednsHeader = ednsH + } processPositive :: DB -> Question -> DNSMessage -> DNSMessage processPositive db@DB{..} q@Question{..} reply = case M.lookup qname dbAnswer of From 839936de140aba4ca9dfb6f395525a4ef55b6802 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 10 Feb 2026 16:19:11 +0900 Subject: [PATCH 31/74] re-exporting DB --- dnsext-auth/DNS/Auth/Algorithm.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index f9247c5f8..44233386d 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -2,6 +2,7 @@ module DNS.Auth.Algorithm ( getAnswer, + DB (..), ) where import Data.List (nub, sort) From 83f6994bb5ace8fe0f7d468c13f767688f0161b5 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 10 Feb 2026 16:07:08 +0900 Subject: [PATCH 32/74] implementing axfr --- dnsext-auth/DNS/Auth/DB.hs | 2 ++ dnsext-bowline/clove/Axfr.hs | 24 ++++++++++++++++++++++++ dnsext-bowline/clove/clove.hs | 6 ++++++ dnsext-bowline/dnsext-bowline.cabal | 7 +++++-- 4 files changed, 37 insertions(+), 2 deletions(-) create mode 100644 dnsext-bowline/clove/Axfr.hs diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs index 1edd7749f..d6096709b 100644 --- a/dnsext-auth/DNS/Auth/DB.hs +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -20,6 +20,7 @@ data DB = DB , dbAnswer :: M.Map Domain [ResourceRecord] , dbAuthority :: M.Map Domain [ResourceRecord] , dbAdditional :: M.Map Domain [ResourceRecord] + , dbAll :: [ResourceRecord] } deriving (Show) @@ -51,6 +52,7 @@ make (zone, soa : rrs) , dbAnswer = ans , dbAuthority = auth , dbAdditional = add + , dbAll = [soa] ++ rrs ++ [soa] } where -- RFC 9471 diff --git a/dnsext-bowline/clove/Axfr.hs b/dnsext-bowline/clove/Axfr.hs new file mode 100644 index 000000000..379833a93 --- /dev/null +++ b/dnsext-bowline/clove/Axfr.hs @@ -0,0 +1,24 @@ +module Axfr where + +import DNS.Auth.Algorithm +import DNS.Do53.Internal +import DNS.Types +import DNS.Types.Decode +import DNS.Types.Encode + +import Network.Socket + +axfr :: DB -> Socket -> IO () +axfr db sock = do + equery <- decode <$> recvVC (32 * 1024) (recvTCP sock) + case equery of + Left _ -> return () + Right query -> do + let reply + | qtype (question query) == AXFR = + makeResponse + (identifier query) + (question query) + (dbAll db) + | otherwise = getAnswer db query + sendVC (sendTCP sock) $ encode reply diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index d92139b50..5f6e4f407 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -4,10 +4,12 @@ module Main where +import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad import qualified Data.List.NonEmpty as NE +import Network.Run.TCP.Timeout import Network.Socket import qualified Network.Socket.ByteString as NSB import System.Environment (getArgs) @@ -19,6 +21,7 @@ import DNS.Types import DNS.Types.Decode import DNS.Types.Encode +import Axfr import Config ---------------------------------------------------------------- @@ -33,6 +36,9 @@ main = do Right db -> do ais <- mapM (serverResolve cnf_udp_port) cnf_dns_addrs ss <- mapM serverSocket ais + _ <- forkIO $ + runTCPServer 10 (Just "127.0.0.1") "53" $ + \_ _ s -> axfr db s mapConcurrently_ (clove db) ss ---------------------------------------------------------------- diff --git a/dnsext-bowline/dnsext-bowline.cabal b/dnsext-bowline/dnsext-bowline.cabal index ea8c21d01..4b0b551ac 100644 --- a/dnsext-bowline/dnsext-bowline.cabal +++ b/dnsext-bowline/dnsext-bowline.cabal @@ -148,7 +148,8 @@ executable ddrd executable clove main-is: clove.hs hs-source-dirs: clove - other-modules: Config + other-modules: Axfr + Config default-language: Haskell2010 ghc-options: -Wall -threaded @@ -159,8 +160,10 @@ executable clove network, -- dnsext packages dnsext-auth, + dnsext-do53, dnsext-types, - dnsext-utils + dnsext-utils, + network-run if (os(windows) && impl(ghc >=9.0)) ghc-options: -with-rtsopts=--io-manager=native From 74ffc7931f4517fc1044d518edbe7473db674756 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 10 Feb 2026 17:26:26 +0900 Subject: [PATCH 33/74] defining tcp-addrs --- dnsext-bowline/clove/Config.hs | 15 +++++++++------ dnsext-bowline/clove/clove.conf | 5 +++-- dnsext-bowline/clove/clove.hs | 15 +++++++++++---- 3 files changed, 23 insertions(+), 12 deletions(-) diff --git a/dnsext-bowline/clove/Config.hs b/dnsext-bowline/clove/Config.hs index f9596daa6..8148b2c3c 100644 --- a/dnsext-bowline/clove/Config.hs +++ b/dnsext-bowline/clove/Config.hs @@ -12,8 +12,9 @@ import System.IO.Error (ioeGetErrorString, ioeSetErrorString, tryIOError) data Config = Config { cnf_zone_name :: String , cnf_zone_file :: FilePath - , cnf_dns_addrs :: [String] - , cnf_udp :: Bool + , cnf_tcp_addrs :: [String] + , cnf_tcp_port :: PortNumber + , cnf_udp_addrs :: [String] , cnf_udp_port :: PortNumber } @@ -22,8 +23,9 @@ defaultConfig = Config { cnf_zone_name = "example.org" , cnf_zone_file = "example.conf" - , cnf_dns_addrs = ["127.0.0.1", "::1"] - , cnf_udp = True + , cnf_tcp_addrs = ["127.0.0.1", "::1"] + , cnf_tcp_port = 53 + , cnf_udp_addrs = ["127.0.0.1", "::1"] , cnf_udp_port = 53 } @@ -31,8 +33,9 @@ makeConfig :: Config -> [Conf] -> IO Config makeConfig def conf = do cnf_zone_name <- get "zone-name" cnf_zone_name cnf_zone_file <- get "zone-file" cnf_zone_file - cnf_dns_addrs <- get "dns-addrs" cnf_dns_addrs - cnf_udp <- get "udp" cnf_udp + cnf_tcp_addrs <- get "tcp-addrs" cnf_tcp_addrs + cnf_tcp_port <- get "tcp-port" cnf_tcp_port + cnf_udp_addrs <- get "udp-addrs" cnf_udp_addrs cnf_udp_port <- get "udp-port" cnf_udp_port pure Config{..} where diff --git a/dnsext-bowline/clove/clove.conf b/dnsext-bowline/clove/clove.conf index 0f8ea7c6e..905ed61e0 100644 --- a/dnsext-bowline/clove/clove.conf +++ b/dnsext-bowline/clove/clove.conf @@ -1,5 +1,6 @@ zone-name: example.jp zone-file: zone/example.zone -dns-addrs: 127.0.0.1,::1 -udp: yes +tcp-addrs: 127.0.0.1,::1 +tcp-port: 53 +udp-addrs: 127.0.0.1,::1 udp-port: 53 diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 5f6e4f407..68edb6975 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -34,15 +34,22 @@ main = do case edb of Left emsg -> die emsg Right db -> do - ais <- mapM (serverResolve cnf_udp_port) cnf_dns_addrs + _ <- + forkIO $ + mapConcurrently_ + (axfrServer db (show cnf_tcp_port)) + cnf_tcp_addrs + ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs ss <- mapM serverSocket ais - _ <- forkIO $ - runTCPServer 10 (Just "127.0.0.1") "53" $ - \_ _ s -> axfr db s mapConcurrently_ (clove db) ss ---------------------------------------------------------------- +axfrServer :: DB -> ServiceName -> HostName -> IO () +axfrServer db port addr = + runTCPServer 10 (Just addr) port $ + \_ _ s -> axfr db s + clove :: DB -> Socket -> IO () clove db s = loop where From 395128254006e928564089424808666915ee79fc Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 10 Feb 2026 17:30:57 +0900 Subject: [PATCH 34/74] using concurrently_ --- dnsext-bowline/clove/clove.hs | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 68edb6975..cd5202dbe 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -4,7 +4,6 @@ module Main where -import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad @@ -34,14 +33,11 @@ main = do case edb of Left emsg -> die emsg Right db -> do - _ <- - forkIO $ - mapConcurrently_ - (axfrServer db (show cnf_tcp_port)) - cnf_tcp_addrs + let as = map (axfrServer db (show cnf_tcp_port)) cnf_tcp_addrs ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs ss <- mapM serverSocket ais - mapConcurrently_ (clove db) ss + let cs = map (clove db) ss + foldr1 concurrently_ $ as ++ cs ---------------------------------------------------------------- From eb141ec199bf45a812ffe4b31380f90a0ad9b9e3 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 10 Feb 2026 20:09:38 +0900 Subject: [PATCH 35/74] using iproute --- dnsext-auth/DNS/Auth/Algorithm.hs | 52 ++++++++++++++++------------- dnsext-bowline/clove/Axfr.hs | 34 +++++++++++++------ dnsext-bowline/clove/Config.hs | 3 ++ dnsext-bowline/clove/clove.conf | 1 + dnsext-bowline/clove/clove.hs | 31 ++++++++++++++--- dnsext-bowline/dnsext-bowline.cabal | 1 + 6 files changed, 84 insertions(+), 38 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 44233386d..a320e0083 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -3,6 +3,7 @@ module DNS.Auth.Algorithm ( getAnswer, DB (..), + fromQuery, ) where import Data.List (nub, sort) @@ -12,6 +13,32 @@ import Data.Maybe (catMaybes, fromMaybe) import DNS.Auth.DB import DNS.Types +fromQuery :: DNSMessage -> DNSMessage +fromQuery query = + query + { -- Copy identifier + -- Copy question + flags = flgs + , ednsHeader = ednsH + } + where + -- RFC 6891: Sec 6.1.1 + ednsH = case ednsHeader query of + EDNSheader _ -> EDNSheader defaultEDNS + _ -> NoEDNS + flgs = + DNSFlags + { isResponse = True + , authAnswer = True + , trunCation = False + , -- RFC 1035 Sec 4.1.1 -- just copy + recDesired = recDesired $ flags query + , -- RFC 1034 Sec 4.3.1 + recAvailable = False + , authenData = False + , chkDisable = False + } + -- RFC 8906: Sec 3.1.3.1 -- -- A non-recursive server is supposed to respond to recursive @@ -25,7 +52,7 @@ getAnswer db query | not (qname q `isSubDomainOf` dbZone db) = reply { rcode = Refused - , flags = flgs{authAnswer = False} + , flags = (flags reply){authAnswer = False} } -- RFC 8906 Sec3.1.3.1. Recursive Queries -- A non-recursive server is supposed to respond to recursive @@ -33,28 +60,7 @@ getAnswer db query | otherwise = processPositive db q reply where q = question query - -- RFC 6891: Sec 6.1.1 - ednsH = case ednsHeader query of - EDNSheader _ -> EDNSheader defaultEDNS - _ -> NoEDNS - flgs = - DNSFlags - { isResponse = True - , authAnswer = True - , trunCation = False - , -- RFC 1035 Sec 4.1.1 -- just copy - recDesired = recDesired $ flags query - , -- RFC 1034 Sec 4.3.1 - recAvailable = False - , authenData = False - , chkDisable = False - } - reply = - query - { identifier = identifier query - , flags = flgs - , ednsHeader = ednsH - } + reply = fromQuery query processPositive :: DB -> Question -> DNSMessage -> DNSMessage processPositive db@DB{..} q@Question{..} reply = case M.lookup qname dbAnswer of diff --git a/dnsext-bowline/clove/Axfr.hs b/dnsext-bowline/clove/Axfr.hs index 379833a93..aebebe249 100644 --- a/dnsext-bowline/clove/Axfr.hs +++ b/dnsext-bowline/clove/Axfr.hs @@ -6,19 +6,31 @@ import DNS.Types import DNS.Types.Decode import DNS.Types.Encode +import Data.IP +import Data.IP.RouteTable +import qualified Data.IP.RouteTable as T +import Data.Maybe import Network.Socket -axfr :: DB -> Socket -> IO () -axfr db sock = do +axfr :: DB -> IPRTable IPv4 Bool -> IPRTable IPv6 Bool -> Socket -> IO () +axfr db t4 t6 sock = do + sa <- getSocketName sock + let ok = case fromSockAddr sa of + Just (IPv4 ip4, _) -> fromMaybe False $ T.lookup (makeAddrRange ip4 32) t4 + Just (IPv6 ip6, _) -> fromMaybe False $ T.lookup (makeAddrRange ip6 128) t6 + _ -> False equery <- decode <$> recvVC (32 * 1024) (recvTCP sock) case equery of Left _ -> return () - Right query -> do - let reply - | qtype (question query) == AXFR = - makeResponse - (identifier query) - (question query) - (dbAll db) - | otherwise = getAnswer db query - sendVC (sendTCP sock) $ encode reply + Right query + | ok -> do + let reply = makeReply db query + sendVC (sendTCP sock) $ encode reply + | otherwise -> do + let reply = (fromQuery query){rcode = Refused} + sendVC (sendTCP sock) $ encode reply + +makeReply :: DB -> DNSMessage -> DNSMessage +makeReply db query + | qtype (question query) == AXFR = (fromQuery query){answer = dbAll db} + | otherwise = getAnswer db query diff --git a/dnsext-bowline/clove/Config.hs b/dnsext-bowline/clove/Config.hs index 8148b2c3c..76dcfc6f1 100644 --- a/dnsext-bowline/clove/Config.hs +++ b/dnsext-bowline/clove/Config.hs @@ -16,6 +16,7 @@ data Config = Config , cnf_tcp_port :: PortNumber , cnf_udp_addrs :: [String] , cnf_udp_port :: PortNumber + , cnf_allow_axfr :: [String] } defaultConfig :: Config @@ -27,6 +28,7 @@ defaultConfig = , cnf_tcp_port = 53 , cnf_udp_addrs = ["127.0.0.1", "::1"] , cnf_udp_port = 53 + , cnf_allow_axfr = ["127.0.0.1", "::1"] } makeConfig :: Config -> [Conf] -> IO Config @@ -37,6 +39,7 @@ makeConfig def conf = do cnf_tcp_port <- get "tcp-port" cnf_tcp_port cnf_udp_addrs <- get "udp-addrs" cnf_udp_addrs cnf_udp_port <- get "udp-port" cnf_udp_port + cnf_allow_axfr <- get "allow-axfer" cnf_allow_axfr pure Config{..} where get k func = do diff --git a/dnsext-bowline/clove/clove.conf b/dnsext-bowline/clove/clove.conf index 905ed61e0..672315db4 100644 --- a/dnsext-bowline/clove/clove.conf +++ b/dnsext-bowline/clove/clove.conf @@ -4,3 +4,4 @@ tcp-addrs: 127.0.0.1,::1 tcp-port: 53 udp-addrs: 127.0.0.1,::1 udp-port: 53 +allow-axfer: 127.0.0.1,::1 diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index cd5202dbe..4b253c406 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -1,18 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Main where import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad +import Data.IP +import Data.IP.RouteTable import qualified Data.List.NonEmpty as NE import Network.Run.TCP.Timeout import Network.Socket import qualified Network.Socket.ByteString as NSB import System.Environment (getArgs) import System.Exit +import Text.Read import DNS.Auth.Algorithm import DNS.Auth.DB @@ -33,7 +37,10 @@ main = do case edb of Left emsg -> die emsg Right db -> do - let as = map (axfrServer db (show cnf_tcp_port)) cnf_tcp_addrs + let (a4, a6) = readIPRange cnf_allow_axfr + t4 = fromList $ map (,True) a4 + t6 = fromList $ map (,True) a6 + let as = map (axfrServer db t4 t6 (show cnf_tcp_port)) cnf_tcp_addrs ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs ss <- mapM serverSocket ais let cs = map (clove db) ss @@ -41,10 +48,16 @@ main = do ---------------------------------------------------------------- -axfrServer :: DB -> ServiceName -> HostName -> IO () -axfrServer db port addr = +axfrServer + :: DB + -> IPRTable IPv4 Bool + -> IPRTable IPv6 Bool + -> ServiceName + -> HostName + -> IO () +axfrServer db t4 t6 port addr = runTCPServer 10 (Just addr) port $ - \_ _ s -> axfr db s + \_ _ s -> axfr db t4 t6 s clove :: DB -> Socket -> IO () clove db s = loop @@ -79,3 +92,13 @@ serverSocket ai = E.bracketOnError (openSocket ai) close $ \s -> do setSocketOption s ReuseAddr 1 bind s $ addrAddress ai return s + +readIPRange :: [String] -> ([AddrRange IPv4], [AddrRange IPv6]) +readIPRange ss0 = loop id id ss0 + where + loop b4 b6 [] = (b4 [], b6 []) + loop b4 b6 (s : ss) = case readMaybe s :: Maybe (AddrRange IPv6) of + Just a6 -> loop b4 (b6 . (a6 :)) ss + Nothing -> case readMaybe s :: Maybe (AddrRange IPv4) of + Just a4 -> loop (b4 . (a4 :)) b6 ss + Nothing -> loop b4 b6 ss diff --git a/dnsext-bowline/dnsext-bowline.cabal b/dnsext-bowline/dnsext-bowline.cabal index 4b0b551ac..8d5e8ec30 100644 --- a/dnsext-bowline/dnsext-bowline.cabal +++ b/dnsext-bowline/dnsext-bowline.cabal @@ -163,6 +163,7 @@ executable clove dnsext-do53, dnsext-types, dnsext-utils, + iproute, network-run if (os(windows) && impl(ghc >=9.0)) From 37838c34b5840b1852ca5d3539790749e4b9cf7d Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Thu, 12 Feb 2026 19:49:04 +0900 Subject: [PATCH 36/74] clove: fix, case for cname point NXDomain - RFC 2308 section-2.1 --- dnsext-auth/test/AlgorithmSpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dnsext-auth/test/AlgorithmSpec.hs b/dnsext-auth/test/AlgorithmSpec.hs index e9f9d0473..323b733cd 100644 --- a/dnsext-auth/test/AlgorithmSpec.hs +++ b/dnsext-auth/test/AlgorithmSpec.hs @@ -80,10 +80,10 @@ spec = describe "authoritative algorithm" $ do length (authority ans) `shouldBe` 0 length (additional ans) `shouldBe` 0 flags ans `shouldSatisfy` authAnswer - it "can handle non-existing CNAME" $ do + it "can handle nx-domain CNAME" $ do let query = defaultQuery{question = Question "fault-cname.example.jp." A IN} ans = getAnswer db query - rcode ans `shouldBe` NoErr + rcode ans `shouldBe` NXDomain length (answer ans) `shouldBe` 1 answer ans `shouldSatisfy` include "fault-cname.example.jp." CNAME length (authority ans) `shouldBe` 0 From 518bc8deddcf57b4553e7f7bbfe32f5d8ed52087 Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Thu, 12 Feb 2026 20:09:11 +0900 Subject: [PATCH 37/74] clove: add case for cname point No Data --- dnsext-auth/test/AlgorithmSpec.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/dnsext-auth/test/AlgorithmSpec.hs b/dnsext-auth/test/AlgorithmSpec.hs index 323b733cd..e9a28c1e4 100644 --- a/dnsext-auth/test/AlgorithmSpec.hs +++ b/dnsext-auth/test/AlgorithmSpec.hs @@ -80,6 +80,15 @@ spec = describe "authoritative algorithm" $ do length (authority ans) `shouldBe` 0 length (additional ans) `shouldBe` 0 flags ans `shouldSatisfy` authAnswer + it "can handle no-data CNAME" $ do + let query = defaultQuery{question = Question "exist-cname.example.jp." TXT IN} + ans = getAnswer db query + rcode ans `shouldBe` NoErr + length (answer ans) `shouldBe` 1 + answer ans `shouldSatisfy` include "exist-cname.example.jp." CNAME + length (authority ans) `shouldBe` 0 + length (additional ans) `shouldBe` 0 + flags ans `shouldSatisfy` authAnswer it "can handle nx-domain CNAME" $ do let query = defaultQuery{question = Question "fault-cname.example.jp." A IN} ans = getAnswer db query From 76d795e8c8a0aaa2108b4de8a44b02474604b9c5 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 13 Feb 2026 09:57:50 +0900 Subject: [PATCH 38/74] fixing processCNAME according to RFC 2308 Sec 2.1 --- dnsext-auth/DNS/Auth/Algorithm.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index a320e0083..89a2ddd8d 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -93,11 +93,14 @@ processCNAME DB{..} Question{..} reply c cname | cname `isSubDomainOf` dbZone = fromMaybe [] $ M.lookup cname dbAdditional | otherwise = [] -processCNAME DB{..} Question{..} reply c cname = makeReply reply ans [] [] NoErr True +processCNAME DB{..} Question{..} reply c cname = makeReply reply ans [] [] code True where - ans = case M.lookup cname dbAnswer of - Nothing -> [c] - Just rs -> [c] ++ filter (\r -> rrtype r == qtype) rs + (ans, code) + | cname `isSubDomainOf` dbZone = case M.lookup cname dbAnswer of + -- RFC 2308 Sec 2.1 - Name Error + Nothing -> ([c], NXDomain) + Just rs -> ([c] ++ filter (\r -> rrtype r == qtype) rs, NoErr) + | otherwise = ([c], NoErr) findAuthority :: DB From dbb98a1ebbac142c72edc806e4a31a193d61c717 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 15 Feb 2026 10:27:09 +0900 Subject: [PATCH 39/74] changing keywords in config --- dnsext-bowline/clove/Config.hs | 47 ++++++++++++++++++--------------- dnsext-bowline/clove/clove.conf | 7 ++++- dnsext-bowline/clove/clove.hs | 4 +-- 3 files changed, 34 insertions(+), 24 deletions(-) diff --git a/dnsext-bowline/clove/Config.hs b/dnsext-bowline/clove/Config.hs index 76dcfc6f1..8cc1cd6ac 100644 --- a/dnsext-bowline/clove/Config.hs +++ b/dnsext-bowline/clove/Config.hs @@ -9,37 +9,41 @@ import DNS.Config import Network.Socket (PortNumber) import System.IO.Error (ioeGetErrorString, ioeSetErrorString, tryIOError) +{- FOURMOLU_DISABLE -} data Config = Config - { cnf_zone_name :: String - , cnf_zone_file :: FilePath - , cnf_tcp_addrs :: [String] - , cnf_tcp_port :: PortNumber - , cnf_udp_addrs :: [String] - , cnf_udp_port :: PortNumber - , cnf_allow_axfr :: [String] + { cnf_zone_name :: String + , cnf_source :: FilePath + , cnf_transfer :: Bool + , cnf_transfer_addrs :: [String] + , cnf_tcp_addrs :: [String] + , cnf_tcp_port :: PortNumber + , cnf_udp_addrs :: [String] + , cnf_udp_port :: PortNumber } defaultConfig :: Config defaultConfig = Config - { cnf_zone_name = "example.org" - , cnf_zone_file = "example.conf" - , cnf_tcp_addrs = ["127.0.0.1", "::1"] - , cnf_tcp_port = 53 - , cnf_udp_addrs = ["127.0.0.1", "::1"] - , cnf_udp_port = 53 - , cnf_allow_axfr = ["127.0.0.1", "::1"] + { cnf_zone_name = "example.org" + , cnf_source = "example.conf" + , cnf_transfer = False + , cnf_transfer_addrs = ["127.0.0.1", "::1"] + , cnf_tcp_addrs = ["127.0.0.1", "::1"] + , cnf_tcp_port = 53 + , cnf_udp_addrs = ["127.0.0.1", "::1"] + , cnf_udp_port = 53 } makeConfig :: Config -> [Conf] -> IO Config makeConfig def conf = do - cnf_zone_name <- get "zone-name" cnf_zone_name - cnf_zone_file <- get "zone-file" cnf_zone_file - cnf_tcp_addrs <- get "tcp-addrs" cnf_tcp_addrs - cnf_tcp_port <- get "tcp-port" cnf_tcp_port - cnf_udp_addrs <- get "udp-addrs" cnf_udp_addrs - cnf_udp_port <- get "udp-port" cnf_udp_port - cnf_allow_axfr <- get "allow-axfer" cnf_allow_axfr + cnf_zone_name <- get "zone-name" cnf_zone_name + cnf_source <- get "source" cnf_source + cnf_transfer <- get "transfer" cnf_transfer + cnf_transfer_addrs <- get "transfer-addrs" cnf_transfer_addrs + cnf_tcp_addrs <- get "tcp-addrs" cnf_tcp_addrs + cnf_tcp_port <- get "tcp-port" cnf_tcp_port + cnf_udp_addrs <- get "udp-addrs" cnf_udp_addrs + cnf_udp_port <- get "udp-port" cnf_udp_port pure Config{..} where get k func = do @@ -48,6 +52,7 @@ makeConfig def conf = do let e' = ioeSetErrorString e (k ++ ": " ++ ioeGetErrorString e) ioError e' either left pure et +{- FOURMOLU_ENABLE -} loadConfig :: FilePath -> IO Config loadConfig file = loadFile file >>= makeConfig defaultConfig diff --git a/dnsext-bowline/clove/clove.conf b/dnsext-bowline/clove/clove.conf index 672315db4..c2dda14e5 100644 --- a/dnsext-bowline/clove/clove.conf +++ b/dnsext-bowline/clove/clove.conf @@ -1,5 +1,10 @@ zone-name: example.jp -zone-file: zone/example.zone +auto-sign: yes +notify: yes +notify-addrs: 127.0.0.1, ::1 +transfer: yes +transfer-addrs: 127.0.0.1, ::1 +source: zone/example.zone tcp-addrs: 127.0.0.1,::1 tcp-port: 53 udp-addrs: 127.0.0.1,::1 diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 4b253c406..398a44809 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -33,11 +33,11 @@ main :: IO () main = do [conffile] <- getArgs Config{..} <- loadConfig conffile - edb <- loadDB cnf_zone_name cnf_zone_file + edb <- loadDB cnf_zone_name cnf_source case edb of Left emsg -> die emsg Right db -> do - let (a4, a6) = readIPRange cnf_allow_axfr + let (a4, a6) = readIPRange cnf_transfer_addrs t4 = fromList $ map (,True) a4 t6 = fromList $ map (,True) a6 let as = map (axfrServer db t4 t6 (show cnf_tcp_port)) cnf_tcp_addrs From 93e18444a3c296a2ae831c9d94709fbc54a6f100 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 15 Feb 2026 10:57:40 +0900 Subject: [PATCH 40/74] using IORef --- dnsext-bowline/clove/Axfr.hs | 15 ++++++++++++--- dnsext-bowline/clove/clove.hs | 20 ++++++++++++-------- 2 files changed, 24 insertions(+), 11 deletions(-) diff --git a/dnsext-bowline/clove/Axfr.hs b/dnsext-bowline/clove/Axfr.hs index aebebe249..a87509e4b 100644 --- a/dnsext-bowline/clove/Axfr.hs +++ b/dnsext-bowline/clove/Axfr.hs @@ -1,4 +1,6 @@ -module Axfr where +module Axfr ( + axfrResponder, +) where import DNS.Auth.Algorithm import DNS.Do53.Internal @@ -6,14 +8,20 @@ import DNS.Types import DNS.Types.Decode import DNS.Types.Encode +import Data.IORef import Data.IP import Data.IP.RouteTable import qualified Data.IP.RouteTable as T import Data.Maybe import Network.Socket -axfr :: DB -> IPRTable IPv4 Bool -> IPRTable IPv6 Bool -> Socket -> IO () -axfr db t4 t6 sock = do +axfrResponder + :: IORef DB + -> IPRTable IPv4 Bool + -> IPRTable IPv6 Bool + -> Socket + -> IO () +axfrResponder dbref t4 t6 sock = do sa <- getSocketName sock let ok = case fromSockAddr sa of Just (IPv4 ip4, _) -> fromMaybe False $ T.lookup (makeAddrRange ip4 32) t4 @@ -24,6 +32,7 @@ axfr db t4 t6 sock = do Left _ -> return () Right query | ok -> do + db <- readIORef dbref let reply = makeReply db query sendVC (sendTCP sock) $ encode reply | otherwise -> do diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 398a44809..d166d1eb6 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -23,6 +23,7 @@ import DNS.Auth.DB import DNS.Types import DNS.Types.Decode import DNS.Types.Encode +import Data.IORef import Axfr import Config @@ -37,37 +38,40 @@ main = do case edb of Left emsg -> die emsg Right db -> do + dbref <- newIORef db let (a4, a6) = readIPRange cnf_transfer_addrs t4 = fromList $ map (,True) a4 t6 = fromList $ map (,True) a6 - let as = map (axfrServer db t4 t6 (show cnf_tcp_port)) cnf_tcp_addrs + let as = map (axfrServer dbref t4 t6 (show cnf_tcp_port)) cnf_tcp_addrs ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs ss <- mapM serverSocket ais - let cs = map (clove db) ss + let cs = map (authServer dbref) ss foldr1 concurrently_ $ as ++ cs ---------------------------------------------------------------- axfrServer - :: DB + :: IORef DB -> IPRTable IPv4 Bool -> IPRTable IPv6 Bool -> ServiceName -> HostName -> IO () -axfrServer db t4 t6 port addr = +axfrServer dbref t4 t6 port addr = runTCPServer 10 (Just addr) port $ - \_ _ s -> axfr db t4 t6 s + \_ _ s -> axfrResponder dbref t4 t6 s -clove :: DB -> Socket -> IO () -clove db s = loop +authServer :: IORef DB -> Socket -> IO () +authServer dbref s = loop where loop = do (bs, sa) <- NSB.recvFrom s 2048 case decode bs of -- fixme: which RFC? Left _e -> return () - Right query -> replyQuery db s sa query + Right query -> do + db <- readIORef dbref + replyQuery db s sa query loop replyQuery :: DB -> Socket -> SockAddr -> DNSMessage -> IO () From f5dc6bf3e3f1e50c55f3f8665d9cbb9fc4a4ce61 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 15 Feb 2026 13:01:15 +0900 Subject: [PATCH 41/74] changing keywords in config --- dnsext-bowline/clove/clove.conf | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/dnsext-bowline/clove/clove.conf b/dnsext-bowline/clove/clove.conf index c2dda14e5..6871aef5b 100644 --- a/dnsext-bowline/clove/clove.conf +++ b/dnsext-bowline/clove/clove.conf @@ -1,12 +1,11 @@ zone-name: example.jp -auto-sign: yes +source: zone/example.zone +dnssec: yes notify: yes notify-addrs: 127.0.0.1, ::1 transfer: yes transfer-addrs: 127.0.0.1, ::1 -source: zone/example.zone tcp-addrs: 127.0.0.1,::1 tcp-port: 53 udp-addrs: 127.0.0.1,::1 udp-port: 53 -allow-axfer: 127.0.0.1,::1 From 4da79cb1687d27bb5960cc121323acc3258ec250 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 15 Feb 2026 19:12:04 +0900 Subject: [PATCH 42/74] defining Source --- dnsext-bowline/clove/clove.hs | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index d166d1eb6..9aa7988bc 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -30,6 +30,14 @@ import Config ---------------------------------------------------------------- +data Source + = FromFile FilePath + | FromUpstream4 IPv4 + | FromUpstream6 IPv6 + deriving (Eq, Show) + +---------------------------------------------------------------- + main :: IO () main = do [conffile] <- getArgs @@ -101,8 +109,13 @@ readIPRange :: [String] -> ([AddrRange IPv4], [AddrRange IPv6]) readIPRange ss0 = loop id id ss0 where loop b4 b6 [] = (b4 [], b6 []) - loop b4 b6 (s : ss) = case readMaybe s :: Maybe (AddrRange IPv6) of - Just a6 -> loop b4 (b6 . (a6 :)) ss - Nothing -> case readMaybe s :: Maybe (AddrRange IPv4) of - Just a4 -> loop (b4 . (a4 :)) b6 ss - Nothing -> loop b4 b6 ss + loop b4 b6 (s : ss) + | Just a6 <- readMaybe s = loop b4 (b6 . (a6 :)) ss + | Just a4 <- readMaybe s = loop (b4 . (a4 :)) b6 ss + | otherwise = loop b4 b6 ss + +readSource :: String -> Source +readSource s + | Just a6 <- readMaybe s = FromUpstream6 a6 + | Just a4 <- readMaybe s = FromUpstream4 a4 + | otherwise = FromFile s From 14d5cd8f555ab744be02f93315f82c18c6b3282e Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 16 Feb 2026 14:21:54 +0900 Subject: [PATCH 43/74] ::1 only for primary --- dnsext-bowline/clove/clove.conf | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/dnsext-bowline/clove/clove.conf b/dnsext-bowline/clove/clove.conf index 6871aef5b..97f0b85db 100644 --- a/dnsext-bowline/clove/clove.conf +++ b/dnsext-bowline/clove/clove.conf @@ -2,10 +2,10 @@ zone-name: example.jp source: zone/example.zone dnssec: yes notify: yes -notify-addrs: 127.0.0.1, ::1 +notify-addrs: ::1 transfer: yes -transfer-addrs: 127.0.0.1, ::1 -tcp-addrs: 127.0.0.1,::1 +transfer-addrs: ::1 +tcp-addrs: ::1 tcp-port: 53 -udp-addrs: 127.0.0.1,::1 +udp-addrs: ::1 udp-port: 53 From 6d548e09f9568766e73d3c4f37b5a0d11400f399 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 19 Feb 2026 07:42:53 +0900 Subject: [PATCH 44/74] AXFR client --- dnsext-auth/DNS/Auth/DB.hs | 11 ++++---- dnsext-bowline/clove/Axfr.hs | 50 ++++++++++++++++++++++++++++------- dnsext-bowline/clove/clove.hs | 22 ++++++++++++--- 3 files changed, 65 insertions(+), 18 deletions(-) diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs index d6096709b..4326fd467 100644 --- a/dnsext-auth/DNS/Auth/DB.hs +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -1,6 +1,7 @@ module DNS.Auth.DB ( DB (..), loadDB, + makeDB, ) where import Data.Function (on) @@ -27,7 +28,7 @@ data DB = DB ---------------------------------------------------------------- loadDB :: String -> FilePath -> IO (Either String DB) -loadDB zone file = make <$> loadZoneFile zone file +loadDB zone file = makeDB <$> loadZoneFile zone file loadZoneFile :: String -> FilePath -> IO (Domain, [ResourceRecord]) loadZoneFile zone file = do @@ -38,12 +39,12 @@ loadZoneFile zone file = do ---------------------------------------------------------------- -make :: (Domain, [ResourceRecord]) -> Either String DB -make (_, []) = Left "make: no resource records" +makeDB :: (Domain, [ResourceRecord]) -> Either String DB +makeDB (_, []) = Left "makeDB: no resource records" -- RFC 1035 Sec 5.2 -- Exactly one SOA RR should be present at the top of the zone. -make (zone, soa : rrs) - | rrtype soa /= SOA = Left "make: no SOA" +makeDB (zone, soa : rrs) + | rrtype soa /= SOA = Left "makeDB: no SOA" | otherwise = Right $ DB diff --git a/dnsext-bowline/clove/Axfr.hs b/dnsext-bowline/clove/Axfr.hs index a87509e4b..7348e3b01 100644 --- a/dnsext-bowline/clove/Axfr.hs +++ b/dnsext-bowline/clove/Axfr.hs @@ -1,28 +1,33 @@ +{-# LANGUAGE OverloadedLists #-} + module Axfr ( - axfrResponder, + server, + client, ) where -import DNS.Auth.Algorithm -import DNS.Do53.Internal -import DNS.Types -import DNS.Types.Decode -import DNS.Types.Encode - import Data.IORef import Data.IP import Data.IP.RouteTable import qualified Data.IP.RouteTable as T +import Data.List.NonEmpty () import Data.Maybe import Network.Socket -axfrResponder +import DNS.Auth.Algorithm +import DNS.Do53.Client +import DNS.Do53.Internal +import DNS.Types +import DNS.Types.Decode +import DNS.Types.Encode + +server :: IORef DB -> IPRTable IPv4 Bool -> IPRTable IPv6 Bool -> Socket -> IO () -axfrResponder dbref t4 t6 sock = do - sa <- getSocketName sock +server dbref t4 t6 sock = do + sa <- getPeerName sock let ok = case fromSockAddr sa of Just (IPv4 ip4, _) -> fromMaybe False $ T.lookup (makeAddrRange ip4 32) t4 Just (IPv6 ip6, _) -> fromMaybe False $ T.lookup (makeAddrRange ip6 128) t6 @@ -43,3 +48,28 @@ makeReply :: DB -> DNSMessage -> DNSMessage makeReply db query | qtype (question query) == AXFR = (fromQuery query){answer = dbAll db} | otherwise = getAnswer db query + +client :: IP -> Domain -> IO (Either DNSError DNSMessage) +client ip name = do + let riActions = + defaultResolveActions + { ractionTimeoutTime = 3000000 + } + ris = + [ defaultResolveInfo + { rinfoIP = ip + , rinfoPort = 53 + , rinfoActions = riActions + , rinfoUDPRetry = 1 + , rinfoVCLimit = 32 * 1024 + } + ] + renv = + ResolveEnv + { renvResolver = tcpResolver + , renvConcurrent = True -- should set True if multiple RIs are provided + , renvResolveInfos = ris + } + q = Question name AXFR IN + qctl = rdFlag FlagClear <> doFlag FlagClear + fmap replyDNSMessage <$> resolve renv q qctl diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 9aa7988bc..196519e4f 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -25,7 +25,7 @@ import DNS.Types.Decode import DNS.Types.Encode import Data.IORef -import Axfr +import qualified Axfr as Axfr import Config ---------------------------------------------------------------- @@ -42,7 +42,7 @@ main :: IO () main = do [conffile] <- getArgs Config{..} <- loadConfig conffile - edb <- loadDB cnf_zone_name cnf_source + edb <- loadSource cnf_zone_name cnf_source case edb of Left emsg -> die emsg Right db -> do @@ -67,7 +67,7 @@ axfrServer -> IO () axfrServer dbref t4 t6 port addr = runTCPServer 10 (Just addr) port $ - \_ _ s -> axfrResponder dbref t4 t6 s + \_ _ s -> Axfr.server dbref t4 t6 s authServer :: IORef DB -> Socket -> IO () authServer dbref s = loop @@ -119,3 +119,19 @@ readSource s | Just a6 <- readMaybe s = FromUpstream6 a6 | Just a4 <- readMaybe s = FromUpstream4 a4 | otherwise = FromFile s + +loadSource :: String -> String -> IO (Either String DB) +loadSource zone src = case readSource src of + FromUpstream4 ip4 -> do + emsg <- Axfr.client (IPv4 ip4) dom + case emsg of + Left _e -> return $ Left $ show _e + Right reply -> return $ makeDB (dom, answer reply) + FromUpstream6 ip6 -> do + emsg <- Axfr.client (IPv6 ip6) dom + case emsg of + Left _e -> return $ Left $ show _e + Right reply -> return $ makeDB (dom, answer reply) + FromFile fn -> loadDB zone fn + where + dom = fromRepresentation zone From 8bf7d330dc61c18bb818a41f0a811700e42d3240 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 16 Feb 2026 16:01:28 +0900 Subject: [PATCH 45/74] better key names --- dnsext-bowline/clove/Config.hs | 48 ++++++++++++++++----------------- dnsext-bowline/clove/clove.conf | 14 +++++----- dnsext-bowline/clove/clove.hs | 4 +-- 3 files changed, 33 insertions(+), 33 deletions(-) diff --git a/dnsext-bowline/clove/Config.hs b/dnsext-bowline/clove/Config.hs index 8cc1cd6ac..ad476b893 100644 --- a/dnsext-bowline/clove/Config.hs +++ b/dnsext-bowline/clove/Config.hs @@ -11,39 +11,39 @@ import System.IO.Error (ioeGetErrorString, ioeSetErrorString, tryIOError) {- FOURMOLU_DISABLE -} data Config = Config - { cnf_zone_name :: String - , cnf_source :: FilePath - , cnf_transfer :: Bool - , cnf_transfer_addrs :: [String] - , cnf_tcp_addrs :: [String] - , cnf_tcp_port :: PortNumber - , cnf_udp_addrs :: [String] - , cnf_udp_port :: PortNumber + { cnf_zone :: String + , cnf_source :: FilePath + , cnf_allow_transfer :: Bool + , cnf_allow_transfer_addrs :: [String] + , cnf_tcp_addrs :: [String] + , cnf_tcp_port :: PortNumber + , cnf_udp_addrs :: [String] + , cnf_udp_port :: PortNumber } defaultConfig :: Config defaultConfig = Config - { cnf_zone_name = "example.org" - , cnf_source = "example.conf" - , cnf_transfer = False - , cnf_transfer_addrs = ["127.0.0.1", "::1"] - , cnf_tcp_addrs = ["127.0.0.1", "::1"] - , cnf_tcp_port = 53 - , cnf_udp_addrs = ["127.0.0.1", "::1"] - , cnf_udp_port = 53 + { cnf_zone = "example.org" + , cnf_source = "example.conf" + , cnf_allow_transfer = False + , cnf_allow_transfer_addrs = ["127.0.0.1", "::1"] + , cnf_tcp_addrs = ["127.0.0.1", "::1"] + , cnf_tcp_port = 53 + , cnf_udp_addrs = ["127.0.0.1", "::1"] + , cnf_udp_port = 53 } makeConfig :: Config -> [Conf] -> IO Config makeConfig def conf = do - cnf_zone_name <- get "zone-name" cnf_zone_name - cnf_source <- get "source" cnf_source - cnf_transfer <- get "transfer" cnf_transfer - cnf_transfer_addrs <- get "transfer-addrs" cnf_transfer_addrs - cnf_tcp_addrs <- get "tcp-addrs" cnf_tcp_addrs - cnf_tcp_port <- get "tcp-port" cnf_tcp_port - cnf_udp_addrs <- get "udp-addrs" cnf_udp_addrs - cnf_udp_port <- get "udp-port" cnf_udp_port + cnf_zone <- get "zone" cnf_zone + cnf_source <- get "source" cnf_source + cnf_allow_transfer <- get "allow-transfer" cnf_allow_transfer + cnf_allow_transfer_addrs <- get "allow-transfer-addrs" cnf_allow_transfer_addrs + cnf_tcp_addrs <- get "tcp-addrs" cnf_tcp_addrs + cnf_tcp_port <- get "tcp-port" cnf_tcp_port + cnf_udp_addrs <- get "udp-addrs" cnf_udp_addrs + cnf_udp_port <- get "udp-port" cnf_udp_port pure Config{..} where get k func = do diff --git a/dnsext-bowline/clove/clove.conf b/dnsext-bowline/clove/clove.conf index 97f0b85db..1b0825b8c 100644 --- a/dnsext-bowline/clove/clove.conf +++ b/dnsext-bowline/clove/clove.conf @@ -1,10 +1,10 @@ -zone-name: example.jp -source: zone/example.zone -dnssec: yes -notify: yes -notify-addrs: ::1 -transfer: yes -transfer-addrs: ::1 +zone: example.jp + source: zone/example.zone + dnssec: yes + notify: yes + notify-addrs: ::1 + allow-transfer: yes + allow-transfer-addrs: ::1 tcp-addrs: ::1 tcp-port: 53 udp-addrs: ::1 diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 196519e4f..e19d0bc61 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -42,12 +42,12 @@ main :: IO () main = do [conffile] <- getArgs Config{..} <- loadConfig conffile - edb <- loadSource cnf_zone_name cnf_source + edb <- loadSource cnf_zone cnf_source case edb of Left emsg -> die emsg Right db -> do dbref <- newIORef db - let (a4, a6) = readIPRange cnf_transfer_addrs + let (a4, a6) = readIPRange cnf_allow_transfer_addrs t4 = fromList $ map (,True) a4 t6 = fromList $ map (,True) a6 let as = map (axfrServer dbref t4 t6 (show cnf_tcp_port)) cnf_tcp_addrs From 8669417215dc7ef5b50553d6d8d26a1bd152dc08 Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Mon, 16 Feb 2026 14:26:42 +0900 Subject: [PATCH 46/74] update test-zone for ENT --- dnsext-auth/test/example.zone | 1 + 1 file changed, 1 insertion(+) diff --git a/dnsext-auth/test/example.zone b/dnsext-auth/test/example.zone index 781d195a8..680bd6c28 100644 --- a/dnsext-auth/test/example.zone +++ b/dnsext-auth/test/example.zone @@ -20,3 +20,4 @@ unrelated.com. 3600 A 192.0.2.10 ; glue exist-cname.example.jp. 3600 CNAME exist.example.jp. fault-cname.example.jp. 3600 CNAME nonexist.example.jp. ext-cname.example.jp. 3600 CNAME foo.unrelated.com. +a.ent2.ent1.example.jp. 3600 A 192.0.2.5 From 5b936d947677f273edd4afbf5c429d738701d7b7 Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Mon, 16 Feb 2026 14:27:31 +0900 Subject: [PATCH 47/74] add tests for Empty Non-Terminal(ENT) cases --- dnsext-auth/test/AlgorithmSpec.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/dnsext-auth/test/AlgorithmSpec.hs b/dnsext-auth/test/AlgorithmSpec.hs index e9a28c1e4..c8741d83b 100644 --- a/dnsext-auth/test/AlgorithmSpec.hs +++ b/dnsext-auth/test/AlgorithmSpec.hs @@ -118,6 +118,22 @@ spec = describe "authoritative algorithm" $ do additional ans `shouldSatisfy` include "exist.example.jp." A additional ans `shouldSatisfy` include "exist.example.jp." AAAA flags ans `shouldSatisfy` authAnswer + it "can handle Empty Non-Terminal node" $ do + let query = defaultQuery{question = Question "ent1.example.jp." A IN} + ans = getAnswer db query + rcode ans `shouldBe` NoErr + length (answer ans) `shouldBe` 0 + length (authority ans) `shouldBe` 0 + length (additional ans) `shouldBe` 0 + flags ans `shouldSatisfy` authAnswer + it "can handle Empty Non-Terminal node nested" $ do + let query = defaultQuery{question = Question "ent2.ent1.example.jp." A IN} + ans = getAnswer db query + rcode ans `shouldBe` NoErr + length (answer ans) `shouldBe` 0 + length (authority ans) `shouldBe` 0 + length (additional ans) `shouldBe` 0 + flags ans `shouldSatisfy` authAnswer includeNS :: Domain -> [ResourceRecord] -> Bool includeNS dom rs = any has rs From 9a1f1eddd708ad620dd2bd33891260424aa6b49f Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 16 Feb 2026 19:41:16 +0900 Subject: [PATCH 48/74] removing illegal code --- dnsext-auth/DNS/Auth/Algorithm.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index 89a2ddd8d..ba1cca579 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -80,7 +80,6 @@ processPositive db@DB{..} q@Question{..} reply = case M.lookup qname dbAnswer of _ -> error "processPositive: multiple CNAMEs" where -- RFC2308 Sec 2.2 No Data - makeAnswer [] add = makeReply reply [] [dbSOA] add NoErr True makeAnswer ans add = makeReply reply ans [] add NoErr True -- RFC 1912 Sec 2.4 CNAME records From be0a2bf164c1d5250330779512b037045af0d4e2 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 16 Feb 2026 19:39:59 +0900 Subject: [PATCH 49/74] making DB ENT-friendly --- dnsext-auth/DNS/Auth/DB.hs | 27 ++++++++++++++++++++++++--- 1 file changed, 24 insertions(+), 3 deletions(-) diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs index 4326fd467..abbfc4d4c 100644 --- a/dnsext-auth/DNS/Auth/DB.hs +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module DNS.Auth.DB ( DB (..), loadDB, @@ -64,7 +66,7 @@ makeDB (zone, soa : rrs) (gs, zs) = partition (\r -> isDelegated (rrname r)) as -- gs: glue (in delegated domain) -- zs: in-domain - ans = makeMap $ [soa] ++ zs + ans = makeMap $ [soa] ++ concat (map (expand zone) zs) auth = makeMap ns xs = filter (\r -> rrtype r == A || rrtype r == AAAA) zs add = makeMap $ xs ++ gs @@ -95,8 +97,9 @@ makeIsDelegated rrs = \dom -> or (map (\f -> f dom) ps) makeMap :: [ResourceRecord] -> M.Map Domain [ResourceRecord] makeMap rrs = M.fromList kvs where - vs = groupBy ((==) `on` rrname) $ sort rrs - ks = map (rrname . unsafeHead) vs + ts = groupBy ((==) `on` rrname) $ sort rrs + vs = map (filter (\rr -> rrtype rr /= NULL)) ts + ks = map (rrname . unsafeHead) ts kvs = zip ks vs unsafeHead :: [a] -> a @@ -108,3 +111,21 @@ unsafeHead _ = error "unsafeHead" fromResource :: ZF.Record -> Maybe ResourceRecord fromResource (ZF.R_RR r) = Just r fromResource _ = Nothing + +expand :: Domain -> ResourceRecord -> [ResourceRecord] +expand dom rr = loop r0 + where + r0 = rrname rr + loop r + | r == dom = [rr] + | otherwise = case unconsDomain r of + Nothing -> [rr] + Just (_, r1) -> rrnull r : loop r1 + rrnull r = + ResourceRecord + { rrname = r + , rrtype = NULL + , rrclass = IN + , rrttl = 0 + , rdata = rd_null "" + } From bb47073ec8e90b97e6052ffc3eb9d3da4ce67943 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 16 Feb 2026 19:46:27 +0900 Subject: [PATCH 50/74] typo --- dnsext-auth/test/AlgorithmSpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dnsext-auth/test/AlgorithmSpec.hs b/dnsext-auth/test/AlgorithmSpec.hs index c8741d83b..17ef1d9bf 100644 --- a/dnsext-auth/test/AlgorithmSpec.hs +++ b/dnsext-auth/test/AlgorithmSpec.hs @@ -14,7 +14,7 @@ spec = describe "authoritative algorithm" $ do let db = case edb of Left _ -> error "DB" Right db' -> db' - it "can answer an exiting domain" $ do + it "can answer an existing domain" $ do let query = defaultQuery{question = Question "exist.example.jp." A IN} ans = getAnswer db query rcode ans `shouldBe` NoErr @@ -22,7 +22,7 @@ spec = describe "authoritative algorithm" $ do length (authority ans) `shouldBe` 0 length (additional ans) `shouldBe` 0 flags ans `shouldSatisfy` authAnswer - it "can answer an non-exiting domain" $ do + it "can answer an non-existing domain" $ do let query = defaultQuery{question = Question "nonexist.example.jp." A IN} ans = getAnswer db query rcode ans `shouldBe` NXDomain From eba50423a0e90e62644731534fea1fd60a9cd900 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 16 Feb 2026 20:06:47 +0900 Subject: [PATCH 51/74] comments --- dnsext-auth/DNS/Auth/DB.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs index abbfc4d4c..0989bde1d 100644 --- a/dnsext-auth/DNS/Auth/DB.hs +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -66,6 +66,7 @@ makeDB (zone, soa : rrs) (gs, zs) = partition (\r -> isDelegated (rrname r)) as -- gs: glue (in delegated domain) -- zs: in-domain + -- expand is for RFC 4592 Sec 2.2.2.Empty Non-terminals ans = makeMap $ [soa] ++ concat (map (expand zone) zs) auth = makeMap ns xs = filter (\r -> rrtype r == A || rrtype r == AAAA) zs @@ -112,6 +113,7 @@ fromResource :: ZF.Record -> Maybe ResourceRecord fromResource (ZF.R_RR r) = Just r fromResource _ = Nothing +-- For RFC 4592 Sec 2.2.2.Empty Non-terminals expand :: Domain -> ResourceRecord -> [ResourceRecord] expand dom rr = loop r0 where From 41d383e20c24376ec3221d67512b62c45890d296 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 17 Feb 2026 09:51:10 +0900 Subject: [PATCH 52/74] debug print --- dnsext-bowline/clove/Axfr.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/dnsext-bowline/clove/Axfr.hs b/dnsext-bowline/clove/Axfr.hs index 7348e3b01..09e4bd398 100644 --- a/dnsext-bowline/clove/Axfr.hs +++ b/dnsext-bowline/clove/Axfr.hs @@ -54,6 +54,7 @@ client ip name = do let riActions = defaultResolveActions { ractionTimeoutTime = 3000000 + , ractionLog = \_lvl _mclr ss -> mapM_ putStrLn ss } ris = [ defaultResolveInfo From 492052681b5dedaa6a0c7ce007daff0889cc85b4 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Feb 2026 09:41:05 +0900 Subject: [PATCH 53/74] introducing Control --- dnsext-auth/DNS/Auth/DB.hs | 30 ++++++++--- dnsext-bowline/clove/Axfr.hs | 14 ++--- dnsext-bowline/clove/Config.hs | 13 ++++- dnsext-bowline/clove/Control.hs | 71 ++++++++++++++++++++++++ dnsext-bowline/clove/Types.hs | 20 +++++++ dnsext-bowline/clove/clove.hs | 84 ++++++----------------------- dnsext-bowline/dnsext-bowline.cabal | 2 + 7 files changed, 150 insertions(+), 84 deletions(-) create mode 100644 dnsext-bowline/clove/Control.hs create mode 100644 dnsext-bowline/clove/Types.hs diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs index 0989bde1d..3f0c8cb80 100644 --- a/dnsext-auth/DNS/Auth/DB.hs +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -4,6 +4,7 @@ module DNS.Auth.DB ( DB (..), loadDB, makeDB, + emptyDB, ) where import Data.Function (on) @@ -27,6 +28,17 @@ data DB = DB } deriving (Show) +emptyDB :: DB +emptyDB = + DB + { dbZone = "" + , dbSOA = rrnull "" + , dbAnswer = M.empty + , dbAuthority = M.empty + , dbAdditional = M.empty + , dbAll = [] + } + ---------------------------------------------------------------- loadDB :: String -> FilePath -> IO (Either String DB) @@ -123,11 +135,13 @@ expand dom rr = loop r0 | otherwise = case unconsDomain r of Nothing -> [rr] Just (_, r1) -> rrnull r : loop r1 - rrnull r = - ResourceRecord - { rrname = r - , rrtype = NULL - , rrclass = IN - , rrttl = 0 - , rdata = rd_null "" - } + +rrnull :: Domain -> ResourceRecord +rrnull r = + ResourceRecord + { rrname = r + , rrtype = NULL + , rrclass = IN + , rrttl = 0 + , rdata = rd_null "" + } diff --git a/dnsext-bowline/clove/Axfr.hs b/dnsext-bowline/clove/Axfr.hs index 09e4bd398..7ce4f4646 100644 --- a/dnsext-bowline/clove/Axfr.hs +++ b/dnsext-bowline/clove/Axfr.hs @@ -7,7 +7,6 @@ module Axfr ( import Data.IORef import Data.IP -import Data.IP.RouteTable import qualified Data.IP.RouteTable as T import Data.List.NonEmpty () import Data.Maybe @@ -20,14 +19,17 @@ import DNS.Types import DNS.Types.Decode import DNS.Types.Encode +import Types + server - :: IORef DB - -> IPRTable IPv4 Bool - -> IPRTable IPv6 Bool + :: IORef Control -> Socket -> IO () -server dbref t4 t6 sock = do +server ctlref sock = do sa <- getPeerName sock + ctl <- readIORef ctlref + let t4 = ctlAllowTransfer4 ctl + t6 = ctlAllowTransfer6 ctl let ok = case fromSockAddr sa of Just (IPv4 ip4, _) -> fromMaybe False $ T.lookup (makeAddrRange ip4 32) t4 Just (IPv6 ip6, _) -> fromMaybe False $ T.lookup (makeAddrRange ip6 128) t6 @@ -37,7 +39,7 @@ server dbref t4 t6 sock = do Left _ -> return () Right query | ok -> do - db <- readIORef dbref + let db = ctlDB ctl let reply = makeReply db query sendVC (sendTCP sock) $ encode reply | otherwise -> do diff --git a/dnsext-bowline/clove/Config.hs b/dnsext-bowline/clove/Config.hs index ad476b893..777691ab4 100644 --- a/dnsext-bowline/clove/Config.hs +++ b/dnsext-bowline/clove/Config.hs @@ -13,6 +13,9 @@ import System.IO.Error (ioeGetErrorString, ioeSetErrorString, tryIOError) data Config = Config { cnf_zone :: String , cnf_source :: FilePath + , cnf_dnssec :: Bool + , cnf_notify :: Bool + , cnf_notify_addrs :: [String] , cnf_allow_transfer :: Bool , cnf_allow_transfer_addrs :: [String] , cnf_tcp_addrs :: [String] @@ -25,9 +28,12 @@ defaultConfig :: Config defaultConfig = Config { cnf_zone = "example.org" - , cnf_source = "example.conf" + , cnf_source = "example.zone" + , cnf_dnssec = False + , cnf_notify = False + , cnf_notify_addrs = [] , cnf_allow_transfer = False - , cnf_allow_transfer_addrs = ["127.0.0.1", "::1"] + , cnf_allow_transfer_addrs = [] , cnf_tcp_addrs = ["127.0.0.1", "::1"] , cnf_tcp_port = 53 , cnf_udp_addrs = ["127.0.0.1", "::1"] @@ -38,6 +44,9 @@ makeConfig :: Config -> [Conf] -> IO Config makeConfig def conf = do cnf_zone <- get "zone" cnf_zone cnf_source <- get "source" cnf_source + cnf_dnssec <- get "dnssec" cnf_dnssec + cnf_notify <- get "notify" cnf_notify + cnf_notify_addrs <- get "notify-addrs" cnf_notify_addrs cnf_allow_transfer <- get "allow-transfer" cnf_allow_transfer cnf_allow_transfer_addrs <- get "allow-transfer-addrs" cnf_allow_transfer_addrs cnf_tcp_addrs <- get "tcp-addrs" cnf_tcp_addrs diff --git a/dnsext-bowline/clove/Control.hs b/dnsext-bowline/clove/Control.hs new file mode 100644 index 000000000..d20dce6bf --- /dev/null +++ b/dnsext-bowline/clove/Control.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Control where + +import Data.IORef +import Data.IP +import Data.IP.RouteTable +import Data.Maybe +import Text.Read + +import DNS.Auth.Algorithm +import DNS.Auth.DB +import DNS.Types + +import qualified Axfr as Axfr +import Config +import Types + +readIP :: [String] -> [IP] +readIP ss = catMaybes $ map readMaybe ss + +readIPRange :: [String] -> ([AddrRange IPv4], [AddrRange IPv6]) +readIPRange ss0 = loop id id ss0 + where + loop b4 b6 [] = (b4 [], b6 []) + loop b4 b6 (s : ss) + | Just a6 <- readMaybe s = loop b4 (b6 . (a6 :)) ss + | Just a4 <- readMaybe s = loop (b4 . (a4 :)) b6 ss + | otherwise = loop b4 b6 ss + +readSource :: String -> Source +readSource s + | Just a6 <- readMaybe s = FromUpstream6 a6 + | Just a4 <- readMaybe s = FromUpstream4 a4 + | otherwise = FromFile s + +loadSource :: String -> String -> IO (Either String DB) +loadSource zone src = case readSource src of + FromUpstream4 ip4 -> do + emsg <- Axfr.client (IPv4 ip4) dom + case emsg of + Left _e -> return $ Left $ show _e + Right reply -> return $ makeDB (dom, answer reply) + FromUpstream6 ip6 -> do + emsg <- Axfr.client (IPv6 ip6) dom + case emsg of + Left _e -> return $ Left $ show _e + Right reply -> return $ makeDB (dom, answer reply) + FromFile fn -> loadDB zone fn + where + dom = fromRepresentation zone + +newControl :: Config -> IO (IORef Control) +newControl Config{..} = do + edb <- loadSource cnf_zone cnf_source + let (db, ready) = case edb of + Left _ -> (emptyDB, False) + Right db' -> (db', True) + let (a4, a6) = readIPRange cnf_allow_transfer_addrs + t4 = fromList $ map (,True) a4 + t6 = fromList $ map (,True) a6 + notify_addrs = readIP cnf_notify_addrs + newIORef $ + Control + { ctlDB = db + , ctlReady = ready + , ctlNotifyAddrs = notify_addrs + , ctlAllowTransfer4 = t4 + , ctlAllowTransfer6 = t6 + } diff --git a/dnsext-bowline/clove/Types.hs b/dnsext-bowline/clove/Types.hs new file mode 100644 index 000000000..7f61157d5 --- /dev/null +++ b/dnsext-bowline/clove/Types.hs @@ -0,0 +1,20 @@ +module Types where + +import Data.IP +import Data.IP.RouteTable + +import DNS.Auth.Algorithm + +data Source + = FromFile FilePath + | FromUpstream4 IPv4 + | FromUpstream6 IPv6 + deriving (Eq, Show) + +data Control = Control + { ctlDB :: DB + , ctlReady :: Bool + , ctlNotifyAddrs :: [IP] + , ctlAllowTransfer4 :: IPRTable IPv4 Bool + , ctlAllowTransfer6 :: IPRTable IPv6 Bool + } diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index e19d0bc61..f8f476354 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -1,25 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} module Main where import Control.Concurrent.Async import qualified Control.Exception as E import Control.Monad -import Data.IP -import Data.IP.RouteTable import qualified Data.List.NonEmpty as NE import Network.Run.TCP.Timeout import Network.Socket import qualified Network.Socket.ByteString as NSB import System.Environment (getArgs) -import System.Exit -import Text.Read import DNS.Auth.Algorithm -import DNS.Auth.DB import DNS.Types import DNS.Types.Decode import DNS.Types.Encode @@ -27,50 +21,35 @@ import Data.IORef import qualified Axfr as Axfr import Config - ----------------------------------------------------------------- - -data Source - = FromFile FilePath - | FromUpstream4 IPv4 - | FromUpstream6 IPv6 - deriving (Eq, Show) +import Control +import Types ---------------------------------------------------------------- main :: IO () main = do [conffile] <- getArgs - Config{..} <- loadConfig conffile - edb <- loadSource cnf_zone cnf_source - case edb of - Left emsg -> die emsg - Right db -> do - dbref <- newIORef db - let (a4, a6) = readIPRange cnf_allow_transfer_addrs - t4 = fromList $ map (,True) a4 - t6 = fromList $ map (,True) a6 - let as = map (axfrServer dbref t4 t6 (show cnf_tcp_port)) cnf_tcp_addrs - ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs - ss <- mapM serverSocket ais - let cs = map (authServer dbref) ss - foldr1 concurrently_ $ as ++ cs + cnf@Config{..} <- loadConfig conffile + ctlref <- newControl cnf + let as = map (axfrServer ctlref (show cnf_tcp_port)) cnf_tcp_addrs + ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs + ss <- mapM serverSocket ais + let cs = map (authServer ctlref) ss + foldr1 concurrently_ $ as ++ cs ---------------------------------------------------------------- axfrServer - :: IORef DB - -> IPRTable IPv4 Bool - -> IPRTable IPv6 Bool + :: IORef Control -> ServiceName -> HostName -> IO () -axfrServer dbref t4 t6 port addr = +axfrServer ctlref port addr = runTCPServer 10 (Just addr) port $ - \_ _ s -> Axfr.server dbref t4 t6 s + \_ _ s -> Axfr.server ctlref s -authServer :: IORef DB -> Socket -> IO () -authServer dbref s = loop +authServer :: IORef Control -> Socket -> IO () +authServer ctlref s = loop where loop = do (bs, sa) <- NSB.recvFrom s 2048 @@ -78,8 +57,8 @@ authServer dbref s = loop -- fixme: which RFC? Left _e -> return () Right query -> do - db <- readIORef dbref - replyQuery db s sa query + ctl <- readIORef ctlref + replyQuery (ctlDB ctl) s sa query loop replyQuery :: DB -> Socket -> SockAddr -> DNSMessage -> IO () @@ -104,34 +83,3 @@ serverSocket ai = E.bracketOnError (openSocket ai) close $ \s -> do setSocketOption s ReuseAddr 1 bind s $ addrAddress ai return s - -readIPRange :: [String] -> ([AddrRange IPv4], [AddrRange IPv6]) -readIPRange ss0 = loop id id ss0 - where - loop b4 b6 [] = (b4 [], b6 []) - loop b4 b6 (s : ss) - | Just a6 <- readMaybe s = loop b4 (b6 . (a6 :)) ss - | Just a4 <- readMaybe s = loop (b4 . (a4 :)) b6 ss - | otherwise = loop b4 b6 ss - -readSource :: String -> Source -readSource s - | Just a6 <- readMaybe s = FromUpstream6 a6 - | Just a4 <- readMaybe s = FromUpstream4 a4 - | otherwise = FromFile s - -loadSource :: String -> String -> IO (Either String DB) -loadSource zone src = case readSource src of - FromUpstream4 ip4 -> do - emsg <- Axfr.client (IPv4 ip4) dom - case emsg of - Left _e -> return $ Left $ show _e - Right reply -> return $ makeDB (dom, answer reply) - FromUpstream6 ip6 -> do - emsg <- Axfr.client (IPv6 ip6) dom - case emsg of - Left _e -> return $ Left $ show _e - Right reply -> return $ makeDB (dom, answer reply) - FromFile fn -> loadDB zone fn - where - dom = fromRepresentation zone diff --git a/dnsext-bowline/dnsext-bowline.cabal b/dnsext-bowline/dnsext-bowline.cabal index 8d5e8ec30..5b61b7154 100644 --- a/dnsext-bowline/dnsext-bowline.cabal +++ b/dnsext-bowline/dnsext-bowline.cabal @@ -150,6 +150,8 @@ executable clove hs-source-dirs: clove other-modules: Axfr Config + Control + Types default-language: Haskell2010 ghc-options: -Wall -threaded From a7318a712891b4e0fa08c6a6e5e9eec115fda71b Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Feb 2026 09:57:27 +0900 Subject: [PATCH 54/74] extracting Net module --- dnsext-bowline/clove/Net.hs | 21 +++++++++++++++++++++ dnsext-bowline/clove/clove.hs | 23 +++-------------------- dnsext-bowline/dnsext-bowline.cabal | 1 + 3 files changed, 25 insertions(+), 20 deletions(-) create mode 100644 dnsext-bowline/clove/Net.hs diff --git a/dnsext-bowline/clove/Net.hs b/dnsext-bowline/clove/Net.hs new file mode 100644 index 000000000..adc5a7290 --- /dev/null +++ b/dnsext-bowline/clove/Net.hs @@ -0,0 +1,21 @@ +module Net where + +import qualified Control.Exception as E +import qualified Data.List.NonEmpty as NE +import Network.Socket + +serverResolve :: PortNumber -> HostName -> IO AddrInfo +serverResolve pn addr = NE.head <$> getAddrInfo (Just hints) (Just addr) (Just port) + where + port = show pn + hints = + defaultHints + { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE] + , addrSocketType = Datagram + } + +serverSocket :: AddrInfo -> IO Socket +serverSocket ai = E.bracketOnError (openSocket ai) close $ \s -> do + setSocketOption s ReuseAddr 1 + bind s $ addrAddress ai + return s diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index f8f476354..0acdd6bdb 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -5,9 +5,7 @@ module Main where import Control.Concurrent.Async -import qualified Control.Exception as E import Control.Monad -import qualified Data.List.NonEmpty as NE import Network.Run.TCP.Timeout import Network.Socket import qualified Network.Socket.ByteString as NSB @@ -22,6 +20,7 @@ import Data.IORef import qualified Axfr as Axfr import Config import Control +import Net import Types ---------------------------------------------------------------- @@ -48,6 +47,8 @@ axfrServer ctlref port addr = runTCPServer 10 (Just addr) port $ \_ _ s -> Axfr.server ctlref s +---------------------------------------------------------------- + authServer :: IORef Control -> Socket -> IO () authServer ctlref s = loop where @@ -65,21 +66,3 @@ replyQuery :: DB -> Socket -> SockAddr -> DNSMessage -> IO () replyQuery db s sa query = void $ NSB.sendTo s bs sa where bs = encode $ getAnswer db query - ----------------------------------------------------------------- - -serverResolve :: PortNumber -> HostName -> IO AddrInfo -serverResolve pn addr = NE.head <$> getAddrInfo (Just hints) (Just addr) (Just port) - where - port = show pn - hints = - defaultHints - { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE] - , addrSocketType = Datagram - } - -serverSocket :: AddrInfo -> IO Socket -serverSocket ai = E.bracketOnError (openSocket ai) close $ \s -> do - setSocketOption s ReuseAddr 1 - bind s $ addrAddress ai - return s diff --git a/dnsext-bowline/dnsext-bowline.cabal b/dnsext-bowline/dnsext-bowline.cabal index 5b61b7154..e720ae586 100644 --- a/dnsext-bowline/dnsext-bowline.cabal +++ b/dnsext-bowline/dnsext-bowline.cabal @@ -151,6 +151,7 @@ executable clove other-modules: Axfr Config Control + Net Types default-language: Haskell2010 From cc792530ba7b8c1e33c743ec8d62b0d3df612ec7 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Feb 2026 10:00:00 +0900 Subject: [PATCH 55/74] hlint suggestions --- dnsext-bowline/clove/Control.hs | 4 ++-- dnsext-bowline/clove/clove.hs | 3 +-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/dnsext-bowline/clove/Control.hs b/dnsext-bowline/clove/Control.hs index d20dce6bf..3adf4fa07 100644 --- a/dnsext-bowline/clove/Control.hs +++ b/dnsext-bowline/clove/Control.hs @@ -13,12 +13,12 @@ import DNS.Auth.Algorithm import DNS.Auth.DB import DNS.Types -import qualified Axfr as Axfr +import qualified Axfr import Config import Types readIP :: [String] -> [IP] -readIP ss = catMaybes $ map readMaybe ss +readIP ss = mapMaybe readMaybe ss readIPRange :: [String] -> ([AddrRange IPv4], [AddrRange IPv6]) readIPRange ss0 = loop id id ss0 diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 0acdd6bdb..cc9bfb3af 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,7 +16,7 @@ import DNS.Types.Decode import DNS.Types.Encode import Data.IORef -import qualified Axfr as Axfr +import qualified Axfr import Config import Control import Net From d25d63ba1dfccfaf17de1899b3be3814ed1999e1 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Feb 2026 10:51:12 +0900 Subject: [PATCH 56/74] "kill -HUP" syncs zone --- dnsext-bowline/clove/Control.hs | 31 +++++++++++++++++++++------ dnsext-bowline/clove/clove.hs | 33 ++++++++++++++++++++++++++++- dnsext-bowline/dnsext-bowline.cabal | 4 +++- 3 files changed, 59 insertions(+), 9 deletions(-) diff --git a/dnsext-bowline/clove/Control.hs b/dnsext-bowline/clove/Control.hs index 3adf4fa07..5a8941b68 100644 --- a/dnsext-bowline/clove/Control.hs +++ b/dnsext-bowline/clove/Control.hs @@ -35,8 +35,15 @@ readSource s | Just a4 <- readMaybe s = FromUpstream4 a4 | otherwise = FromFile s -loadSource :: String -> String -> IO (Either String DB) -loadSource zone src = case readSource src of +loadSource :: Config -> IO (DB, Bool) +loadSource Config{..} = do + edb <- loadSource' cnf_zone cnf_source + case edb of + Left _ -> return (emptyDB, False) + Right db' -> return (db', True) + +loadSource' :: String -> String -> IO (Either String DB) +loadSource' zone src = case readSource src of FromUpstream4 ip4 -> do emsg <- Axfr.client (IPv4 ip4) dom case emsg of @@ -52,11 +59,8 @@ loadSource zone src = case readSource src of dom = fromRepresentation zone newControl :: Config -> IO (IORef Control) -newControl Config{..} = do - edb <- loadSource cnf_zone cnf_source - let (db, ready) = case edb of - Left _ -> (emptyDB, False) - Right db' -> (db', True) +newControl cnf@Config{..} = do + (db, ready) <- loadSource cnf let (a4, a6) = readIPRange cnf_allow_transfer_addrs t4 = fromList $ map (,True) a4 t6 = fromList $ map (,True) a6 @@ -69,3 +73,16 @@ newControl Config{..} = do , ctlAllowTransfer4 = t4 , ctlAllowTransfer6 = t6 } + +updateControl :: Config -> IORef Control -> IO () +updateControl cnf ctlref = do + (db, ready) <- loadSource cnf + atomicModifyIORef' ctlref $ modify db ready + where + modify db ready ctl = (ctl', ()) + where + ctl' = + ctl + { ctlReady = ready + , ctlDB = db + } diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index cc9bfb3af..b1db00cc8 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -3,12 +3,15 @@ module Main where -import Control.Concurrent.Async +import Control.Concurrent (forkIO) +import Control.Concurrent.Async hiding (wait) +import Control.Concurrent.STM import Control.Monad import Network.Run.TCP.Timeout import Network.Socket import qualified Network.Socket.ByteString as NSB import System.Environment (getArgs) +import System.Posix (Handler (Catch), installHandler, sigHUP) import DNS.Auth.Algorithm import DNS.Types @@ -29,6 +32,14 @@ main = do [conffile] <- getArgs cnf@Config{..} <- loadConfig conffile ctlref <- newControl cnf + var <- newTVarIO False + let wakeup = atomically $ writeTVar var True + reset = atomically $ writeTVar var False + wait = atomically $ do + v <- readTVar var + check v + void $ installHandler sigHUP (Catch wakeup) Nothing + _ <- forkIO $ syncZone cnf ctlref (wait >> reset) let as = map (axfrServer ctlref (show cnf_tcp_port)) cnf_tcp_addrs ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs ss <- mapM serverSocket ais @@ -65,3 +76,23 @@ replyQuery :: DB -> Socket -> SockAddr -> DNSMessage -> IO () replyQuery db s sa query = void $ NSB.sendTo s bs sa where bs = encode $ getAnswer db query + +---------------------------------------------------------------- + +syncZone :: Config -> IORef Control -> IO () -> IO () +syncZone cnf ctlref wait = loop + where + loop = do + wait + -- reading zone source + updateControl cnf ctlref + -- notify + {- + Control{..} <- readIORef ctlref + let addrs = ctlNotifyAddrs + notify addrs + -} + -- refresh timer + loop + +---------------------------------------------------------------- diff --git a/dnsext-bowline/dnsext-bowline.cabal b/dnsext-bowline/dnsext-bowline.cabal index e720ae586..dd7072948 100644 --- a/dnsext-bowline/dnsext-bowline.cabal +++ b/dnsext-bowline/dnsext-bowline.cabal @@ -167,7 +167,9 @@ executable clove dnsext-types, dnsext-utils, iproute, - network-run + network-run, + stm, + unix if (os(windows) && impl(ghc >=9.0)) ghc-options: -with-rtsopts=--io-manager=native From c3a88cc87054d61a0ffd026b88ba01ef8b2c38e1 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Feb 2026 12:22:34 +0900 Subject: [PATCH 57/74] initial implementation of zone refresh --- dnsext-bowline/clove/clove.hs | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index b1db00cc8..f878c575c 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -4,9 +4,11 @@ module Main where import Control.Concurrent (forkIO) -import Control.Concurrent.Async hiding (wait) +import Control.Concurrent.Async (concurrently_) import Control.Concurrent.STM +import qualified Control.Exception as E import Control.Monad +import GHC.Event import Network.Run.TCP.Timeout import Network.Socket import qualified Network.Socket.ByteString as NSB @@ -32,14 +34,9 @@ main = do [conffile] <- getArgs cnf@Config{..} <- loadConfig conffile ctlref <- newControl cnf - var <- newTVarIO False - let wakeup = atomically $ writeTVar var True - reset = atomically $ writeTVar var False - wait = atomically $ do - v <- readTVar var - check v + (wakeup, wait) <- initSync 5 void $ installHandler sigHUP (Catch wakeup) Nothing - _ <- forkIO $ syncZone cnf ctlref (wait >> reset) + _ <- forkIO $ syncZone cnf ctlref wait let as = map (axfrServer ctlref (show cnf_tcp_port)) cnf_tcp_addrs ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs ss <- mapM serverSocket ais @@ -92,7 +89,19 @@ syncZone cnf ctlref wait = loop let addrs = ctlNotifyAddrs notify addrs -} - -- refresh timer loop ---------------------------------------------------------------- + +initSync :: Int -> IO (IO (), IO ()) +initSync refresh = do + tmgr <- getSystemTimerManager + var <- newTVarIO False + let wakeup = atomically $ writeTVar var True + register = registerTimeout tmgr (refresh * 1000000) wakeup + cancel = unregisterTimeout tmgr + wait = E.bracket register cancel $ \_ -> atomically $ do + v <- readTVar var + check v + writeTVar var False + return (wakeup, wait) From 9c32652df884cd2e6bb84909d73c61fdc7a364bd Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Feb 2026 13:16:18 +0900 Subject: [PATCH 58/74] implementing checkSOA --- dnsext-bowline/clove/Control.hs | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/dnsext-bowline/clove/Control.hs b/dnsext-bowline/clove/Control.hs index 5a8941b68..799ac5c3d 100644 --- a/dnsext-bowline/clove/Control.hs +++ b/dnsext-bowline/clove/Control.hs @@ -6,6 +6,7 @@ module Control where import Data.IORef import Data.IP import Data.IP.RouteTable +import Data.List import Data.Maybe import Text.Read @@ -48,16 +49,31 @@ loadSource' zone src = case readSource src of emsg <- Axfr.client (IPv4 ip4) dom case emsg of Left _e -> return $ Left $ show _e - Right reply -> return $ makeDB (dom, answer reply) + Right reply -> case checkSOA $ answer reply of + Nothing -> return $ Left "loadSource'" + Just rrs -> return $ makeDB (dom, rrs) FromUpstream6 ip6 -> do emsg <- Axfr.client (IPv6 ip6) dom case emsg of Left _e -> return $ Left $ show _e - Right reply -> return $ makeDB (dom, answer reply) + Right reply -> case checkSOA $ answer reply of + Nothing -> return $ Left "loadSource'" + Just rrs -> return $ makeDB (dom, rrs) FromFile fn -> loadDB zone fn where dom = fromRepresentation zone +checkSOA :: [ResourceRecord] -> Maybe [ResourceRecord] +checkSOA [] = Nothing +checkSOA (soa : rrs) + | rrtype soa == SOA = + case unsnoc rrs of + Nothing -> Nothing + Just (rrs', soa') + | rrtype soa' == SOA -> Just (soa : rrs') + | otherwise -> Nothing + | otherwise = Nothing + newControl :: Config -> IO (IORef Control) newControl cnf@Config{..} = do (db, ready) <- loadSource cnf From e06e201cef13d94cc6b52e62ea055de76c84e413 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Feb 2026 14:46:42 +0900 Subject: [PATCH 59/74] lookup SOA before AXFR --- dnsext-auth/DNS/Auth/DB.hs | 34 +++++---- dnsext-auth/test/AlgorithmSpec.hs | 4 +- dnsext-bowline/clove/Axfr.hs | 113 +++++++++++++++++++++++------- dnsext-bowline/clove/Control.hs | 58 +++++---------- dnsext-bowline/clove/Types.hs | 3 + 5 files changed, 131 insertions(+), 81 deletions(-) diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs index 3f0c8cb80..b46d874f5 100644 --- a/dnsext-auth/DNS/Auth/DB.hs +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -12,6 +12,7 @@ import Data.List (groupBy, partition, sort) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes) import qualified Data.Set as Set +import Data.Word import DNS.Types import qualified DNS.ZoneFile as ZF @@ -20,6 +21,7 @@ import qualified DNS.ZoneFile as ZF data DB = DB { dbZone :: Domain + , dbSerial :: Word32 , dbSOA :: ResourceRecord , dbAnswer :: M.Map Domain [ResourceRecord] , dbAuthority :: M.Map Domain [ResourceRecord] @@ -32,6 +34,7 @@ emptyDB :: DB emptyDB = DB { dbZone = "" + , dbSerial = 0 , dbSOA = rrnull "" , dbAnswer = M.empty , dbAuthority = M.empty @@ -41,7 +44,7 @@ emptyDB = ---------------------------------------------------------------- -loadDB :: String -> FilePath -> IO (Either String DB) +loadDB :: String -> FilePath -> IO (Maybe DB) loadDB zone file = makeDB <$> loadZoneFile zone file loadZoneFile :: String -> FilePath -> IO (Domain, [ResourceRecord]) @@ -53,22 +56,25 @@ loadZoneFile zone file = do ---------------------------------------------------------------- -makeDB :: (Domain, [ResourceRecord]) -> Either String DB -makeDB (_, []) = Left "makeDB: no resource records" +makeDB :: (Domain, [ResourceRecord]) -> Maybe DB +makeDB (_, []) = Nothing -- RFC 1035 Sec 5.2 -- Exactly one SOA RR should be present at the top of the zone. makeDB (zone, soa : rrs) - | rrtype soa /= SOA = Left "makeDB: no SOA" - | otherwise = - Right $ - DB - { dbZone = zone - , dbSOA = soa - , dbAnswer = ans - , dbAuthority = auth - , dbAdditional = add - , dbAll = [soa] ++ rrs ++ [soa] - } + | rrtype soa /= SOA = Nothing + | otherwise = case fromRData $ rdata soa of + Nothing -> Nothing + Just s -> + Just $ + DB + { dbZone = zone + , dbSerial = soa_serial s + , dbSOA = soa + , dbAnswer = ans + , dbAuthority = auth + , dbAdditional = add + , dbAll = [soa] ++ rrs ++ [soa] -- for AXFR + } where -- RFC 9471 -- In-domain and sibling glues only. diff --git a/dnsext-auth/test/AlgorithmSpec.hs b/dnsext-auth/test/AlgorithmSpec.hs index 17ef1d9bf..ce16387e6 100644 --- a/dnsext-auth/test/AlgorithmSpec.hs +++ b/dnsext-auth/test/AlgorithmSpec.hs @@ -12,8 +12,8 @@ spec :: Spec spec = describe "authoritative algorithm" $ do edb <- runIO $ loadDB "example.jp." "test/example.zone" let db = case edb of - Left _ -> error "DB" - Right db' -> db' + Nothing -> error "DB" + Just db' -> db' it "can answer an existing domain" $ do let query = defaultQuery{question = Question "exist.example.jp." A IN} ans = getAnswer db query diff --git a/dnsext-bowline/clove/Axfr.hs b/dnsext-bowline/clove/Axfr.hs index 7ce4f4646..305a61f4d 100644 --- a/dnsext-bowline/clove/Axfr.hs +++ b/dnsext-bowline/clove/Axfr.hs @@ -8,6 +8,7 @@ module Axfr ( import Data.IORef import Data.IP import qualified Data.IP.RouteTable as T +import Data.List import Data.List.NonEmpty () import Data.Maybe import Network.Socket @@ -21,6 +22,8 @@ import DNS.Types.Encode import Types +---------------------------------------------------------------- + server :: IORef Control -> Socket @@ -51,28 +54,88 @@ makeReply db query | qtype (question query) == AXFR = (fromQuery query){answer = dbAll db} | otherwise = getAnswer db query -client :: IP -> Domain -> IO (Either DNSError DNSMessage) -client ip name = do - let riActions = - defaultResolveActions - { ractionTimeoutTime = 3000000 - , ractionLog = \_lvl _mclr ss -> mapM_ putStrLn ss - } - ris = - [ defaultResolveInfo - { rinfoIP = ip - , rinfoPort = 53 - , rinfoActions = riActions - , rinfoUDPRetry = 1 - , rinfoVCLimit = 32 * 1024 - } - ] - renv = - ResolveEnv - { renvResolver = tcpResolver - , renvConcurrent = True -- should set True if multiple RIs are provided - , renvResolveInfos = ris - } - q = Question name AXFR IN - qctl = rdFlag FlagClear <> doFlag FlagClear - fmap replyDNSMessage <$> resolve renv q qctl +---------------------------------------------------------------- + +client :: Serial -> IP -> Domain -> IO [ResourceRecord] +client serial0 ip dom = do + mserial <- serialQuery ip dom + case mserial of + Nothing -> return [] + Just serial + | serial /= serial0 -> axfrQuery ip dom + | otherwise -> return [] + +serialQuery :: IP -> Domain -> IO (Maybe Serial) +serialQuery ip dom = do + emsg <- fmap replyDNSMessage <$> resolve renv q qctl + case emsg of + Left _ -> return Nothing + Right msg -> case answer msg of + [] -> return Nothing + soa : _ -> case fromRData $ rdata soa of + Nothing -> return Nothing + Just s -> return $ Just $ soa_serial s + where + riActions = + defaultResolveActions + { ractionTimeoutTime = 3000000 + , ractionLog = \_lvl _mclr ss -> mapM_ putStrLn ss + } + ris = + [ defaultResolveInfo + { rinfoIP = ip + , rinfoPort = 53 + , rinfoActions = riActions + , rinfoUDPRetry = 3 + , rinfoVCLimit = 0 + } + ] + renv = + ResolveEnv + { renvResolver = udpResolver + , renvConcurrent = True -- should set True if multiple RIs are provided + , renvResolveInfos = ris + } + q = Question dom SOA IN + qctl = rdFlag FlagClear <> doFlag FlagClear + +axfrQuery :: IP -> Domain -> IO [ResourceRecord] +axfrQuery ip dom = do + emsg <- fmap replyDNSMessage <$> resolve renv q qctl + case emsg of + Left _ -> return [] + Right msg -> return $ checkSOA $ answer msg + where + riActions = + defaultResolveActions + { ractionTimeoutTime = 30000000 + , ractionLog = \_lvl _mclr ss -> mapM_ putStrLn ss + } + ris = + [ defaultResolveInfo + { rinfoIP = ip + , rinfoPort = 53 + , rinfoActions = riActions + , rinfoUDPRetry = 1 + , rinfoVCLimit = 32 * 1024 + } + ] + renv = + ResolveEnv + { renvResolver = tcpResolver + , renvConcurrent = True -- should set True if multiple RIs are provided + , renvResolveInfos = ris + } + q = Question dom AXFR IN + qctl = rdFlag FlagClear <> doFlag FlagClear + +checkSOA :: [ResourceRecord] -> [ResourceRecord] +checkSOA [] = [] +checkSOA (soa : rrs) + | rrtype soa == SOA = + case unsnoc rrs of + Nothing -> [] + Just (rrs', soa') + | rrtype soa' == SOA -> soa : rrs' + | otherwise -> [] + | otherwise = [] diff --git a/dnsext-bowline/clove/Control.hs b/dnsext-bowline/clove/Control.hs index 799ac5c3d..193cfd900 100644 --- a/dnsext-bowline/clove/Control.hs +++ b/dnsext-bowline/clove/Control.hs @@ -6,7 +6,6 @@ module Control where import Data.IORef import Data.IP import Data.IP.RouteTable -import Data.List import Data.Maybe import Text.Read @@ -36,47 +35,23 @@ readSource s | Just a4 <- readMaybe s = FromUpstream4 a4 | otherwise = FromFile s -loadSource :: Config -> IO (DB, Bool) -loadSource Config{..} = do - edb <- loadSource' cnf_zone cnf_source - case edb of - Left _ -> return (emptyDB, False) - Right db' -> return (db', True) - -loadSource' :: String -> String -> IO (Either String DB) -loadSource' zone src = case readSource src of - FromUpstream4 ip4 -> do - emsg <- Axfr.client (IPv4 ip4) dom - case emsg of - Left _e -> return $ Left $ show _e - Right reply -> case checkSOA $ answer reply of - Nothing -> return $ Left "loadSource'" - Just rrs -> return $ makeDB (dom, rrs) - FromUpstream6 ip6 -> do - emsg <- Axfr.client (IPv6 ip6) dom - case emsg of - Left _e -> return $ Left $ show _e - Right reply -> case checkSOA $ answer reply of - Nothing -> return $ Left "loadSource'" - Just rrs -> return $ makeDB (dom, rrs) +loadSource :: Serial -> Config -> IO (Maybe DB) +loadSource serial cnf = case readSource $ cnf_source cnf of + FromUpstream4 ip4 -> toDB <$> Axfr.client serial (IPv4 ip4) dom + FromUpstream6 ip6 -> toDB <$> Axfr.client serial (IPv6 ip6) dom FromFile fn -> loadDB zone fn where + zone = cnf_zone cnf dom = fromRepresentation zone - -checkSOA :: [ResourceRecord] -> Maybe [ResourceRecord] -checkSOA [] = Nothing -checkSOA (soa : rrs) - | rrtype soa == SOA = - case unsnoc rrs of - Nothing -> Nothing - Just (rrs', soa') - | rrtype soa' == SOA -> Just (soa : rrs') - | otherwise -> Nothing - | otherwise = Nothing + toDB [] = Nothing + toDB rrs = makeDB (dom, rrs) newControl :: Config -> IO (IORef Control) newControl cnf@Config{..} = do - (db, ready) <- loadSource cnf + mdb <- loadSource 0 cnf + let (db, ready) = case mdb of + Nothing -> (emptyDB, False) + Just db' -> (db', True) let (a4, a6) = readIPRange cnf_allow_transfer_addrs t4 = fromList $ map (,True) a4 t6 = fromList $ map (,True) a6 @@ -92,13 +67,16 @@ newControl cnf@Config{..} = do updateControl :: Config -> IORef Control -> IO () updateControl cnf ctlref = do - (db, ready) <- loadSource cnf - atomicModifyIORef' ctlref $ modify db ready + Control{..} <- readIORef ctlref + mdb <- loadSource (dbSerial ctlDB) cnf + case mdb of + Nothing -> return () + Just db -> atomicModifyIORef' ctlref $ modify db where - modify db ready ctl = (ctl', ()) + modify db ctl = (ctl', ()) where ctl' = ctl - { ctlReady = ready + { ctlReady = True , ctlDB = db } diff --git a/dnsext-bowline/clove/Types.hs b/dnsext-bowline/clove/Types.hs index 7f61157d5..91cffbb94 100644 --- a/dnsext-bowline/clove/Types.hs +++ b/dnsext-bowline/clove/Types.hs @@ -2,6 +2,7 @@ module Types where import Data.IP import Data.IP.RouteTable +import Data.Word import DNS.Auth.Algorithm @@ -18,3 +19,5 @@ data Control = Control , ctlAllowTransfer4 :: IPRTable IPv4 Bool , ctlAllowTransfer6 :: IPRTable IPv6 Bool } + +type Serial = Word32 From d849319bdaec668a0933fc3c37457803a59b4c63 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Feb 2026 16:57:24 +0900 Subject: [PATCH 60/74] refactoring --- dnsext-auth/DNS/Auth/Algorithm.hs | 6 ++-- dnsext-auth/DNS/Auth/DB.hs | 54 +++++++++++++++++-------------- dnsext-bowline/clove/Config.hs | 2 +- dnsext-bowline/clove/Control.hs | 26 ++++++++------- dnsext-bowline/clove/clove.hs | 26 ++++++++++----- 5 files changed, 67 insertions(+), 47 deletions(-) diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs index ba1cca579..62ed6c889 100644 --- a/dnsext-auth/DNS/Auth/Algorithm.hs +++ b/dnsext-auth/DNS/Auth/Algorithm.hs @@ -109,13 +109,13 @@ findAuthority findAuthority db@DB{..} Question{..} reply = loop qname where loop dom - | dom == dbZone = makeReply reply [] [dbSOA] [] NXDomain True + | dom == dbZone = makeReply reply [] [dbSOArr] [] NXDomain True | otherwise = case unconsDomain dom of - Nothing -> makeReply reply [] [dbSOA] [] NXDomain True + Nothing -> makeReply reply [] [dbSOArr] [] NXDomain True Just (_, dom') -> case M.lookup dom dbAuthority of Nothing -> loop dom' Just auth - | null auth -> makeReply reply [] [dbSOA] [] NoErr True + | null auth -> makeReply reply [] [dbSOArr] [] NoErr True | otherwise -> let add = findAdditional db auth in makeReply reply [] auth add NoErr False diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs index b46d874f5..1d73b6b89 100644 --- a/dnsext-auth/DNS/Auth/DB.hs +++ b/dnsext-auth/DNS/Auth/DB.hs @@ -10,9 +10,8 @@ module DNS.Auth.DB ( import Data.Function (on) import Data.List (groupBy, partition, sort) import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromJust) import qualified Data.Set as Set -import Data.Word import DNS.Types import qualified DNS.ZoneFile as ZF @@ -21,8 +20,8 @@ import qualified DNS.ZoneFile as ZF data DB = DB { dbZone :: Domain - , dbSerial :: Word32 - , dbSOA :: ResourceRecord + , dbSOA :: RD_SOA + , dbSOArr :: ResourceRecord , dbAnswer :: M.Map Domain [ResourceRecord] , dbAuthority :: M.Map Domain [ResourceRecord] , dbAdditional :: M.Map Domain [ResourceRecord] @@ -33,47 +32,54 @@ data DB = DB emptyDB :: DB emptyDB = DB - { dbZone = "" - , dbSerial = 0 - , dbSOA = rrnull "" + { dbZone = "." + , dbSOA = soa + , dbSOArr = soarr , dbAnswer = M.empty , dbAuthority = M.empty , dbAdditional = M.empty , dbAll = [] } + where + soard = rd_soa "." "." 0 0 0 0 0 + soa = fromJust $ fromRData soard + soarr = + ResourceRecord + { rrname = "." + , rrtype = SOA + , rrclass = IN + , rrttl = 0 + , rdata = soard + } ---------------------------------------------------------------- -loadDB :: String -> FilePath -> IO (Maybe DB) -loadDB zone file = makeDB <$> loadZoneFile zone file +loadDB :: Domain -> FilePath -> IO (Maybe DB) +loadDB zone file = makeDB zone <$> loadZoneFile zone file -loadZoneFile :: String -> FilePath -> IO (Domain, [ResourceRecord]) -loadZoneFile zone file = do - rrs <- catMaybes . map fromResource <$> ZF.parseFile file dom - return (dom, rrs) - where - dom = fromRepresentation zone +loadZoneFile :: Domain -> FilePath -> IO [ResourceRecord] +loadZoneFile zone file = catMaybes . map fromResource <$> ZF.parseFile file zone ---------------------------------------------------------------- -makeDB :: (Domain, [ResourceRecord]) -> Maybe DB -makeDB (_, []) = Nothing +makeDB :: Domain -> [ResourceRecord] -> Maybe DB +makeDB _ [] = Nothing -- RFC 1035 Sec 5.2 -- Exactly one SOA RR should be present at the top of the zone. -makeDB (zone, soa : rrs) - | rrtype soa /= SOA = Nothing - | otherwise = case fromRData $ rdata soa of +makeDB zone (soarr : rrs) + | rrtype soarr /= SOA = Nothing + | otherwise = case fromRData $ rdata soarr of Nothing -> Nothing - Just s -> + Just soa -> Just $ DB { dbZone = zone - , dbSerial = soa_serial s , dbSOA = soa + , dbSOArr = soarr , dbAnswer = ans , dbAuthority = auth , dbAdditional = add - , dbAll = [soa] ++ rrs ++ [soa] -- for AXFR + , dbAll = [soarr] ++ rrs ++ [soarr] -- for AXFR } where -- RFC 9471 @@ -85,7 +91,7 @@ makeDB (zone, soa : rrs) -- gs: glue (in delegated domain) -- zs: in-domain -- expand is for RFC 4592 Sec 2.2.2.Empty Non-terminals - ans = makeMap $ [soa] ++ concat (map (expand zone) zs) + ans = makeMap $ [soarr] ++ concat (map (expand zone) zs) auth = makeMap ns xs = filter (\r -> rrtype r == A || rrtype r == AAAA) zs add = makeMap $ xs ++ gs diff --git a/dnsext-bowline/clove/Config.hs b/dnsext-bowline/clove/Config.hs index 777691ab4..2e152e55b 100644 --- a/dnsext-bowline/clove/Config.hs +++ b/dnsext-bowline/clove/Config.hs @@ -12,7 +12,7 @@ import System.IO.Error (ioeGetErrorString, ioeSetErrorString, tryIOError) {- FOURMOLU_DISABLE -} data Config = Config { cnf_zone :: String - , cnf_source :: FilePath + , cnf_source :: String , cnf_dnssec :: Bool , cnf_notify :: Bool , cnf_notify_addrs :: [String] diff --git a/dnsext-bowline/clove/Control.hs b/dnsext-bowline/clove/Control.hs index 193cfd900..350eb3528 100644 --- a/dnsext-bowline/clove/Control.hs +++ b/dnsext-bowline/clove/Control.hs @@ -35,20 +35,18 @@ readSource s | Just a4 <- readMaybe s = FromUpstream4 a4 | otherwise = FromFile s -loadSource :: Serial -> Config -> IO (Maybe DB) -loadSource serial cnf = case readSource $ cnf_source cnf of - FromUpstream4 ip4 -> toDB <$> Axfr.client serial (IPv4 ip4) dom - FromUpstream6 ip6 -> toDB <$> Axfr.client serial (IPv6 ip6) dom +loadSource :: Domain -> Serial -> Source -> IO (Maybe DB) +loadSource zone serial source = case source of + FromUpstream4 ip4 -> toDB <$> Axfr.client serial (IPv4 ip4) zone + FromUpstream6 ip6 -> toDB <$> Axfr.client serial (IPv6 ip6) zone FromFile fn -> loadDB zone fn where - zone = cnf_zone cnf - dom = fromRepresentation zone toDB [] = Nothing - toDB rrs = makeDB (dom, rrs) + toDB rrs = makeDB zone rrs newControl :: Config -> IO (IORef Control) -newControl cnf@Config{..} = do - mdb <- loadSource 0 cnf +newControl Config{..} = do + mdb <- loadSource zone 0 source let (db, ready) = case mdb of Nothing -> (emptyDB, False) Just db' -> (db', True) @@ -64,15 +62,21 @@ newControl cnf@Config{..} = do , ctlAllowTransfer4 = t4 , ctlAllowTransfer6 = t6 } + where + zone = fromRepresentation cnf_zone + source = readSource cnf_source updateControl :: Config -> IORef Control -> IO () -updateControl cnf ctlref = do +updateControl Config{..} ctlref = do Control{..} <- readIORef ctlref - mdb <- loadSource (dbSerial ctlDB) cnf + let serial = soa_serial $ dbSOA ctlDB + mdb <- loadSource zone serial source case mdb of Nothing -> return () Just db -> atomicModifyIORef' ctlref $ modify db where + zone = fromRepresentation cnf_zone + source = readSource cnf_source modify db ctl = (ctl', ()) where ctl' = diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index f878c575c..c9474f397 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -95,13 +95,23 @@ syncZone cnf ctlref wait = loop initSync :: Int -> IO (IO (), IO ()) initSync refresh = do - tmgr <- getSystemTimerManager var <- newTVarIO False let wakeup = atomically $ writeTVar var True - register = registerTimeout tmgr (refresh * 1000000) wakeup - cancel = unregisterTimeout tmgr - wait = E.bracket register cancel $ \_ -> atomically $ do - v <- readTVar var - check v - writeTVar var False - return (wakeup, wait) + if refresh > 0 + then do + wait <- newWait var wakeup + return (wakeup, wait) + else + return (wakeup, waitBody var) + where + newWait var wakeup = do + tmgr <- getSystemTimerManager + let register = registerTimeout tmgr (refresh * 1000000) wakeup + cancel = unregisterTimeout tmgr + return $ E.bracket register cancel $ \_ -> waitBody var + where + + waitBody var = atomically $ do + v <- readTVar var + check v + writeTVar var False From 18be68f542ee98bd58fcc05cea9af19b10c44c2a Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Feb 2026 17:33:50 +0900 Subject: [PATCH 61/74] wait now can take timeout value --- dnsext-bowline/clove/clove.hs | 31 +++++++++++++------------------ 1 file changed, 13 insertions(+), 18 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index c9474f397..42fe156b0 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -34,7 +34,7 @@ main = do [conffile] <- getArgs cnf@Config{..} <- loadConfig conffile ctlref <- newControl cnf - (wakeup, wait) <- initSync 5 + (wakeup, wait) <- initSync void $ installHandler sigHUP (Catch wakeup) Nothing _ <- forkIO $ syncZone cnf ctlref wait let as = map (axfrServer ctlref (show cnf_tcp_port)) cnf_tcp_addrs @@ -76,11 +76,11 @@ replyQuery db s sa query = void $ NSB.sendTo s bs sa ---------------------------------------------------------------- -syncZone :: Config -> IORef Control -> IO () -> IO () +syncZone :: Config -> IORef Control -> (Int -> IO ()) -> IO () syncZone cnf ctlref wait = loop where loop = do - wait + wait 5 -- reading zone source updateControl cnf ctlref -- notify @@ -93,24 +93,19 @@ syncZone cnf ctlref wait = loop ---------------------------------------------------------------- -initSync :: Int -> IO (IO (), IO ()) -initSync refresh = do +initSync :: IO (IO (), Int -> IO ()) +initSync = do var <- newTVarIO False - let wakeup = atomically $ writeTVar var True - if refresh > 0 - then do - wait <- newWait var wakeup - return (wakeup, wait) - else - return (wakeup, waitBody var) + tmgr <- getSystemTimerManager + return (wakeup var, wait var tmgr) where - newWait var wakeup = do - tmgr <- getSystemTimerManager - let register = registerTimeout tmgr (refresh * 1000000) wakeup - cancel = unregisterTimeout tmgr - return $ E.bracket register cancel $ \_ -> waitBody var + wakeup var = atomically $ writeTVar var True + wait var tmgr tout + | tout == 0 = waitBody var + | otherwise = E.bracket register cancel $ \_ -> waitBody var where - + register = registerTimeout tmgr (tout * 1000000) $ wakeup var + cancel = unregisterTimeout tmgr waitBody var = atomically $ do v <- readTVar var check v From c80525cb7d473538271153b99613c98c5672969c Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Feb 2026 17:50:08 +0900 Subject: [PATCH 62/74] setting proper timeout value --- dnsext-auth/test/example.zone | 4 ++-- dnsext-bowline/clove/Control.hs | 5 +++++ dnsext-bowline/clove/Types.hs | 1 + dnsext-bowline/clove/clove.hs | 7 ++++++- 4 files changed, 14 insertions(+), 3 deletions(-) diff --git a/dnsext-auth/test/example.zone b/dnsext-auth/test/example.zone index 680bd6c28..7b646fdb4 100644 --- a/dnsext-auth/test/example.zone +++ b/dnsext-auth/test/example.zone @@ -1,6 +1,6 @@ @ IN SOA ns.example.jp. hostmaster.example.jp. ( - 870776 ;serial - 1800 ;refresh every 30 minutes + 870779 ;serial + 5 ;refresh every 30 minutes 300 ;retry every 5 minutes 604800 ;expire after a week 86400 ;minimum of a day diff --git a/dnsext-bowline/clove/Control.hs b/dnsext-bowline/clove/Control.hs index 350eb3528..1258daa8f 100644 --- a/dnsext-bowline/clove/Control.hs +++ b/dnsext-bowline/clove/Control.hs @@ -58,6 +58,7 @@ newControl Config{..} = do Control { ctlDB = db , ctlReady = ready + , ctlShouldRefresh = shouldReload source , ctlNotifyAddrs = notify_addrs , ctlAllowTransfer4 = t4 , ctlAllowTransfer6 = t6 @@ -84,3 +85,7 @@ updateControl Config{..} ctlref = do { ctlReady = True , ctlDB = db } + +shouldReload :: Source -> Bool +shouldReload (FromFile _) = False +shouldReload _ = True diff --git a/dnsext-bowline/clove/Types.hs b/dnsext-bowline/clove/Types.hs index 91cffbb94..2d7756de9 100644 --- a/dnsext-bowline/clove/Types.hs +++ b/dnsext-bowline/clove/Types.hs @@ -15,6 +15,7 @@ data Source data Control = Control { ctlDB :: DB , ctlReady :: Bool + , ctlShouldRefresh :: Bool , ctlNotifyAddrs :: [IP] , ctlAllowTransfer4 :: IPRTable IPv4 Bool , ctlAllowTransfer6 :: IPRTable IPv6 Bool diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 42fe156b0..c267b4e4b 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -80,7 +80,12 @@ syncZone :: Config -> IORef Control -> (Int -> IO ()) -> IO () syncZone cnf ctlref wait = loop where loop = do - wait 5 + Control{..} <- readIORef ctlref + let tm + | not ctlShouldRefresh = 0 + | not ctlReady = 10 + | otherwise = fromIntegral $ soa_refresh $ dbSOA ctlDB + wait tm -- reading zone source updateControl cnf ctlref -- notify From 83563aa954f8cfe500e419c118f5d331017fe64e Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Feb 2026 19:40:31 +0900 Subject: [PATCH 63/74] implementing notify --- dnsext-bowline/clove/Notify.hs | 41 +++++++++++++++++++++++++ dnsext-bowline/clove/clove.conf | 2 +- dnsext-bowline/clove/clove.hs | 46 +++++++++++++++++++++-------- dnsext-bowline/dnsext-bowline.cabal | 1 + 4 files changed, 77 insertions(+), 13 deletions(-) create mode 100644 dnsext-bowline/clove/Notify.hs diff --git a/dnsext-bowline/clove/Notify.hs b/dnsext-bowline/clove/Notify.hs new file mode 100644 index 000000000..2895884ad --- /dev/null +++ b/dnsext-bowline/clove/Notify.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedLists #-} + +module Notify where + +import Data.IP +import Data.List.NonEmpty () + +import DNS.Do53.Client +import DNS.Do53.Internal +import DNS.Types + +notify :: Domain -> IP -> IO (Maybe DNSMessage) +notify dom ip = do + emsg <- fmap replyDNSMessage <$> resolve renv q qctl + case emsg of + Left _ -> return Nothing + Right msg -> return $ Just msg + where + riActions = + defaultResolveActions + { ractionTimeoutTime = 3000000 + , ractionLog = \_lvl _mclr ss -> mapM_ putStrLn ss + } + ris = + [ defaultResolveInfo + { rinfoIP = ip + , rinfoPort = 53 + , rinfoActions = riActions + , rinfoUDPRetry = 3 + , rinfoVCLimit = 0 + } + ] + renv = + ResolveEnv + { renvResolver = udpResolver + , renvConcurrent = True -- should set True if multiple RIs are provided + , renvResolveInfos = ris + } + -- fixme: AA flags + q = Question dom SOA IN + qctl = rdFlag FlagClear <> doFlag FlagClear <> aaFlag FlagSet <> opCode OP_NOTIFY diff --git a/dnsext-bowline/clove/clove.conf b/dnsext-bowline/clove/clove.conf index 1b0825b8c..814a081e7 100644 --- a/dnsext-bowline/clove/clove.conf +++ b/dnsext-bowline/clove/clove.conf @@ -2,7 +2,7 @@ zone: example.jp source: zone/example.zone dnssec: yes notify: yes - notify-addrs: ::1 + notify-addrs: 127.0.0.1 allow-transfer: yes allow-transfer-addrs: ::1 tcp-addrs: ::1 diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index c267b4e4b..cafbc1d9b 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -25,6 +25,7 @@ import qualified Axfr import Config import Control import Net +import Notify import Types ---------------------------------------------------------------- @@ -34,13 +35,14 @@ main = do [conffile] <- getArgs cnf@Config{..} <- loadConfig conffile ctlref <- newControl cnf + notifyWithControl ctlref (wakeup, wait) <- initSync void $ installHandler sigHUP (Catch wakeup) Nothing _ <- forkIO $ syncZone cnf ctlref wait let as = map (axfrServer ctlref (show cnf_tcp_port)) cnf_tcp_addrs ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs ss <- mapM serverSocket ais - let cs = map (authServer ctlref) ss + let cs = map (authServer ctlref wakeup) ss foldr1 concurrently_ $ as ++ cs ---------------------------------------------------------------- @@ -56,24 +58,43 @@ axfrServer ctlref port addr = ---------------------------------------------------------------- -authServer :: IORef Control -> Socket -> IO () -authServer ctlref s = loop +authServer :: IORef Control -> IO () -> Socket -> IO () +authServer ctlref wakeup s = loop where loop = do (bs, sa) <- NSB.recvFrom s 2048 case decode bs of -- fixme: which RFC? Left _e -> return () - Right query -> do - ctl <- readIORef ctlref - replyQuery (ctlDB ctl) s sa query + Right query -> case opcode query of + OP_NOTIFY -> do + -- fixme: access control + replyNotice s sa query + wakeup + OP_STD -> do + ctl <- readIORef ctlref + replyQuery (ctlDB ctl) s sa query + _ -> do + replyRefused s sa query loop +replyNotice :: Socket -> SockAddr -> DNSMessage -> IO () +replyNotice s sa query = void $ NSB.sendTo s bs sa + where + flgs = (flags query){isResponse = True} + bs = encode $ query{flags = flgs} + replyQuery :: DB -> Socket -> SockAddr -> DNSMessage -> IO () replyQuery db s sa query = void $ NSB.sendTo s bs sa where bs = encode $ getAnswer db query +replyRefused :: Socket -> SockAddr -> DNSMessage -> IO () +replyRefused s sa query = void $ NSB.sendTo s bs sa + where + flgs = (flags query){isResponse = True} + bs = encode $ query{rcode = Refused, flags = flgs} + ---------------------------------------------------------------- syncZone :: Config -> IORef Control -> (Int -> IO ()) -> IO () @@ -83,19 +104,20 @@ syncZone cnf ctlref wait = loop Control{..} <- readIORef ctlref let tm | not ctlShouldRefresh = 0 - | not ctlReady = 10 + | not ctlReady = 10 -- retry | otherwise = fromIntegral $ soa_refresh $ dbSOA ctlDB wait tm -- reading zone source updateControl cnf ctlref -- notify - {- - Control{..} <- readIORef ctlref - let addrs = ctlNotifyAddrs - notify addrs - -} + notifyWithControl ctlref loop +notifyWithControl :: IORef Control -> IO () +notifyWithControl ctlref = do + Control{..} <- readIORef ctlref + mapM_ (notify $ dbZone ctlDB) $ ctlNotifyAddrs + ---------------------------------------------------------------- initSync :: IO (IO (), Int -> IO ()) diff --git a/dnsext-bowline/dnsext-bowline.cabal b/dnsext-bowline/dnsext-bowline.cabal index dd7072948..cf022a1f5 100644 --- a/dnsext-bowline/dnsext-bowline.cabal +++ b/dnsext-bowline/dnsext-bowline.cabal @@ -152,6 +152,7 @@ executable clove Config Control Net + Notify Types default-language: Haskell2010 From 11eaa8ea87f72efc466e7911ffba271230a7b580 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 19 Feb 2026 09:42:46 +0900 Subject: [PATCH 64/74] delay for notify to get recv-sockets ready --- dnsext-bowline/clove/clove.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index cafbc1d9b..d46c70bf9 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -3,7 +3,7 @@ module Main where -import Control.Concurrent (forkIO) +import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Async (concurrently_) import Control.Concurrent.STM import qualified Control.Exception as E @@ -35,7 +35,9 @@ main = do [conffile] <- getArgs cnf@Config{..} <- loadConfig conffile ctlref <- newControl cnf - notifyWithControl ctlref + _ <- forkIO $ do + threadDelay 1000000 + notifyWithControl ctlref (wakeup, wait) <- initSync void $ installHandler sigHUP (Catch wakeup) Nothing _ <- forkIO $ syncZone cnf ctlref wait From 76e9cb38615c2a95c474c0fe1bf9966ef70ba9b5 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 19 Feb 2026 12:47:06 +0900 Subject: [PATCH 65/74] allow-notify-addrs for Config --- dnsext-bowline/clove/Config.hs | 10 ++++++++-- dnsext-bowline/clove/Control.hs | 2 ++ dnsext-bowline/clove/Types.hs | 1 + dnsext-bowline/clove/clove.conf | 2 ++ 4 files changed, 13 insertions(+), 2 deletions(-) diff --git a/dnsext-bowline/clove/Config.hs b/dnsext-bowline/clove/Config.hs index 2e152e55b..0bcd71628 100644 --- a/dnsext-bowline/clove/Config.hs +++ b/dnsext-bowline/clove/Config.hs @@ -16,6 +16,8 @@ data Config = Config , cnf_dnssec :: Bool , cnf_notify :: Bool , cnf_notify_addrs :: [String] + , cnf_allow_notify :: Bool + , cnf_allow_notify_addrs :: [String] , cnf_allow_transfer :: Bool , cnf_allow_transfer_addrs :: [String] , cnf_tcp_addrs :: [String] @@ -32,11 +34,13 @@ defaultConfig = , cnf_dnssec = False , cnf_notify = False , cnf_notify_addrs = [] + , cnf_allow_notify = False + , cnf_allow_notify_addrs = [] , cnf_allow_transfer = False , cnf_allow_transfer_addrs = [] - , cnf_tcp_addrs = ["127.0.0.1", "::1"] + , cnf_tcp_addrs = [] , cnf_tcp_port = 53 - , cnf_udp_addrs = ["127.0.0.1", "::1"] + , cnf_udp_addrs = [] , cnf_udp_port = 53 } @@ -47,6 +51,8 @@ makeConfig def conf = do cnf_dnssec <- get "dnssec" cnf_dnssec cnf_notify <- get "notify" cnf_notify cnf_notify_addrs <- get "notify-addrs" cnf_notify_addrs + cnf_allow_notify <- get "allow-notify" cnf_allow_notify + cnf_allow_notify_addrs <- get "allow-notify-addrs" cnf_allow_notify_addrs cnf_allow_transfer <- get "allow-transfer" cnf_allow_transfer cnf_allow_transfer_addrs <- get "allow-transfer-addrs" cnf_allow_transfer_addrs cnf_tcp_addrs <- get "tcp-addrs" cnf_tcp_addrs diff --git a/dnsext-bowline/clove/Control.hs b/dnsext-bowline/clove/Control.hs index 1258daa8f..c56b92fba 100644 --- a/dnsext-bowline/clove/Control.hs +++ b/dnsext-bowline/clove/Control.hs @@ -54,12 +54,14 @@ newControl Config{..} = do t4 = fromList $ map (,True) a4 t6 = fromList $ map (,True) a6 notify_addrs = readIP cnf_notify_addrs + allow_notify_addrs = readIP cnf_allow_notify_addrs newIORef $ Control { ctlDB = db , ctlReady = ready , ctlShouldRefresh = shouldReload source , ctlNotifyAddrs = notify_addrs + , ctlAllowNotifyAddrs = allow_notify_addrs , ctlAllowTransfer4 = t4 , ctlAllowTransfer6 = t6 } diff --git a/dnsext-bowline/clove/Types.hs b/dnsext-bowline/clove/Types.hs index 2d7756de9..19f73b629 100644 --- a/dnsext-bowline/clove/Types.hs +++ b/dnsext-bowline/clove/Types.hs @@ -17,6 +17,7 @@ data Control = Control , ctlReady :: Bool , ctlShouldRefresh :: Bool , ctlNotifyAddrs :: [IP] + , ctlAllowNotifyAddrs :: [IP] , ctlAllowTransfer4 :: IPRTable IPv4 Bool , ctlAllowTransfer6 :: IPRTable IPv6 Bool } diff --git a/dnsext-bowline/clove/clove.conf b/dnsext-bowline/clove/clove.conf index 814a081e7..2b70bfdf8 100644 --- a/dnsext-bowline/clove/clove.conf +++ b/dnsext-bowline/clove/clove.conf @@ -3,6 +3,8 @@ zone: example.jp dnssec: yes notify: yes notify-addrs: 127.0.0.1 + allow-notify: no + allow-notify-addrs: allow-transfer: yes allow-transfer-addrs: ::1 tcp-addrs: ::1 From 4a5c7b777864b053a7598b5caf1d2cf2c750fb76 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 19 Feb 2026 12:47:37 +0900 Subject: [PATCH 66/74] comment --- dnsext-bowline/clove/Notify.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dnsext-bowline/clove/Notify.hs b/dnsext-bowline/clove/Notify.hs index 2895884ad..ec7eda232 100644 --- a/dnsext-bowline/clove/Notify.hs +++ b/dnsext-bowline/clove/Notify.hs @@ -36,6 +36,6 @@ notify dom ip = do , renvConcurrent = True -- should set True if multiple RIs are provided , renvResolveInfos = ris } - -- fixme: AA flags q = Question dom SOA IN + -- RFC 5936: DNS Zone Transfer Protocol (AXFR) qctl = rdFlag FlagClear <> doFlag FlagClear <> aaFlag FlagSet <> opCode OP_NOTIFY From 59f712b8c1b33192f18bd5c41bbb4601e1360558 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 19 Feb 2026 12:55:11 +0900 Subject: [PATCH 67/74] access control for notify --- dnsext-bowline/clove/clove.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index d46c70bf9..597094f06 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -8,6 +8,7 @@ import Control.Concurrent.Async (concurrently_) import Control.Concurrent.STM import qualified Control.Exception as E import Control.Monad +import Data.IP import GHC.Event import Network.Run.TCP.Timeout import Network.Socket @@ -70,9 +71,14 @@ authServer ctlref wakeup s = loop Left _e -> return () Right query -> case opcode query of OP_NOTIFY -> do - -- fixme: access control - replyNotice s sa query - wakeup + Control{..} <- readIORef ctlref + case fromSockAddr sa of + Nothing -> replyRefused s sa query + Just (ip, _) + | ip `elem` ctlAllowNotifyAddrs -> do + replyNotice s sa query + wakeup + | otherwise -> replyRefused s sa query OP_STD -> do ctl <- readIORef ctlref replyQuery (ctlDB ctl) s sa query From 18e07d830bd10e8eec81ab3366950f8144c9414a Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 19 Feb 2026 13:56:01 +0900 Subject: [PATCH 68/74] supporting multiple zone --- dnsext-bowline/clove/Config.hs | 73 ++++++++++++++++++++++----------- dnsext-bowline/clove/Control.hs | 15 ++++--- dnsext-bowline/clove/Types.hs | 18 +++++++- dnsext-bowline/clove/clove.conf | 8 ++-- dnsext-bowline/clove/clove.hs | 12 +++--- 5 files changed, 82 insertions(+), 44 deletions(-) diff --git a/dnsext-bowline/clove/Config.hs b/dnsext-bowline/clove/Config.hs index 0bcd71628..dacdbe5d3 100644 --- a/dnsext-bowline/clove/Config.hs +++ b/dnsext-bowline/clove/Config.hs @@ -9,26 +9,28 @@ import DNS.Config import Network.Socket (PortNumber) import System.IO.Error (ioeGetErrorString, ioeSetErrorString, tryIOError) +import Types + {- FOURMOLU_DISABLE -} data Config = Config - { cnf_zone :: String - , cnf_source :: String - , cnf_dnssec :: Bool - , cnf_notify :: Bool - , cnf_notify_addrs :: [String] - , cnf_allow_notify :: Bool - , cnf_allow_notify_addrs :: [String] - , cnf_allow_transfer :: Bool - , cnf_allow_transfer_addrs :: [String] - , cnf_tcp_addrs :: [String] - , cnf_tcp_port :: PortNumber - , cnf_udp_addrs :: [String] - , cnf_udp_port :: PortNumber + { cnf_tcp_addrs :: [String] + , cnf_tcp_port :: PortNumber + , cnf_udp_addrs :: [String] + , cnf_udp_port :: PortNumber } defaultConfig :: Config defaultConfig = Config + { cnf_tcp_addrs = [] + , cnf_tcp_port = 53 + , cnf_udp_addrs = [] + , cnf_udp_port = 53 + } + +defaultZone :: Zone +defaultZone = + Zone { cnf_zone = "example.org" , cnf_source = "example.zone" , cnf_dnssec = False @@ -38,14 +40,27 @@ defaultConfig = , cnf_allow_notify_addrs = [] , cnf_allow_transfer = False , cnf_allow_transfer_addrs = [] - , cnf_tcp_addrs = [] - , cnf_tcp_port = 53 - , cnf_udp_addrs = [] - , cnf_udp_port = 53 } -makeConfig :: Config -> [Conf] -> IO Config -makeConfig def conf = do +makeConfig :: Config -> [Conf] -> IO (Config, [Zone]) +makeConfig def conf0 = do + cnf_tcp_addrs <- get "tcp-addrs" cnf_tcp_addrs + cnf_tcp_port <- get "tcp-port" cnf_tcp_port + cnf_udp_addrs <- get "udp-addrs" cnf_udp_addrs + cnf_udp_port <- get "udp-port" cnf_udp_port + zonelist <- mapM (makeZone defaultZone) zones + pure (Config{..}, zonelist) + where + (conf, zones) = splitConfig conf0 + get k func = do + et <- tryIOError $ maybe (pure $ func def) fromConf $ lookup k conf + let left e = do + let e' = ioeSetErrorString e (k ++ ": " ++ ioeGetErrorString e) + ioError e' + either left pure et + +makeZone :: Zone -> [Conf] -> IO Zone +makeZone def conf = do cnf_zone <- get "zone" cnf_zone cnf_source <- get "source" cnf_source cnf_dnssec <- get "dnssec" cnf_dnssec @@ -55,11 +70,7 @@ makeConfig def conf = do cnf_allow_notify_addrs <- get "allow-notify-addrs" cnf_allow_notify_addrs cnf_allow_transfer <- get "allow-transfer" cnf_allow_transfer cnf_allow_transfer_addrs <- get "allow-transfer-addrs" cnf_allow_transfer_addrs - cnf_tcp_addrs <- get "tcp-addrs" cnf_tcp_addrs - cnf_tcp_port <- get "tcp-port" cnf_tcp_port - cnf_udp_addrs <- get "udp-addrs" cnf_udp_addrs - cnf_udp_port <- get "udp-port" cnf_udp_port - pure Config{..} + pure Zone{..} where get k func = do et <- tryIOError $ maybe (pure $ func def) fromConf $ lookup k conf @@ -67,7 +78,19 @@ makeConfig def conf = do let e' = ioeSetErrorString e (k ++ ": " ++ ioeGetErrorString e) ioError e' either left pure et + {- FOURMOLU_ENABLE -} -loadConfig :: FilePath -> IO Config +loadConfig :: FilePath -> IO (Config, [Zone]) loadConfig file = loadFile file >>= makeConfig defaultConfig + +splitConfig :: [Conf] -> ([Conf], [[Conf]]) +splitConfig xs0 = (gs, zss) + where + p (k, _) = k == "zone" + (gs, os) = break p xs0 + zss = loop os + loop [] = [] + loop (x : xs) = + let (zs', xs') = break p xs + in (x : zs') : loop xs' diff --git a/dnsext-bowline/clove/Control.hs b/dnsext-bowline/clove/Control.hs index c56b92fba..3774ed7f5 100644 --- a/dnsext-bowline/clove/Control.hs +++ b/dnsext-bowline/clove/Control.hs @@ -14,7 +14,6 @@ import DNS.Auth.DB import DNS.Types import qualified Axfr -import Config import Types readIP :: [String] -> [IP] @@ -44,8 +43,8 @@ loadSource zone serial source = case source of toDB [] = Nothing toDB rrs = makeDB zone rrs -newControl :: Config -> IO (IORef Control) -newControl Config{..} = do +newControl :: Zone -> IO (IORef Control) +newControl Zone{..} = do mdb <- loadSource zone 0 source let (db, ready) = case mdb of Nothing -> (emptyDB, False) @@ -64,22 +63,22 @@ newControl Config{..} = do , ctlAllowNotifyAddrs = allow_notify_addrs , ctlAllowTransfer4 = t4 , ctlAllowTransfer6 = t6 + , ctlZone = zone + , ctlSource = source } where zone = fromRepresentation cnf_zone source = readSource cnf_source -updateControl :: Config -> IORef Control -> IO () -updateControl Config{..} ctlref = do +updateControl :: IORef Control -> IO () +updateControl ctlref = do Control{..} <- readIORef ctlref let serial = soa_serial $ dbSOA ctlDB - mdb <- loadSource zone serial source + mdb <- loadSource ctlZone serial ctlSource case mdb of Nothing -> return () Just db -> atomicModifyIORef' ctlref $ modify db where - zone = fromRepresentation cnf_zone - source = readSource cnf_source modify db ctl = (ctl', ()) where ctl' = diff --git a/dnsext-bowline/clove/Types.hs b/dnsext-bowline/clove/Types.hs index 19f73b629..00988673a 100644 --- a/dnsext-bowline/clove/Types.hs +++ b/dnsext-bowline/clove/Types.hs @@ -5,6 +5,7 @@ import Data.IP.RouteTable import Data.Word import DNS.Auth.Algorithm +import DNS.Types data Source = FromFile FilePath @@ -13,7 +14,9 @@ data Source deriving (Eq, Show) data Control = Control - { ctlDB :: DB + { ctlZone :: Domain + , ctlSource :: Source + , ctlDB :: DB , ctlReady :: Bool , ctlShouldRefresh :: Bool , ctlNotifyAddrs :: [IP] @@ -22,4 +25,17 @@ data Control = Control , ctlAllowTransfer6 :: IPRTable IPv6 Bool } +data Zone = Zone + { cnf_zone :: String + , cnf_source :: String + , cnf_dnssec :: Bool + , cnf_notify :: Bool + , cnf_notify_addrs :: [String] + , cnf_allow_notify :: Bool + , cnf_allow_notify_addrs :: [String] + , cnf_allow_transfer :: Bool + , cnf_allow_transfer_addrs :: [String] + } + deriving (Show) + type Serial = Word32 diff --git a/dnsext-bowline/clove/clove.conf b/dnsext-bowline/clove/clove.conf index 2b70bfdf8..a388326c5 100644 --- a/dnsext-bowline/clove/clove.conf +++ b/dnsext-bowline/clove/clove.conf @@ -1,3 +1,7 @@ +tcp-addrs: ::1 +tcp-port: 53 +udp-addrs: ::1 +udp-port: 53 zone: example.jp source: zone/example.zone dnssec: yes @@ -7,7 +11,3 @@ zone: example.jp allow-notify-addrs: allow-transfer: yes allow-transfer-addrs: ::1 -tcp-addrs: ::1 -tcp-port: 53 -udp-addrs: ::1 -udp-port: 53 diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 597094f06..f7baebf3d 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -34,14 +34,14 @@ import Types main :: IO () main = do [conffile] <- getArgs - cnf@Config{..} <- loadConfig conffile - ctlref <- newControl cnf + (Config{..}, zonelist) <- loadConfig conffile + ctlref <- newControl $ head zonelist _ <- forkIO $ do threadDelay 1000000 notifyWithControl ctlref (wakeup, wait) <- initSync void $ installHandler sigHUP (Catch wakeup) Nothing - _ <- forkIO $ syncZone cnf ctlref wait + _ <- forkIO $ syncZone ctlref wait let as = map (axfrServer ctlref (show cnf_tcp_port)) cnf_tcp_addrs ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs ss <- mapM serverSocket ais @@ -105,8 +105,8 @@ replyRefused s sa query = void $ NSB.sendTo s bs sa ---------------------------------------------------------------- -syncZone :: Config -> IORef Control -> (Int -> IO ()) -> IO () -syncZone cnf ctlref wait = loop +syncZone :: IORef Control -> (Int -> IO ()) -> IO () +syncZone ctlref wait = loop where loop = do Control{..} <- readIORef ctlref @@ -116,7 +116,7 @@ syncZone cnf ctlref wait = loop | otherwise = fromIntegral $ soa_refresh $ dbSOA ctlDB wait tm -- reading zone source - updateControl cnf ctlref + updateControl ctlref -- notify notifyWithControl ctlref loop From 3a25d0bad9589b67aa4620b0dcc530badd9a37be Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 19 Feb 2026 14:12:55 +0900 Subject: [PATCH 69/74] better naming --- dnsext-bowline/clove/Config.hs | 18 +++++++++--------- dnsext-bowline/clove/Control.hs | 4 ++-- dnsext-bowline/clove/Types.hs | 2 +- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/dnsext-bowline/clove/Config.hs b/dnsext-bowline/clove/Config.hs index dacdbe5d3..8b0322ed0 100644 --- a/dnsext-bowline/clove/Config.hs +++ b/dnsext-bowline/clove/Config.hs @@ -28,9 +28,9 @@ defaultConfig = , cnf_udp_port = 53 } -defaultZone :: Zone -defaultZone = - Zone +defaultZoneConf :: ZoneConf +defaultZoneConf = + ZoneConf { cnf_zone = "example.org" , cnf_source = "example.zone" , cnf_dnssec = False @@ -42,13 +42,13 @@ defaultZone = , cnf_allow_transfer_addrs = [] } -makeConfig :: Config -> [Conf] -> IO (Config, [Zone]) +makeConfig :: Config -> [Conf] -> IO (Config, [ZoneConf]) makeConfig def conf0 = do cnf_tcp_addrs <- get "tcp-addrs" cnf_tcp_addrs cnf_tcp_port <- get "tcp-port" cnf_tcp_port cnf_udp_addrs <- get "udp-addrs" cnf_udp_addrs cnf_udp_port <- get "udp-port" cnf_udp_port - zonelist <- mapM (makeZone defaultZone) zones + zonelist <- mapM (makeZoneConf defaultZoneConf) zones pure (Config{..}, zonelist) where (conf, zones) = splitConfig conf0 @@ -59,8 +59,8 @@ makeConfig def conf0 = do ioError e' either left pure et -makeZone :: Zone -> [Conf] -> IO Zone -makeZone def conf = do +makeZoneConf :: ZoneConf -> [Conf] -> IO ZoneConf +makeZoneConf def conf = do cnf_zone <- get "zone" cnf_zone cnf_source <- get "source" cnf_source cnf_dnssec <- get "dnssec" cnf_dnssec @@ -70,7 +70,7 @@ makeZone def conf = do cnf_allow_notify_addrs <- get "allow-notify-addrs" cnf_allow_notify_addrs cnf_allow_transfer <- get "allow-transfer" cnf_allow_transfer cnf_allow_transfer_addrs <- get "allow-transfer-addrs" cnf_allow_transfer_addrs - pure Zone{..} + pure ZoneConf{..} where get k func = do et <- tryIOError $ maybe (pure $ func def) fromConf $ lookup k conf @@ -81,7 +81,7 @@ makeZone def conf = do {- FOURMOLU_ENABLE -} -loadConfig :: FilePath -> IO (Config, [Zone]) +loadConfig :: FilePath -> IO (Config, [ZoneConf]) loadConfig file = loadFile file >>= makeConfig defaultConfig splitConfig :: [Conf] -> ([Conf], [[Conf]]) diff --git a/dnsext-bowline/clove/Control.hs b/dnsext-bowline/clove/Control.hs index 3774ed7f5..5a8f347cd 100644 --- a/dnsext-bowline/clove/Control.hs +++ b/dnsext-bowline/clove/Control.hs @@ -43,8 +43,8 @@ loadSource zone serial source = case source of toDB [] = Nothing toDB rrs = makeDB zone rrs -newControl :: Zone -> IO (IORef Control) -newControl Zone{..} = do +newControl :: ZoneConf -> IO (IORef Control) +newControl ZoneConf{..} = do mdb <- loadSource zone 0 source let (db, ready) = case mdb of Nothing -> (emptyDB, False) diff --git a/dnsext-bowline/clove/Types.hs b/dnsext-bowline/clove/Types.hs index 00988673a..3774f25a5 100644 --- a/dnsext-bowline/clove/Types.hs +++ b/dnsext-bowline/clove/Types.hs @@ -25,7 +25,7 @@ data Control = Control , ctlAllowTransfer6 :: IPRTable IPv6 Bool } -data Zone = Zone +data ZoneConf = ZoneConf { cnf_zone :: String , cnf_source :: String , cnf_dnssec :: Bool From c1c6b9d982b125c8affe04e64e42e7b414f37d62 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 19 Feb 2026 14:18:12 +0900 Subject: [PATCH 70/74] better naming: Control -> Zone --- dnsext-bowline/clove/Axfr.hs | 12 ++--- dnsext-bowline/clove/Types.hs | 20 ++++---- dnsext-bowline/clove/{Control.hs => Zone.hs} | 48 ++++++++--------- dnsext-bowline/clove/clove.hs | 54 ++++++++++---------- dnsext-bowline/dnsext-bowline.cabal | 2 +- 5 files changed, 68 insertions(+), 68 deletions(-) rename dnsext-bowline/clove/{Control.hs => Zone.hs} (68%) diff --git a/dnsext-bowline/clove/Axfr.hs b/dnsext-bowline/clove/Axfr.hs index 305a61f4d..d03aec929 100644 --- a/dnsext-bowline/clove/Axfr.hs +++ b/dnsext-bowline/clove/Axfr.hs @@ -25,14 +25,14 @@ import Types ---------------------------------------------------------------- server - :: IORef Control + :: IORef Zone -> Socket -> IO () -server ctlref sock = do +server zoneref sock = do sa <- getPeerName sock - ctl <- readIORef ctlref - let t4 = ctlAllowTransfer4 ctl - t6 = ctlAllowTransfer6 ctl + zone <- readIORef zoneref + let t4 = zoneAllowTransfer4 zone + t6 = zoneAllowTransfer6 zone let ok = case fromSockAddr sa of Just (IPv4 ip4, _) -> fromMaybe False $ T.lookup (makeAddrRange ip4 32) t4 Just (IPv6 ip6, _) -> fromMaybe False $ T.lookup (makeAddrRange ip6 128) t6 @@ -42,7 +42,7 @@ server ctlref sock = do Left _ -> return () Right query | ok -> do - let db = ctlDB ctl + let db = zoneDB zone let reply = makeReply db query sendVC (sendTCP sock) $ encode reply | otherwise -> do diff --git a/dnsext-bowline/clove/Types.hs b/dnsext-bowline/clove/Types.hs index 3774f25a5..21bd6a4c7 100644 --- a/dnsext-bowline/clove/Types.hs +++ b/dnsext-bowline/clove/Types.hs @@ -13,16 +13,16 @@ data Source | FromUpstream6 IPv6 deriving (Eq, Show) -data Control = Control - { ctlZone :: Domain - , ctlSource :: Source - , ctlDB :: DB - , ctlReady :: Bool - , ctlShouldRefresh :: Bool - , ctlNotifyAddrs :: [IP] - , ctlAllowNotifyAddrs :: [IP] - , ctlAllowTransfer4 :: IPRTable IPv4 Bool - , ctlAllowTransfer6 :: IPRTable IPv6 Bool +data Zone = Zone + { zoneName :: Domain + , zoneSource :: Source + , zoneDB :: DB + , zoneReady :: Bool + , zoneShouldRefresh :: Bool + , zoneNotifyAddrs :: [IP] + , zoneAllowNotifyAddrs :: [IP] + , zoneAllowTransfer4 :: IPRTable IPv4 Bool + , zoneAllowTransfer6 :: IPRTable IPv6 Bool } data ZoneConf = ZoneConf diff --git a/dnsext-bowline/clove/Control.hs b/dnsext-bowline/clove/Zone.hs similarity index 68% rename from dnsext-bowline/clove/Control.hs rename to dnsext-bowline/clove/Zone.hs index 5a8f347cd..f31cbf088 100644 --- a/dnsext-bowline/clove/Control.hs +++ b/dnsext-bowline/clove/Zone.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -module Control where +module Zone where import Data.IORef import Data.IP @@ -43,8 +43,8 @@ loadSource zone serial source = case source of toDB [] = Nothing toDB rrs = makeDB zone rrs -newControl :: ZoneConf -> IO (IORef Control) -newControl ZoneConf{..} = do +newZone :: ZoneConf -> IO (IORef Zone) +newZone ZoneConf{..} = do mdb <- loadSource zone 0 source let (db, ready) = case mdb of Nothing -> (emptyDB, False) @@ -55,36 +55,36 @@ newControl ZoneConf{..} = do notify_addrs = readIP cnf_notify_addrs allow_notify_addrs = readIP cnf_allow_notify_addrs newIORef $ - Control - { ctlDB = db - , ctlReady = ready - , ctlShouldRefresh = shouldReload source - , ctlNotifyAddrs = notify_addrs - , ctlAllowNotifyAddrs = allow_notify_addrs - , ctlAllowTransfer4 = t4 - , ctlAllowTransfer6 = t6 - , ctlZone = zone - , ctlSource = source + Zone + { zoneDB = db + , zoneReady = ready + , zoneShouldRefresh = shouldReload source + , zoneNotifyAddrs = notify_addrs + , zoneAllowNotifyAddrs = allow_notify_addrs + , zoneAllowTransfer4 = t4 + , zoneAllowTransfer6 = t6 + , zoneName = zone + , zoneSource = source } where zone = fromRepresentation cnf_zone source = readSource cnf_source -updateControl :: IORef Control -> IO () -updateControl ctlref = do - Control{..} <- readIORef ctlref - let serial = soa_serial $ dbSOA ctlDB - mdb <- loadSource ctlZone serial ctlSource +updateZone :: IORef Zone -> IO () +updateZone zoneref = do + Zone{..} <- readIORef zoneref + let serial = soa_serial $ dbSOA zoneDB + mdb <- loadSource zoneName serial zoneSource case mdb of Nothing -> return () - Just db -> atomicModifyIORef' ctlref $ modify db + Just db -> atomicModifyIORef' zoneref $ modify db where - modify db ctl = (ctl', ()) + modify db zone = (zone', ()) where - ctl' = - ctl - { ctlReady = True - , ctlDB = db + zone' = + zone + { zoneReady = True + , zoneDB = db } shouldReload :: Source -> Bool diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index f7baebf3d..71cf3c0f8 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -24,10 +24,10 @@ import Data.IORef import qualified Axfr import Config -import Control import Net import Notify import Types +import Zone ---------------------------------------------------------------- @@ -35,34 +35,34 @@ main :: IO () main = do [conffile] <- getArgs (Config{..}, zonelist) <- loadConfig conffile - ctlref <- newControl $ head zonelist + zoneref <- newZone $ head zonelist _ <- forkIO $ do threadDelay 1000000 - notifyWithControl ctlref + notifyWithZone zoneref (wakeup, wait) <- initSync void $ installHandler sigHUP (Catch wakeup) Nothing - _ <- forkIO $ syncZone ctlref wait - let as = map (axfrServer ctlref (show cnf_tcp_port)) cnf_tcp_addrs + _ <- forkIO $ syncZone zoneref wait + let as = map (axfrServer zoneref (show cnf_tcp_port)) cnf_tcp_addrs ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs ss <- mapM serverSocket ais - let cs = map (authServer ctlref wakeup) ss + let cs = map (authServer zoneref wakeup) ss foldr1 concurrently_ $ as ++ cs ---------------------------------------------------------------- axfrServer - :: IORef Control + :: IORef Zone -> ServiceName -> HostName -> IO () -axfrServer ctlref port addr = +axfrServer zoneref port addr = runTCPServer 10 (Just addr) port $ - \_ _ s -> Axfr.server ctlref s + \_ _ s -> Axfr.server zoneref s ---------------------------------------------------------------- -authServer :: IORef Control -> IO () -> Socket -> IO () -authServer ctlref wakeup s = loop +authServer :: IORef Zone -> IO () -> Socket -> IO () +authServer zoneref wakeup s = loop where loop = do (bs, sa) <- NSB.recvFrom s 2048 @@ -71,17 +71,17 @@ authServer ctlref wakeup s = loop Left _e -> return () Right query -> case opcode query of OP_NOTIFY -> do - Control{..} <- readIORef ctlref + Zone{..} <- readIORef zoneref case fromSockAddr sa of Nothing -> replyRefused s sa query Just (ip, _) - | ip `elem` ctlAllowNotifyAddrs -> do + | ip `elem` zoneAllowNotifyAddrs -> do replyNotice s sa query wakeup | otherwise -> replyRefused s sa query OP_STD -> do - ctl <- readIORef ctlref - replyQuery (ctlDB ctl) s sa query + zone <- readIORef zoneref + replyQuery (zoneDB zone) s sa query _ -> do replyRefused s sa query loop @@ -105,26 +105,26 @@ replyRefused s sa query = void $ NSB.sendTo s bs sa ---------------------------------------------------------------- -syncZone :: IORef Control -> (Int -> IO ()) -> IO () -syncZone ctlref wait = loop +syncZone :: IORef Zone -> (Int -> IO ()) -> IO () +syncZone zoneref wait = loop where loop = do - Control{..} <- readIORef ctlref + Zone{..} <- readIORef zoneref let tm - | not ctlShouldRefresh = 0 - | not ctlReady = 10 -- retry - | otherwise = fromIntegral $ soa_refresh $ dbSOA ctlDB + | not zoneShouldRefresh = 0 + | not zoneReady = 10 -- retry + | otherwise = fromIntegral $ soa_refresh $ dbSOA zoneDB wait tm -- reading zone source - updateControl ctlref + updateZone zoneref -- notify - notifyWithControl ctlref + notifyWithZone zoneref loop -notifyWithControl :: IORef Control -> IO () -notifyWithControl ctlref = do - Control{..} <- readIORef ctlref - mapM_ (notify $ dbZone ctlDB) $ ctlNotifyAddrs +notifyWithZone :: IORef Zone -> IO () +notifyWithZone zoneref = do + Zone{..} <- readIORef zoneref + mapM_ (notify $ dbZone zoneDB) $ zoneNotifyAddrs ---------------------------------------------------------------- diff --git a/dnsext-bowline/dnsext-bowline.cabal b/dnsext-bowline/dnsext-bowline.cabal index cf022a1f5..e08fa0aa8 100644 --- a/dnsext-bowline/dnsext-bowline.cabal +++ b/dnsext-bowline/dnsext-bowline.cabal @@ -150,10 +150,10 @@ executable clove hs-source-dirs: clove other-modules: Axfr Config - Control Net Notify Types + Zone default-language: Haskell2010 ghc-options: -Wall -threaded From 8f871345ba986dab559d5f036442d50d4add9289 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 19 Feb 2026 15:45:46 +0900 Subject: [PATCH 71/74] supporting multiple zones --- dnsext-bowline/clove/Axfr.hs | 44 +++++++++------- dnsext-bowline/clove/Net.hs | 7 ++- dnsext-bowline/clove/Types.hs | 36 ++++++++----- dnsext-bowline/clove/Zone.hs | 60 +++++++++++++++++++-- dnsext-bowline/clove/clove.hs | 98 ++++++++++++++++------------------- 5 files changed, 155 insertions(+), 90 deletions(-) diff --git a/dnsext-bowline/clove/Axfr.hs b/dnsext-bowline/clove/Axfr.hs index d03aec929..3fc28bf5e 100644 --- a/dnsext-bowline/clove/Axfr.hs +++ b/dnsext-bowline/clove/Axfr.hs @@ -8,7 +8,7 @@ module Axfr ( import Data.IORef import Data.IP import qualified Data.IP.RouteTable as T -import Data.List +import Data.List as List import Data.List.NonEmpty () import Data.Maybe import Network.Socket @@ -25,29 +25,37 @@ import Types ---------------------------------------------------------------- server - :: IORef Zone + :: ZoneAlist -> Socket -> IO () -server zoneref sock = do +server zoneAlist sock = do sa <- getPeerName sock - zone <- readIORef zoneref - let t4 = zoneAllowTransfer4 zone - t6 = zoneAllowTransfer6 zone - let ok = case fromSockAddr sa of - Just (IPv4 ip4, _) -> fromMaybe False $ T.lookup (makeAddrRange ip4 32) t4 - Just (IPv6 ip6, _) -> fromMaybe False $ T.lookup (makeAddrRange ip6 128) t6 - _ -> False equery <- decode <$> recvVC (32 * 1024) (recvTCP sock) case equery of Left _ -> return () - Right query - | ok -> do - let db = zoneDB zone - let reply = makeReply db query - sendVC (sendTCP sock) $ encode reply - | otherwise -> do - let reply = (fromQuery query){rcode = Refused} - sendVC (sendTCP sock) $ encode reply + Right query -> do + let dom = qname $ question query + case List.lookup dom zoneAlist of -- exact match + Nothing -> replyRefused query + Just zoneref -> do + zone <- readIORef zoneref + if accessControl zone sa + then do + let db = zoneDB zone + let reply = makeReply db query + sendVC (sendTCP sock) $ encode reply + else replyRefused query + where + replyRefused query = sendVC (sendTCP sock) $ encode reply + where + reply = (fromQuery query){rcode = Refused} + accessControl zone sa = case fromSockAddr sa of + Just (IPv4 ip4, _) -> fromMaybe False $ T.lookup (makeAddrRange ip4 32) t4 + Just (IPv6 ip6, _) -> fromMaybe False $ T.lookup (makeAddrRange ip6 128) t6 + _ -> False + where + t4 = zoneAllowTransfer4 zone + t6 = zoneAllowTransfer6 zone makeReply :: DB -> DNSMessage -> DNSMessage makeReply db query diff --git a/dnsext-bowline/clove/Net.hs b/dnsext-bowline/clove/Net.hs index adc5a7290..ea215cedc 100644 --- a/dnsext-bowline/clove/Net.hs +++ b/dnsext-bowline/clove/Net.hs @@ -4,6 +4,9 @@ import qualified Control.Exception as E import qualified Data.List.NonEmpty as NE import Network.Socket +serverSocket :: PortNumber -> HostName -> IO Socket +serverSocket pn addr = serverResolve pn addr >>= openSock + serverResolve :: PortNumber -> HostName -> IO AddrInfo serverResolve pn addr = NE.head <$> getAddrInfo (Just hints) (Just addr) (Just port) where @@ -14,8 +17,8 @@ serverResolve pn addr = NE.head <$> getAddrInfo (Just hints) (Just addr) (Just p , addrSocketType = Datagram } -serverSocket :: AddrInfo -> IO Socket -serverSocket ai = E.bracketOnError (openSocket ai) close $ \s -> do +openSock :: AddrInfo -> IO Socket +openSock ai = E.bracketOnError (openSocket ai) close $ \s -> do setSocketOption s ReuseAddr 1 bind s $ addrAddress ai return s diff --git a/dnsext-bowline/clove/Types.hs b/dnsext-bowline/clove/Types.hs index 21bd6a4c7..3d57463b4 100644 --- a/dnsext-bowline/clove/Types.hs +++ b/dnsext-bowline/clove/Types.hs @@ -1,5 +1,6 @@ module Types where +import Data.IORef import Data.IP import Data.IP.RouteTable import Data.Word @@ -7,24 +8,14 @@ import Data.Word import DNS.Auth.Algorithm import DNS.Types +---------------------------------------------------------------- + data Source = FromFile FilePath | FromUpstream4 IPv4 | FromUpstream6 IPv6 deriving (Eq, Show) -data Zone = Zone - { zoneName :: Domain - , zoneSource :: Source - , zoneDB :: DB - , zoneReady :: Bool - , zoneShouldRefresh :: Bool - , zoneNotifyAddrs :: [IP] - , zoneAllowNotifyAddrs :: [IP] - , zoneAllowTransfer4 :: IPRTable IPv4 Bool - , zoneAllowTransfer6 :: IPRTable IPv6 Bool - } - data ZoneConf = ZoneConf { cnf_zone :: String , cnf_source :: String @@ -39,3 +30,24 @@ data ZoneConf = ZoneConf deriving (Show) type Serial = Word32 + +---------------------------------------------------------------- + +type WakeUp = IO () +type Wait = Int -> IO () + +data Zone = Zone + { zoneName :: Domain + , zoneSource :: Source + , zoneDB :: DB + , zoneReady :: Bool + , zoneShouldRefresh :: Bool + , zoneNotifyAddrs :: [IP] + , zoneAllowNotifyAddrs :: [IP] + , zoneAllowTransfer4 :: IPRTable IPv4 Bool + , zoneAllowTransfer6 :: IPRTable IPv6 Bool + , zoneWait :: Int -> IO () + , zoneWakeUp :: IO () + } + +type ZoneAlist = [(Domain, IORef Zone)] diff --git a/dnsext-bowline/clove/Zone.hs b/dnsext-bowline/clove/Zone.hs index f31cbf088..ac0ee1ec4 100644 --- a/dnsext-bowline/clove/Zone.hs +++ b/dnsext-bowline/clove/Zone.hs @@ -3,10 +3,14 @@ module Zone where +import Control.Concurrent.STM +import qualified Control.Exception as E import Data.IORef import Data.IP import Data.IP.RouteTable +import Data.List import Data.Maybe +import GHC.Event import Text.Read import DNS.Auth.Algorithm @@ -16,6 +20,8 @@ import DNS.Types import qualified Axfr import Types +---------------------------------------------------------------- + readIP :: [String] -> [IP] readIP ss = mapMaybe readMaybe ss @@ -34,6 +40,8 @@ readSource s | Just a4 <- readMaybe s = FromUpstream4 a4 | otherwise = FromFile s +---------------------------------------------------------------- + loadSource :: Domain -> Serial -> Source -> IO (Maybe DB) loadSource zone serial source = case source of FromUpstream4 ip4 -> toDB <$> Axfr.client serial (IPv4 ip4) zone @@ -43,7 +51,24 @@ loadSource zone serial source = case source of toDB [] = Nothing toDB rrs = makeDB zone rrs -newZone :: ZoneConf -> IO (IORef Zone) +---------------------------------------------------------------- + +findZoneAlist :: Domain -> ZoneAlist -> Maybe (Domain, IORef Zone) +findZoneAlist dom alist = find (\(k, _) -> dom `isSubDomainOf` k) alist + +toZoneAlist :: [Zone] -> IO ZoneAlist +toZoneAlist zones = do + refs <- mapM newIORef zones + return $ zip names refs + where + names = map zoneName zones + +newZones :: [ZoneConf] -> IO [Zone] +newZones zcs = mapM newZone zcs + +---------------------------------------------------------------- + +newZone :: ZoneConf -> IO Zone newZone ZoneConf{..} = do mdb <- loadSource zone 0 source let (db, ready) = case mdb of @@ -54,7 +79,8 @@ newZone ZoneConf{..} = do t6 = fromList $ map (,True) a6 notify_addrs = readIP cnf_notify_addrs allow_notify_addrs = readIP cnf_allow_notify_addrs - newIORef $ + (wakeup, wait) <- initSync + return $ Zone { zoneDB = db , zoneReady = ready @@ -65,11 +91,19 @@ newZone ZoneConf{..} = do , zoneAllowTransfer6 = t6 , zoneName = zone , zoneSource = source + , zoneWakeUp = wakeup + , zoneWait = wait } where zone = fromRepresentation cnf_zone source = readSource cnf_source +shouldReload :: Source -> Bool +shouldReload (FromFile _) = False +shouldReload _ = True + +---------------------------------------------------------------- + updateZone :: IORef Zone -> IO () updateZone zoneref = do Zone{..} <- readIORef zoneref @@ -87,6 +121,22 @@ updateZone zoneref = do , zoneDB = db } -shouldReload :: Source -> Bool -shouldReload (FromFile _) = False -shouldReload _ = True +---------------------------------------------------------------- + +initSync :: IO (WakeUp, Wait) +initSync = do + var <- newTVarIO False + tmgr <- getSystemTimerManager + return (wakeup var, wait var tmgr) + where + wakeup var = atomically $ writeTVar var True + wait var tmgr tout + | tout == 0 = waitBody var + | otherwise = E.bracket register cancel $ \_ -> waitBody var + where + register = registerTimeout tmgr (tout * 1000000) $ wakeup var + cancel = unregisterTimeout tmgr + waitBody var = atomically $ do + v <- readTVar var + check v + writeTVar var False diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs index 71cf3c0f8..4dd8d8092 100644 --- a/dnsext-bowline/clove/clove.hs +++ b/dnsext-bowline/clove/clove.hs @@ -5,11 +5,8 @@ module Main where import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Async (concurrently_) -import Control.Concurrent.STM -import qualified Control.Exception as E import Control.Monad import Data.IP -import GHC.Event import Network.Run.TCP.Timeout import Network.Socket import qualified Network.Socket.ByteString as NSB @@ -33,36 +30,43 @@ import Zone main :: IO () main = do + -- Initialization [conffile] <- getArgs (Config{..}, zonelist) <- loadConfig conffile - zoneref <- newZone $ head zonelist + zones <- newZones zonelist + zoneAlist <- toZoneAlist zones + -- Notify + let (_, zonerefs) = unzip zoneAlist _ <- forkIO $ do threadDelay 1000000 - notifyWithZone zoneref - (wakeup, wait) <- initSync - void $ installHandler sigHUP (Catch wakeup) Nothing - _ <- forkIO $ syncZone zoneref wait - let as = map (axfrServer zoneref (show cnf_tcp_port)) cnf_tcp_addrs - ais <- mapM (serverResolve cnf_udp_port) cnf_udp_addrs - ss <- mapM serverSocket ais - let cs = map (authServer zoneref wakeup) ss + mapM_ notifyWithZone zonerefs + -- Zone updators + let wakeupAll = sequence_ $ map zoneWakeUp zones + void $ installHandler sigHUP (Catch wakeupAll) Nothing + mapM_ (void . forkIO . syncZone) zonerefs + -- AXFR servers: TCP + let as = map (axfrServer zoneAlist (show cnf_tcp_port)) cnf_tcp_addrs + -- Authoritative servers: UDP + ss <- mapM (serverSocket cnf_udp_port) cnf_udp_addrs + let cs = map (authServer zoneAlist) ss + -- Run servers foldr1 concurrently_ $ as ++ cs ---------------------------------------------------------------- axfrServer - :: IORef Zone + :: ZoneAlist -> ServiceName -> HostName -> IO () -axfrServer zoneref port addr = +axfrServer zoneAlist port addr = runTCPServer 10 (Just addr) port $ - \_ _ s -> Axfr.server zoneref s + \_ _ s -> Axfr.server zoneAlist s ---------------------------------------------------------------- -authServer :: IORef Zone -> IO () -> Socket -> IO () -authServer zoneref wakeup s = loop +authServer :: ZoneAlist -> Socket -> IO () +authServer zoneAlist s = loop where loop = do (bs, sa) <- NSB.recvFrom s 2048 @@ -70,21 +74,29 @@ authServer zoneref wakeup s = loop -- fixme: which RFC? Left _e -> return () Right query -> case opcode query of - OP_NOTIFY -> do - Zone{..} <- readIORef zoneref - case fromSockAddr sa of - Nothing -> replyRefused s sa query - Just (ip, _) - | ip `elem` zoneAllowNotifyAddrs -> do - replyNotice s sa query - wakeup - | otherwise -> replyRefused s sa query + OP_NOTIFY -> handleNotify sa query OP_STD -> do - zone <- readIORef zoneref - replyQuery (zoneDB zone) s sa query - _ -> do - replyRefused s sa query + let dom = qname $ question query + case findZoneAlist dom zoneAlist of -- isSubDomainOf + Nothing -> replyRefused s sa query + Just (_, zoneref) -> do + zone <- readIORef zoneref + replyQuery (zoneDB zone) s sa query + _ -> replyRefused s sa query loop + handleNotify sa query = case lookup dom zoneAlist of -- exact match + Nothing -> replyRefused s sa query + Just zoneref -> do + Zone{..} <- readIORef zoneref + case fromSockAddr sa of + Nothing -> replyRefused s sa query + Just (ip, _) + | ip `elem` zoneAllowNotifyAddrs -> do + replyNotice s sa query + zoneWakeUp + | otherwise -> replyRefused s sa query + where + dom = qname $ question query replyNotice :: Socket -> SockAddr -> DNSMessage -> IO () replyNotice s sa query = void $ NSB.sendTo s bs sa @@ -105,8 +117,8 @@ replyRefused s sa query = void $ NSB.sendTo s bs sa ---------------------------------------------------------------- -syncZone :: IORef Zone -> (Int -> IO ()) -> IO () -syncZone zoneref wait = loop +syncZone :: IORef Zone -> IO () +syncZone zoneref = loop where loop = do Zone{..} <- readIORef zoneref @@ -114,7 +126,7 @@ syncZone zoneref wait = loop | not zoneShouldRefresh = 0 | not zoneReady = 10 -- retry | otherwise = fromIntegral $ soa_refresh $ dbSOA zoneDB - wait tm + zoneWait tm -- reading zone source updateZone zoneref -- notify @@ -125,23 +137,3 @@ notifyWithZone :: IORef Zone -> IO () notifyWithZone zoneref = do Zone{..} <- readIORef zoneref mapM_ (notify $ dbZone zoneDB) $ zoneNotifyAddrs - ----------------------------------------------------------------- - -initSync :: IO (IO (), Int -> IO ()) -initSync = do - var <- newTVarIO False - tmgr <- getSystemTimerManager - return (wakeup var, wait var tmgr) - where - wakeup var = atomically $ writeTVar var True - wait var tmgr tout - | tout == 0 = waitBody var - | otherwise = E.bracket register cancel $ \_ -> waitBody var - where - register = registerTimeout tmgr (tout * 1000000) $ wakeup var - cancel = unregisterTimeout tmgr - waitBody var = atomically $ do - v <- readTVar var - check v - writeTVar var False From 7a1358a9220a4218aa322f8207136ae934eab4cb Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 25 Feb 2026 07:46:37 +0900 Subject: [PATCH 72/74] adding auth to cabal.project --- cabal.project | 1 + 1 file changed, 1 insertion(+) diff --git a/cabal.project b/cabal.project index a2fa3f332..be42484ec 100644 --- a/cabal.project +++ b/cabal.project @@ -6,4 +6,5 @@ packages: dnsext-do53 dnsext-dox dnsext-iterative + dnsext-auth dnsext-bowline From e9d195b5e830a089670dc0d559e7b348555295eb Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 25 Feb 2026 08:40:11 +0900 Subject: [PATCH 73/74] copying the definition of unsnoc --- dnsext-bowline/clove/Axfr.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/dnsext-bowline/clove/Axfr.hs b/dnsext-bowline/clove/Axfr.hs index 3fc28bf5e..74682dd46 100644 --- a/dnsext-bowline/clove/Axfr.hs +++ b/dnsext-bowline/clove/Axfr.hs @@ -141,9 +141,11 @@ checkSOA :: [ResourceRecord] -> [ResourceRecord] checkSOA [] = [] checkSOA (soa : rrs) | rrtype soa == SOA = - case unsnoc rrs of + case unsnoc' rrs of Nothing -> [] Just (rrs', soa') | rrtype soa' == SOA -> soa : rrs' | otherwise -> [] | otherwise = [] + where + unsnoc' = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing From 5a93588826832b8e850adeb0818b490d539fe56d Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 26 Feb 2026 14:45:38 +0900 Subject: [PATCH 74/74] adding dnsext-auth to Dockerfile --- build-docker/Dockerfile | 1 + 1 file changed, 1 insertion(+) diff --git a/build-docker/Dockerfile b/build-docker/Dockerfile index 7fbe663d6..dfc67a5bd 100644 --- a/build-docker/Dockerfile +++ b/build-docker/Dockerfile @@ -85,6 +85,7 @@ git clone ${CLONE_URL} dnsext-do53 \ dnsext-iterative \ dnsext-dox \ + dnsext-auth \ dnsext-bowline \ ; do touch ${dir}/CHANGELOG.md