Clove: authoritative DNS server

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

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

cabal.project

@@ -6,4 +6,5 @@ packages:
   dnsext-do53
   dnsext-dox
   dnsext-iterative
+  dnsext-auth
   dnsext-bowline

dnsext-auth/DNS/Auth/Algorithm.hs

@@ -0,0 +1,143 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module DNS.Auth.Algorithm (
+    getAnswer,
+    DB (..),
+    fromQuery,
+) where
+
+import Data.List (nub, sort)
+import qualified Data.Map.Strict as M
+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
+-- queries as if the Recursion Desired (RD) bit is not set
+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 = (flags reply){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
+    reply = fromQuery 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
+        -- RFC 8482 Sec 4.1
+        -- Answer with a Subset of Available RRsets
+        | qtype == ANY -> makeAnswer (take 1 rs) []
+        | 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 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
+  where
+    add
+        | cname `isSubDomainOf` dbZone =
+            fromMaybe [] $ M.lookup cname dbAdditional
+        | otherwise = []
+processCNAME DB{..} Question{..} reply c cname = makeReply reply ans [] [] code True
+  where
+    (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
+    -> Question
+    -> DNSMessage
+    -> DNSMessage
+findAuthority db@DB{..} Question{..} reply = loop qname
+  where
+    loop dom
+        | dom == dbZone = makeReply reply [] [dbSOArr] [] NXDomain True
+        | otherwise = case unconsDomain dom of
+            Nothing -> makeReply reply [] [dbSOArr] [] NXDomain True
+            Just (_, dom') -> case M.lookup dom dbAuthority of
+                Nothing -> loop dom'
+                Just auth
+                    | null auth -> makeReply reply [] [dbSOArr] [] NoErr True
+                    | otherwise ->
+                        let add = findAdditional db auth
+                         in makeReply reply [] auth add NoErr False
+
+findAdditional
+    :: DB
+    -> [ResourceRecord] -- NSs in Answer or Authority
+    -> [ResourceRecord]
+findAdditional DB{..} rs0 = add
+  where
+    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)
+
+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}
+        }

dnsext-auth/DNS/Auth/DB.hs

@@ -0,0 +1,159 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module DNS.Auth.DB (
+    DB (..),
+    loadDB,
+    makeDB,
+    emptyDB,
+) where
+
+import Data.Function (on)
+import Data.List (groupBy, partition, sort)
+import qualified Data.Map.Strict as M
+import Data.Maybe (catMaybes, fromJust)
+import qualified Data.Set as Set
+
+import DNS.Types
+import qualified DNS.ZoneFile as ZF
+
+----------------------------------------------------------------
+
+data DB = DB
+    { dbZone :: Domain
+    , dbSOA :: RD_SOA
+    , dbSOArr :: ResourceRecord
+    , dbAnswer :: M.Map Domain [ResourceRecord]
+    , dbAuthority :: M.Map Domain [ResourceRecord]
+    , dbAdditional :: M.Map Domain [ResourceRecord]
+    , dbAll :: [ResourceRecord]
+    }
+    deriving (Show)
+
+emptyDB :: DB
+emptyDB =
+    DB
+        { 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 :: Domain -> FilePath -> IO (Maybe DB)
+loadDB zone file = makeDB zone <$> loadZoneFile zone file
+
+loadZoneFile :: Domain -> FilePath -> IO [ResourceRecord]
+loadZoneFile zone file = catMaybes . map fromResource <$> ZF.parseFile file zone
+
+----------------------------------------------------------------
+
+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 (soarr : rrs)
+    | rrtype soarr /= SOA = Nothing
+    | otherwise = case fromRData $ rdata soarr of
+        Nothing -> Nothing
+        Just soa ->
+            Just $
+                DB
+                    { dbZone = zone
+                    , dbSOA = soa
+                    , dbSOArr = soarr
+                    , dbAnswer = ans
+                    , dbAuthority = auth
+                    , dbAdditional = add
+                    , dbAll = [soarr] ++ rrs ++ [soarr] -- for AXFR
+                    }
+  where
+    -- RFC 9471
+    -- In-domain and sibling glues only.
+    -- Unrelated glues are ignored.
+    (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
+    -- expand is for RFC 4592 Sec 2.2.2.Empty Non-terminals
+    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
+
+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)
+    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] -> M.Map Domain [ResourceRecord]
+makeMap rrs = M.fromList kvs
+  where
+    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
+unsafeHead (x : _) = x
+unsafeHead _ = error "unsafeHead"
+
+----------------------------------------------------------------
+
+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
+    r0 = rrname rr
+    loop r
+        | r == dom = [rr]
+        | otherwise = case unconsDomain r of
+            Nothing -> [rr]
+            Just (_, r1) -> rrnull r : loop r1
+
+rrnull :: Domain -> ResourceRecord
+rrnull r =
+    ResourceRecord
+        { rrname = r
+        , rrtype = NULL
+        , rrclass = IN
+        , rrttl = 0
+        , rdata = rd_null ""
+        }

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.