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 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/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 diff --git a/dnsext-auth/DNS/Auth/Algorithm.hs b/dnsext-auth/DNS/Auth/Algorithm.hs new file mode 100644 index 000000000..62ed6c889 --- /dev/null +++ b/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} + } diff --git a/dnsext-auth/DNS/Auth/DB.hs b/dnsext-auth/DNS/Auth/DB.hs new file mode 100644 index 000000000..1d73b6b89 --- /dev/null +++ b/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 "" + } 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..ab742f443 --- /dev/null +++ b/dnsext-auth/dnsext-auth.cabal @@ -0,0 +1,45 @@ +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 + +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..ce16387e6 --- /dev/null +++ b/dnsext-auth/test/AlgorithmSpec.hs @@ -0,0 +1,148 @@ +{-# 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 + 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 + rcode ans `shouldBe` NoErr + 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-existing 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 + flags ans `shouldSatisfy` authAnswer + 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 + 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 + 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 + 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 + 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 + 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 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 + rcode ans `shouldBe` NXDomain + 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 + 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 + 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..7b646fdb4 --- /dev/null +++ b/dnsext-auth/test/example.zone @@ -0,0 +1,23 @@ +@ IN SOA ns.example.jp. hostmaster.example.jp. ( + 870779 ;serial + 5 ;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. 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 diff --git a/dnsext-bowline/clove/Axfr.hs b/dnsext-bowline/clove/Axfr.hs new file mode 100644 index 000000000..74682dd46 --- /dev/null +++ b/dnsext-bowline/clove/Axfr.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedLists #-} + +module Axfr ( + server, + client, +) where + +import Data.IORef +import Data.IP +import qualified Data.IP.RouteTable as T +import Data.List as List +import Data.List.NonEmpty () +import Data.Maybe +import Network.Socket + +import DNS.Auth.Algorithm +import DNS.Do53.Client +import DNS.Do53.Internal +import DNS.Types +import DNS.Types.Decode +import DNS.Types.Encode + +import Types + +---------------------------------------------------------------- + +server + :: ZoneAlist + -> Socket + -> IO () +server zoneAlist sock = do + sa <- getPeerName sock + equery <- decode <$> recvVC (32 * 1024) (recvTCP sock) + case equery of + Left _ -> return () + 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 + | qtype (question query) == AXFR = (fromQuery query){answer = dbAll db} + | otherwise = getAnswer db query + +---------------------------------------------------------------- + +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 = [] + where + unsnoc' = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing diff --git a/dnsext-bowline/clove/Config.hs b/dnsext-bowline/clove/Config.hs new file mode 100644 index 000000000..8b0322ed0 --- /dev/null +++ b/dnsext-bowline/clove/Config.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE RecordWildCards #-} + +module Config ( + Config (..), + loadConfig, +) where + +import DNS.Config +import Network.Socket (PortNumber) +import System.IO.Error (ioeGetErrorString, ioeSetErrorString, tryIOError) + +import Types + +{- FOURMOLU_DISABLE -} +data Config = Config + { 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 + } + +defaultZoneConf :: ZoneConf +defaultZoneConf = + ZoneConf + { cnf_zone = "example.org" + , cnf_source = "example.zone" + , 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 = [] + } + +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 (makeZoneConf defaultZoneConf) 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 + +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 + 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 + pure ZoneConf{..} + 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 + +{- FOURMOLU_ENABLE -} + +loadConfig :: FilePath -> IO (Config, [ZoneConf]) +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/Net.hs b/dnsext-bowline/clove/Net.hs new file mode 100644 index 000000000..ea215cedc --- /dev/null +++ b/dnsext-bowline/clove/Net.hs @@ -0,0 +1,24 @@ +module Net where + +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 + port = show pn + hints = + defaultHints + { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE] + , addrSocketType = Datagram + } + +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/Notify.hs b/dnsext-bowline/clove/Notify.hs new file mode 100644 index 000000000..ec7eda232 --- /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 + } + q = Question dom SOA IN + -- RFC 5936: DNS Zone Transfer Protocol (AXFR) + qctl = rdFlag FlagClear <> doFlag FlagClear <> aaFlag FlagSet <> opCode OP_NOTIFY diff --git a/dnsext-bowline/clove/Types.hs b/dnsext-bowline/clove/Types.hs new file mode 100644 index 000000000..3d57463b4 --- /dev/null +++ b/dnsext-bowline/clove/Types.hs @@ -0,0 +1,53 @@ +module Types where + +import Data.IORef +import Data.IP +import Data.IP.RouteTable +import Data.Word + +import DNS.Auth.Algorithm +import DNS.Types + +---------------------------------------------------------------- + +data Source + = FromFile FilePath + | FromUpstream4 IPv4 + | FromUpstream6 IPv6 + deriving (Eq, Show) + +data ZoneConf = ZoneConf + { 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 + +---------------------------------------------------------------- + +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 new file mode 100644 index 000000000..ac0ee1ec4 --- /dev/null +++ b/dnsext-bowline/clove/Zone.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +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 +import DNS.Auth.DB +import DNS.Types + +import qualified Axfr +import Types + +---------------------------------------------------------------- + +readIP :: [String] -> [IP] +readIP ss = mapMaybe 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 :: 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 + toDB [] = Nothing + toDB rrs = makeDB zone rrs + +---------------------------------------------------------------- + +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 + 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 + notify_addrs = readIP cnf_notify_addrs + allow_notify_addrs = readIP cnf_allow_notify_addrs + (wakeup, wait) <- initSync + return $ + Zone + { zoneDB = db + , zoneReady = ready + , zoneShouldRefresh = shouldReload source + , zoneNotifyAddrs = notify_addrs + , zoneAllowNotifyAddrs = allow_notify_addrs + , zoneAllowTransfer4 = t4 + , 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 + let serial = soa_serial $ dbSOA zoneDB + mdb <- loadSource zoneName serial zoneSource + case mdb of + Nothing -> return () + Just db -> atomicModifyIORef' zoneref $ modify db + where + modify db zone = (zone', ()) + where + zone' = + zone + { zoneReady = True + , zoneDB = db + } + +---------------------------------------------------------------- + +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.conf b/dnsext-bowline/clove/clove.conf new file mode 100644 index 000000000..a388326c5 --- /dev/null +++ b/dnsext-bowline/clove/clove.conf @@ -0,0 +1,13 @@ +tcp-addrs: ::1 +tcp-port: 53 +udp-addrs: ::1 +udp-port: 53 +zone: example.jp + source: zone/example.zone + dnssec: yes + notify: yes + notify-addrs: 127.0.0.1 + allow-notify: no + allow-notify-addrs: + allow-transfer: yes + allow-transfer-addrs: ::1 diff --git a/dnsext-bowline/clove/clove.hs b/dnsext-bowline/clove/clove.hs new file mode 100644 index 000000000..4dd8d8092 --- /dev/null +++ b/dnsext-bowline/clove/clove.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.Async (concurrently_) +import Control.Monad +import Data.IP +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 +import DNS.Types.Decode +import DNS.Types.Encode +import Data.IORef + +import qualified Axfr +import Config +import Net +import Notify +import Types +import Zone + +---------------------------------------------------------------- + +main :: IO () +main = do + -- Initialization + [conffile] <- getArgs + (Config{..}, zonelist) <- loadConfig conffile + zones <- newZones zonelist + zoneAlist <- toZoneAlist zones + -- Notify + let (_, zonerefs) = unzip zoneAlist + _ <- forkIO $ do + threadDelay 1000000 + 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 + :: ZoneAlist + -> ServiceName + -> HostName + -> IO () +axfrServer zoneAlist port addr = + runTCPServer 10 (Just addr) port $ + \_ _ s -> Axfr.server zoneAlist s + +---------------------------------------------------------------- + +authServer :: ZoneAlist -> Socket -> IO () +authServer zoneAlist s = loop + where + loop = do + (bs, sa) <- NSB.recvFrom s 2048 + case decode bs of + -- fixme: which RFC? + Left _e -> return () + Right query -> case opcode query of + OP_NOTIFY -> handleNotify sa query + OP_STD -> do + 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 + 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 :: IORef Zone -> IO () +syncZone zoneref = loop + where + loop = do + Zone{..} <- readIORef zoneref + let tm + | not zoneShouldRefresh = 0 + | not zoneReady = 10 -- retry + | otherwise = fromIntegral $ soa_refresh $ dbSOA zoneDB + zoneWait tm + -- reading zone source + updateZone zoneref + -- notify + notifyWithZone zoneref + loop + +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 9f0facd6f..e08fa0aa8 100644 --- a/dnsext-bowline/dnsext-bowline.cabal +++ b/dnsext-bowline/dnsext-bowline.cabal @@ -145,6 +145,39 @@ executable ddrd if impl(ghc >=8) default-extensions: Strict StrictData +executable clove + main-is: clove.hs + hs-source-dirs: clove + other-modules: Axfr + Config + Net + Notify + Types + Zone + + default-language: Haskell2010 + ghc-options: -Wall -threaded + build-depends: + -- GHC bundled + base, + async, + network, + -- dnsext packages + dnsext-auth, + dnsext-do53, + dnsext-types, + dnsext-utils, + iproute, + network-run, + stm, + unix + + 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 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