microdns (empty) → 0.1.0.0
raw patch · 10 files changed
+968/−0 lines, 10 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, base16-bytestring, bytestring, case-insensitive, cryptohash-sha256, dns, ip, iproute, megaparsec, network, optparse-generic, prodapi, prometheus-client, servant, servant-server, streaming-commons, text, wai-extra, warp, warp-tls
Files
- CHANGELOG.md +5/−0
- app/Main.hs +118/−0
- microdns.cabal +63/−0
- src/MicroDNS.hs +13/−0
- src/MicroDNS/DAI.hs +23/−0
- src/MicroDNS/DynamicRegistration.hs +331/−0
- src/MicroDNS/Handler.hs +92/−0
- src/MicroDNS/MicroZone.hs +216/−0
- src/MicroDNS/Runtime.hs +66/−0
- src/MicroDNS/Server.hs +41/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for microdns++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ app/Main.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Main where++import Control.Concurrent.Async+import Data.Coerce (coerce)+import Data.Maybe (catMaybes)+import qualified Network.DNS as DNS++import Options.Generic++import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.Text.IO as Text+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Handler.WarpTLS as Warp+import qualified Network.Wai.Middleware.RequestLogger as RequestLogger+import qualified Paths_prodapi+import qualified Prod.App as Prod+import Prod.Status+import Prod.Tracer (tracePrint)+import qualified Text.Megaparsec as Megaparsec++import qualified MicroDNS+import qualified MicroDNS.DynamicRegistration as DynamicRegistration+import Servant++type DNSApex = Text++data Params+ = Plain+ { dnsPort :: Int <?> "DNS port number"+ , dnsApex :: Text <?> "delegated DNS apex"+ , webHmacSecretFile :: FilePath <?> "shared secret file for hmac"+ , webPort :: Int <?> "web console port number"+ , zoneFile :: FilePath <?> "zonefile"+ }+ | Tls+ { dnsPort :: Int <?> "DNS port number"+ , dnsApex :: Text <?> "delegated DNS apex"+ , webHmacSecretFile :: FilePath <?> "shared secret file for hmac"+ , webPort :: Int <?> "web console port number"+ , certFile :: FilePath <?> "certificate file"+ , keyFile :: FilePath <?> "key file"+ , zoneFile :: FilePath <?> "zonefile"+ }+ deriving (Generic, Show)+instance ParseRecord Params++main :: IO ()+main = do+ args <- getRecord "microdns"+ -- app glueing+ healthRt <- (Prod.alwaysReadyRuntime tracePrint)+ init <- Prod.initialize healthRt+ appRuntime <- initRuntime args+ let webapp =+ RequestLogger.logStdoutDev $+ Prod.app+ init+ apiStatus+ (statusPage <> versionsSection [("prodapi", Paths_prodapi.version)])+ (serveApi appRuntime)+ (Proxy @Api)+ dnsrt <- MicroDNS.initRuntime (coerce $ dnsPort args) tracePrint+ configRRs <- loadConfigRRs (MicroDNS.apexFromText $ coerce $ dnsApex args) (coerce zoneFile args)+ _ <- traverse print configRRs+ let combinedRRs = DynamicRegistration.readRRs (dynamicRegistrationRuntime appRuntime) <> pure configRRs+ let dnsapp = MicroDNS.handleQuestion dnsrt (MicroDNS.ioLookup combinedRRs)++ let dns = MicroDNS.serve dnsrt dnsapp+ let web = runWebApp args webapp++ _ <-+ runConcurrently $+ (,,)+ <$> Concurrently web+ <*> Concurrently dns+ pure ()+ where+ runWebApp :: Params -> Application -> IO ()+ runWebApp params@(Plain _ _ _ _ _) webapp =+ let warpSettings = Warp.setPort (coerce $ webPort params) $ Warp.defaultSettings+ in Warp.runSettings warpSettings webapp+ runWebApp params@(Tls _ _ _ _ _ _ _) webapp =+ let tlsSettings = Warp.tlsSettings (coerce $ certFile params) (coerce $ keyFile params)+ warpTlsSettings = Warp.setPort (coerce $ webPort params) $ Warp.defaultSettings+ in Warp.runTLS tlsSettings warpTlsSettings webapp++ apiStatus :: IO Text+ apiStatus = pure "ok"++ loadConfigRRs :: MicroDNS.Apex -> FilePath -> IO [DNS.ResourceRecord]+ loadConfigRRs apex zfile = do+ zonecontent <- Megaparsec.parse MicroDNS.zoneFile zfile <$> Text.readFile zfile+ case zonecontent of+ Left err -> error $ show err+ Right zones -> pure $ MicroDNS.collectDirectives apex zones++type Api = DynamicRegistration.Api++data Runtime = Runtime+ { dynamicRegistrationRuntime :: DynamicRegistration.Runtime+ }++initRuntime :: Params -> IO Runtime+initRuntime params = do+ secret <- ByteString.readFile (coerce $ webHmacSecretFile params)+ Runtime+ <$> DynamicRegistration.initRuntime tracePrint secret (MicroDNS.apexFromText $ coerce $ dnsApex params)++serveApi :: Runtime -> Server Api+serveApi Runtime{..} = DynamicRegistration.handleDynamicRegistration dynamicRegistrationRuntime
+ microdns.cabal view
@@ -0,0 +1,63 @@+cabal-version: 2.4+name: microdns+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: a minimalistic DNS-authoritative server++-- A longer description of the package.+description: a DNS-authoritative server configurable over HTTP for dynamic-DNS and cert-signing purposes++-- A URL where users can report bugs.+-- bug-reports:++-- The license under which the package is released.+license: BSD-3-Clause+author: Lucas DiCioccio+maintainer: lucas@dicioccio.fr++-- A copyright notice.+-- copyright:+category: Networking+extra-source-files: CHANGELOG.md++executable microdns+ main-is: Main.hs++ -- Modules included in this executable, other than Main.+ other-modules: MicroDNS+ , MicroDNS.DynamicRegistration+ , MicroDNS.DAI+ , MicroDNS.Handler+ , MicroDNS.Runtime+ , MicroDNS.Server+ , MicroDNS.MicroZone++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:+ build-depends:+ aeson >= 2.2.1 && < 2.3,+ base >= 4.19.1 && < 4.20,+ bytestring >= 0.12.1 && < 0.13,+ text >= 2.1.1 && < 2.2,+ async >= 2.2.5 && < 2.3,+ base16-bytestring >= 1.0.2 && < 1.1,+ case-insensitive >= 1.2.1 && < 1.3,+ cryptohash-sha256 >= 0.11.102 && < 0.12,+ dns >= 4.2.0 && < 4.3,+ iproute >= 1.7.12 && < 1.8,+ network >= 3.1.4 && < 3.2,+ ip >= 1.7.8 && < 1.8,+ megaparsec >= 9.6.1 && < 9.7,+ optparse-generic >= 1.5.2 && < 1.6,+ prodapi >= 0.1.0 && < 0.2,+ streaming-commons >= 0.2.2 && < 0.3,+ prometheus-client >= 1.1.1 && < 1.2,+ servant >= 0.20.1 && < 0.21,+ servant-server >= 0.20 && < 0.21,+ wai-extra >= 3.1.14 && < 3.2,+ warp >= 3.3.31 && < 3.4,+ warp-tls >= 3.4.5 && < 3.5+ hs-source-dirs: app+ , src+ default-language: Haskell2010
+ src/MicroDNS.hs view
@@ -0,0 +1,13 @@+module MicroDNS (+ module MicroDNS.Runtime,+ module MicroDNS.Handler,+ module MicroDNS.DAI,+ module MicroDNS.Server,+ module MicroDNS.MicroZone,+) where++import MicroDNS.DAI+import MicroDNS.Handler+import MicroDNS.MicroZone+import MicroDNS.Runtime+import MicroDNS.Server
+ src/MicroDNS/DAI.hs view
@@ -0,0 +1,23 @@+module MicroDNS.DAI where++import Data.Text (Text)+import qualified Network.DNS as DNS+import Network.Socket (SockAddr, Socket)++type Reason = Text++data Response+ = Ignore Reason+ | RespondMessage !DNS.DNSMessage+ deriving (Show)++data Request+ = Request+ { requestAddr :: !SockAddr+ , requestMessage :: !DNS.DNSMessage+ }+ deriving (Show)++type Handler = Request -> (Response -> IO ()) -> IO ()++type Middleware = Handler -> Handler
+ src/MicroDNS/DynamicRegistration.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++-- TODO:+-- turned HashedPart in some nonces to limit replay risks+module MicroDNS.DynamicRegistration where++import Control.Monad.IO.Class (liftIO)+import qualified Crypto.Hash.SHA256 as HMAC256+import Data.Aeson (FromJSON, ToJSON)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Base16 as Base16+import qualified Data.ByteString.Char8 as C8+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.IP as IP+import qualified Data.List as List+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.Generics (Generic)+import Net.IPv4 as IPv4+import Net.IPv6 as IPv6+import qualified Network.DNS as DNS+import Network.Socket (SockAddr)+import Prod.Background as Background+import Prod.Tracer (Tracer (..), contramap)+import qualified Prod.Tracer as Tracer+import qualified Prometheus as Prometheus+import Servant+import Servant.Server++import MicroDNS.Handler (Apex (..), apexFromText)++type Api =+ AutoRegisterApi+ :<|> RegisterTextApi+ :<|> RegisterAApi+ :<|> RegisterAAAAApi+ :<|> ListRegistrationsApi++type DNSLeafName = Text++type AutoRegisterApi =+ Summary "registers a unique A record"+ :> "register"+ :> "auto"+ :> Capture "dns-leaf" DNSLeafName+ :> QueryParam "apex" Text+ :> RemoteHost+ :> Header "x-forwarded-for" Text+ :> Header "x-microdns-hmac" ChallengeAttempt+ :> Post '[JSON] AutoRegistrationResult++type RegisterTextApi =+ Summary "registers a TXT (e.g., for an ACME challenge)"+ :> "register"+ :> "txt"+ :> Capture "dns-leaf" DNSLeafName+ :> Capture "token" Text+ :> QueryParam "apex" Text+ :> Header "x-microdns-hmac" ChallengeAttempt+ :> Post '[JSON] (DNSLeafName, Text)++type RegisterAApi =+ Summary "registers a A"+ :> "register"+ :> "a"+ :> Capture "dns-leaf" DNSLeafName+ :> Capture "token" Text+ :> QueryParam "apex" Text+ :> Header "x-microdns-hmac" ChallengeAttempt+ :> Post '[JSON] (DNSLeafName, Text)++type RegisterAAAAApi =+ Summary "registers a AAAA"+ :> "register"+ :> "aaaa"+ :> Capture "dns-leaf" DNSLeafName+ :> Capture "token" Text+ :> QueryParam "apex" Text+ :> Header "x-microdns-hmac" ChallengeAttempt+ :> Post '[JSON] (DNSLeafName, Text)++type ListRegistrationsApi =+ Summary "list registrations"+ :> "registrations"+ :> Header "x-microdns-hmac" ChallengeAttempt+ :> Get '[JSON] Registrations++type ChallengeAttempt = Text++data AutoRegistrationResult+ = AutoRegistrationResult+ { registeredLeaf :: DNSLeafName+ , registeredIP :: Text+ }+ deriving (Show, Generic)+instance ToJSON AutoRegistrationResult++data RegistrationFailedReason+ = AuthError+ | ProxiedError+ | IPLookupError+ | IPParsingError+ deriving (Show)++data Registrations+ = Registrations+ { registrations :: [String]+ }+ deriving (Show, Generic)+instance ToJSON Registrations++data Trace+ = RegistrationSuccess DNS.ResourceRecord+ | RegistrationFailed RegistrationFailedReason+ deriving (Show)++data Counters+ = Counters+ { cnt_registrations :: Prometheus.Vector Text Prometheus.Counter+ , cnt_records :: Prometheus.Gauge+ }++initCounters :: IO Counters+initCounters =+ Counters+ <$> Prometheus.register+ ( Prometheus.vector+ ("status")+ (Prometheus.counter (Prometheus.Info "dyn_registrations" "number of DNS registrations"))+ )+ <*> Prometheus.register+ (Prometheus.gauge (Prometheus.Info "dyn_records" "number of DNS records"))++type SharedSecret = ByteString++data Runtime = Runtime+ { dnsApex :: Apex+ , sharedHmacSecret :: SharedSecret+ , counters :: Counters+ , rrs :: IORef [DNS.ResourceRecord]+ , tracer :: Tracer IO Trace+ , background :: BackgroundVal ()+ }++initRuntime :: Tracer IO Trace -> SharedSecret -> Apex -> IO Runtime+initRuntime tracer secret apex = do+ counters <- initCounters+ rrs <- newIORef []+ let updateCounters = Prometheus.setGauge (cnt_records counters) . fromIntegral . length =<< readIORef rrs+ bkg <- backgroundLoop Tracer.silent () updateCounters 5000000+ pure $ Runtime apex secret counters rrs tracer bkg++readRRs :: Runtime -> IO [DNS.ResourceRecord]+readRRs = readIORef . rrs++addRRa :: ActionAuthorized -> Runtime -> Apex -> DNSLeafName -> IP.IP -> IO DNS.ResourceRecord+addRRa _ rt apex leaf val = do+ atomicModifyIORef' (rrs rt) (\xs -> (insertRR newRecord xs, ()))+ pure newRecord+ where+ fqdn :: ByteString+ fqdn = mconcat [Text.encodeUtf8 leaf, ".", getApex apex]++ newRecord :: DNS.ResourceRecord+ newRecord = case val of+ IP.IPv4 val -> DNS.ResourceRecord fqdn DNS.A DNS.classIN 300 $ DNS.RD_A val+ IP.IPv6 val -> DNS.ResourceRecord fqdn DNS.AAAA DNS.classIN 300 $ DNS.RD_AAAA val++insertRR :: DNS.ResourceRecord -> [DNS.ResourceRecord] -> [DNS.ResourceRecord]+insertRR x xs = x : List.filter (otherFqdn x) xs++otherFqdn :: DNS.ResourceRecord -> DNS.ResourceRecord -> Bool+otherFqdn+ (DNS.ResourceRecord qdn2 _ _ _ _)+ (DNS.ResourceRecord qdn1 _ _ _ _) = qdn1 /= qdn2++addText :: ActionAuthorized -> Runtime -> Apex -> DNSLeafName -> Text -> IO DNS.ResourceRecord+addText _ rt apex leaf val = do+ atomicModifyIORef' (rrs rt) (\xs -> (insertRR newRecord xs, ()))+ pure newRecord+ where+ fqdn :: ByteString+ fqdn = mconcat [Text.encodeUtf8 leaf, ".", getApex apex]++ newRecord :: DNS.ResourceRecord+ newRecord =+ DNS.ResourceRecord fqdn DNS.TXT DNS.classIN 300 $ DNS.RD_TXT $ Text.encodeUtf8 val++handleDynamicRegistration :: Runtime -> Server Api+handleDynamicRegistration runtime =+ handleAutoRegister runtime+ :<|> handleTextRegister runtime+ :<|> handleARegister runtime+ :<|> handleAAAARegister runtime+ :<|> handleListRegistrations runtime++handleAutoRegister :: Runtime -> DNSLeafName -> Maybe Text -> SockAddr -> Maybe Text -> Maybe ChallengeAttempt -> Handler AutoRegistrationResult+handleAutoRegister rt _ _ _ (Just _) _ = do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed ProxiedError+ throwError err400+handleAutoRegister rt _ _ _ _ Nothing = do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed AuthError+ throwError err403+handleAutoRegister rt dnsleaf apex sockaddr Nothing (Just hmac) = do+ let hashedpart = (apex, dnsleaf)+ let auth = verifyHmac rt hashedpart hmac+ let ipport = IP.fromSockAddr sockaddr+ case auth of+ Nothing -> do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "auth-error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed AuthError+ throwError err403+ Just success -> do+ case ipport of+ Nothing -> do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed IPLookupError+ throwError err500+ Just (ip, _) -> liftIO $ do+ rr <- addRRa success rt (maybe (dnsApex rt) apexFromText apex) dnsleaf ip+ runTracer (tracer rt) $ RegistrationSuccess rr+ Prometheus.withLabel (cnt_registrations $ counters rt) "success" Prometheus.incCounter+ pure $ AutoRegistrationResult dnsleaf (Text.pack $ show ip)++handleTextRegister :: Runtime -> DNSLeafName -> Text -> Maybe Text -> Maybe ChallengeAttempt -> Handler (DNSLeafName, Text)+handleTextRegister rt _ _ _ Nothing = do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "auth-error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed AuthError+ throwError err403+handleTextRegister rt dnsleaf textval apex (Just hmac) = do+ let hashedpart = (apex, dnsleaf)+ let auth = verifyHmac rt hashedpart hmac+ case auth of+ Nothing -> do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "auth-error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed AuthError+ throwError err403+ Just success -> liftIO $ do+ rr <- addText success rt (maybe (dnsApex rt) apexFromText apex) dnsleaf textval+ runTracer (tracer rt) $ RegistrationSuccess rr+ pure (dnsleaf, textval)++handleARegister :: Runtime -> DNSLeafName -> Text -> Maybe Text -> Maybe ChallengeAttempt -> Handler (DNSLeafName, Text)+handleARegister rt _ _ _ Nothing = do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "auth-error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed AuthError+ throwError err403+handleARegister rt dnsleaf textval apex (Just hmac) = do+ let hashedpart = (apex, dnsleaf)+ let auth = verifyHmac rt hashedpart hmac+ case auth of+ Nothing -> do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "auth-error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed AuthError+ throwError err403+ Just success -> do+ let ipv4 = IPv4.decode textval+ case ipv4 of+ Nothing -> do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed IPParsingError+ throwError err400+ Just ip -> liftIO $ do+ rr <- addRRa success rt (maybe (dnsApex rt) apexFromText apex) dnsleaf (IP.IPv4 $ IP.fromHostAddress $ IPv4.getIPv4 ip)+ runTracer (tracer rt) $ RegistrationSuccess rr+ pure (dnsleaf, textval)++handleAAAARegister :: Runtime -> DNSLeafName -> Text -> Maybe Text -> Maybe ChallengeAttempt -> Handler (DNSLeafName, Text)+handleAAAARegister rt _ _ _ Nothing = do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "auth-error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed AuthError+ throwError err403+handleAAAARegister rt dnsleaf textval apex (Just hmac) = do+ let hashedpart = (apex, dnsleaf)+ let auth = verifyHmac rt hashedpart hmac+ case auth of+ Nothing -> do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "auth-error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed AuthError+ throwError err403+ Just success -> do+ let ipv6 = IPv6.decode textval+ case ipv6 of+ Nothing -> do+ liftIO $ do+ Prometheus.withLabel (cnt_registrations $ counters rt) "error" Prometheus.incCounter+ runTracer (tracer rt) $ RegistrationFailed IPParsingError+ throwError err400+ Just ip -> liftIO $ do+ rr <- addRRa success rt (maybe (dnsApex rt) apexFromText apex) dnsleaf (IP.IPv6 $ IP.fromHostAddress6 $ IPv6.toWord32s ip)+ runTracer (tracer rt) $ RegistrationSuccess rr+ pure (dnsleaf, textval)++handleListRegistrations :: Runtime -> Maybe ChallengeAttempt -> Handler Registrations+handleListRegistrations rt _ = do+ rrs <- liftIO $ readRRs rt+ pure $ Registrations $ map show rrs++-- (apex?, txt)+type HashedPart = (Maybe Text, Text)++data ActionAuthorized = ActionAuthorized++verifyHmac :: Runtime -> HashedPart -> ChallengeAttempt -> Maybe ActionAuthorized+verifyHmac rt (apex, txt) attempt =+ if attempt == expected+ then Just ActionAuthorized+ else Nothing+ where+ hashedStr :: ByteString+ hashedStr = mconcat [maybe "" Text.encodeUtf8 apex, Text.encodeUtf8 txt]+ hmac = HMAC256.hmac (sharedHmacSecret rt) hashedStr+ expected = Text.decodeUtf8 $ Base16.encode $ hmac
+ src/MicroDNS/Handler.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}++module MicroDNS.Handler where++import Control.Monad (forever, void)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import Data.Coerce (coerce)+import Data.Streaming.Network (bindPortUDP)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Network.DNS as DNS+import Network.Socket (SockAddr, Socket)+import Prod.Tracer+import qualified Prometheus as Prometheus++import MicroDNS.DAI+import MicroDNS.Runtime++newtype Apex = Apex {getApex :: ByteString}+ deriving (Show, Eq, Ord)++endsWithDot :: ByteString -> Bool+endsWithDot bs =+ ByteString.takeEnd 1 bs == "."++apexify :: ByteString -> Apex+apexify bs+ | endsWithDot bs = Apex bs+ | otherwise = Apex (bs <> ".")++apexFromText :: Text -> Apex+apexFromText = apexify . Text.encodeUtf8++type QuestionLookup m = DNS.Question -> m [DNS.ResourceRecord]++ioLookup :: (Applicative m) => m [DNS.ResourceRecord] -> QuestionLookup m+ioLookup records q =+ lookupRecord <$> records <*> pure q++lookupRecord :: [DNS.ResourceRecord] -> DNS.Question -> [DNS.ResourceRecord]+lookupRecord records DNS.Question{DNS.qname = qname, DNS.qtype = qtype} =+ let+ exacts = filter matchExact records+ cnamed = filter matchCName records+ recursedOnce = filter (matchCNameRecursion cnamed) records+ in+ exacts <> cnamed <> recursedOnce+ where+ qname' = downcase qname++ matchExact (DNS.ResourceRecord name_ qtyp_ _ _ _) =+ qtyp_ == qtype && downcase name_ == qname'++ matchCName (DNS.ResourceRecord name_ qtyp_ _ _ _) =+ qtyp_ == DNS.CNAME && downcase name_ == qname'++ matchCNameRecursion :: [DNS.ResourceRecord] -> DNS.ResourceRecord -> Bool+ matchCNameRecursion cnames (DNS.ResourceRecord name_ qtyp_ _ _ _) =+ qtyp_ == qtype && any (matchCNameRecord (downcase name_)) cnames++ matchCNameRecord recordName (DNS.ResourceRecord _ _ _ _ (DNS.RD_CNAME cnamedName)) = downcase cnamedName == recordName+ matchCNameRecord _ _ = False++ downcase x = Text.toLower $ Text.decodeUtf8 x -- todo: better for dns++pureLookup :: (Applicative m) => [DNS.ResourceRecord] -> QuestionLookup m+pureLookup records = ioLookup (pure records)++handleQuestion :: Runtime -> QuestionLookup IO -> Handler+handleQuestion rt lookup (Request _ DNS.DNSMessage{DNS.header = hdr, DNS.question = q}) = \respond -> do+ Prometheus.incCounter $ cnt_messages $ counters rt+ rrs <- traverse countingLookup q+ Prometheus.incCounter $ cnt_responses $ counters rt+ Prometheus.addCounter (cnt_rrs $ counters rt) (fromIntegral $ length rrs)+ respond $ respondRRs $ concat rrs+ where+ countingLookup :: QuestionLookup IO+ countingLookup q = do+ let fqdn = Text.decodeUtf8 $ DNS.qname q+ let qtype = Text.pack $ show $ DNS.qtype q+ Prometheus.withLabel (cnt_questions $ counters rt) (fqdn, qtype) Prometheus.incCounter+ lookup q+ respondRRs :: [DNS.ResourceRecord] -> Response+ respondRRs rrs =+ RespondMessage $+ DNS.defaultResponse+ { DNS.header = (DNS.header DNS.defaultResponse){DNS.identifier = DNS.identifier hdr}+ , DNS.question = q+ , DNS.answer = rrs+ }
+ src/MicroDNS/MicroZone.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module MicroDNS.MicroZone (+ ZoneFile (..),+ Directive (..),++ -- * parsing+ zoneFile,++ -- * exploitation+ collectDirectives,+) where++import qualified Data.ByteString as ByteString+import Data.CaseInsensitive as CI+import Data.IP (IPv4, IPv6)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Void (Void)+import Data.Word (Word16)+import qualified Network.DNS as DNS+import Text.Megaparsec+import Text.Megaparsec.Char (alphaNumChar, digitChar, hexDigitChar, newline, space, string)++import MicroDNS.Handler (Apex (..), apexFromText, apexify, endsWithDot)++data ZoneFile+ = ZoneFile+ { directives :: [Directive]+ }+ deriving (Show)++type CommentedText = Text++data GuardedCommand+ = SetApex Text+ deriving (Show)++data Directive+ = Comment CommentedText+ | Command GuardedCommand+ | Record DNS.ResourceRecord+ deriving (Show)++type Parser = Parsec Void Text++zoneFile :: Parser ZoneFile+zoneFile =+ ZoneFile <$> (directive `sepEndBy` skipSome newline) <* eof++directive :: Parser Directive+directive =+ choice+ [ (Comment <$> comment)+ , (Command <$> command)+ , (Record <$> record)+ ]++comment :: Parser CommentedText+comment = string "--" *> space *> takeWhile1P Nothing ((/=) '\n')++command :: Parser GuardedCommand+command =+ choice+ [ SetApex <$> apex+ ]+ where+ apex = string "microdns:apex" *> space *> domainName++record :: Parser DNS.ResourceRecord+record =+ choice+ [ txtRecord+ , -- aaaa first to avoid a valid 'a' prefix parse+ aaaaRecord+ , aRecord+ , caaRecord+ , cnameRecord+ , mxRecord+ , srvRecord+ ]++txtRecord :: Parser DNS.ResourceRecord+txtRecord = do+ _ <- string "TXT"+ _ <- space+ !domain <- Text.encodeUtf8 <$> apexOrDomainName+ _ <- space+ !val <- Text.encodeUtf8 <$> quotedString+ pure $ DNS.ResourceRecord domain DNS.TXT DNS.classIN 300 $ DNS.RD_TXT val++aRecord :: Parser DNS.ResourceRecord+aRecord = do+ _ <- string "A"+ _ <- space+ !domain <- Text.encodeUtf8 <$> apexOrDomainName+ _ <- space+ !val <- ipv4+ pure $ DNS.ResourceRecord domain DNS.A DNS.classIN 300 $ DNS.RD_A val++aaaaRecord :: Parser DNS.ResourceRecord+aaaaRecord = do+ _ <- string "AAAA"+ _ <- space+ !domain <- Text.encodeUtf8 <$> apexOrDomainName+ _ <- space+ !val <- ipv6+ pure $ DNS.ResourceRecord domain DNS.AAAA DNS.classIN 300 $ DNS.RD_AAAA val++caaRecord :: Parser DNS.ResourceRecord+caaRecord = do+ _ <- string "CAA"+ _ <- space+ !domain <- Text.encodeUtf8 <$> apexOrDomainName+ _ <- space+ !key <- CI.mk . Text.encodeUtf8 <$> quotedString+ _ <- space+ !val <- Text.encodeUtf8 <$> quotedString+ pure $ DNS.ResourceRecord domain DNS.CAA DNS.classIN 300 $ DNS.RD_CAA 0 key val++cnameRecord :: Parser DNS.ResourceRecord+cnameRecord = do+ _ <- string "CNAME"+ _ <- space+ !domain <- Text.encodeUtf8 <$> apexOrDomainName+ _ <- space+ !val <- Text.encodeUtf8 <$> domainName+ pure $ DNS.ResourceRecord domain DNS.CNAME DNS.classIN 300 $ DNS.RD_CNAME val++mxRecord :: Parser DNS.ResourceRecord+mxRecord = do+ _ <- string "MX"+ _ <- space+ !domain <- Text.encodeUtf8 <$> apexOrDomainName+ _ <- space+ !priority <- mxPriority+ _ <- space+ !val <- Text.encodeUtf8 <$> domainName+ pure $ DNS.ResourceRecord domain DNS.MX DNS.classIN 300 $ DNS.RD_MX priority val++srvRecord :: Parser DNS.ResourceRecord+srvRecord = do+ _ <- string "SRV"+ _ <- space+ !domain <- Text.encodeUtf8 <$> apexOrDomainName+ _ <- space+ !priority <- srvPriority+ _ <- space+ !port <- srvPortnum+ _ <- space+ !val <- Text.encodeUtf8 <$> domainName+ pure $ DNS.ResourceRecord domain DNS.SRV DNS.classIN 300 $ DNS.RD_SRV priority 1 port val++apexOrDomainName :: Parser Text+apexOrDomainName =+ (string "@" *> pure "") <|> domainName++domainName :: Parser Text+domainName =+ Text.pack+ <$> many (alphaNumChar <|> oneOf ['.', '-', '_'])++quotedString :: Parser Text+quotedString =+ Text.pack+ <$> between (string "\"") (string "\"") contents+ where+ contents :: Parser [Char]+ contents = many (escapedChar <|> plainChar)++ escapedChar :: Parser Char+ escapedChar = backspace <|> quote++ backspace :: Parser Char+ backspace = string "\\\\" *> pure '\\'++ quote :: Parser Char+ quote = string "\\\"" *> pure '"'++ plainChar :: Parser Char+ plainChar = noneOf ['\\', '"']++ipv4 :: Parser IPv4+ipv4 = read <$> many (digitChar <|> oneOf ['.'])++ipv6 :: Parser IPv6+ipv6 = read <$> many (hexDigitChar <|> oneOf [':', '.'])++mxPriority, srvPriority, srvPortnum :: Parser Word16+mxPriority = read <$> many (digitChar)+srvPriority = read <$> many (digitChar)+srvPortnum = read <$> many (digitChar)++collectDirectives :: Apex -> ZoneFile -> [DNS.ResourceRecord]+collectDirectives defaultApex zones =+ go defaultApex [] (directives zones)+ where+ go :: Apex -> [DNS.ResourceRecord] -> [Directive] -> [DNS.ResourceRecord]+ go _ xs [] = xs+ go a xs ((Comment _) : ds) = go a xs ds+ go _ xs ((Command (SetApex a)) : ds) = go (apexFromText a) xs ds+ go a xs ((Record rec) : ds) = go a (adapt a rec : xs) ds++ adapt :: Apex -> DNS.ResourceRecord -> DNS.ResourceRecord+ adapt apex rr+ | matchSuffix apex rr = rr+ | otherwise = rr{DNS.rrname = addApex apex (DNS.rrname rr)}++ addApex :: Apex -> ByteString.ByteString -> ByteString.ByteString+ addApex apex "" = getApex apex+ addApex apex bs = if endsWithDot bs then mconcat [bs, getApex apex] else mconcat [bs, ".", getApex apex]++ matchSuffix :: Apex -> DNS.ResourceRecord -> Bool+ matchSuffix apex rr = getApex apex `ByteString.isSuffixOf` getApex (apexify $ DNS.rrname rr)
+ src/MicroDNS/Runtime.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++module MicroDNS.Runtime where++import Control.Monad (forever, void)+import Data.ByteString (ByteString)+import Data.Coerce (coerce)+import Data.Streaming.Network (bindPortUDP)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Network.DNS as DNS+import Network.Socket (SockAddr, Socket)+import Network.Socket.ByteString (recvFrom, sendTo)+import Prod.Tracer+import qualified Prometheus as Prometheus++import MicroDNS.DAI++data Trace+ = ParsingError DNS.DNSError+ | HandlingRequest Request+ | RequestHandled Request Response+ deriving (Show)++data Counters+ = Counters+ { cnt_packets :: Prometheus.Counter+ , cnt_messages :: Prometheus.Counter+ , cnt_questions :: Prometheus.Vector (Text, Text) Prometheus.Counter+ , cnt_responses :: Prometheus.Counter+ , cnt_ignores :: Prometheus.Counter+ , cnt_rrs :: Prometheus.Counter+ }++initCounters :: IO Counters+initCounters =+ Counters+ <$> Prometheus.register+ (Prometheus.counter (Prometheus.Info "udp_packets" "number of UDP packets"))+ <*> Prometheus.register+ (Prometheus.counter (Prometheus.Info "dns_messages" "number of DNS messages"))+ <*> Prometheus.register+ ( Prometheus.vector+ ("fqdn", "type")+ (Prometheus.counter (Prometheus.Info "dns_questions" "number of DNS questions"))+ )+ <*> Prometheus.register+ (Prometheus.counter (Prometheus.Info "dns_responses" "number of DNS responses"))+ <*> Prometheus.register+ (Prometheus.counter (Prometheus.Info "dns_ignores" "number of DNS requests ignored"))+ <*> Prometheus.register+ (Prometheus.counter (Prometheus.Info "dns_rrs" "number of DNS RRs"))++data Runtime = Runtime+ { dnsSocket :: Socket+ , tracer :: Tracer IO Trace+ , counters :: Counters+ }++initRuntime :: Int -> Tracer IO Trace -> IO Runtime+initRuntime portnum tracer =+ Runtime+ <$> bindPortUDP (coerce portnum) "*4"+ <*> pure tracer+ <*> initCounters
+ src/MicroDNS/Server.hs view
@@ -0,0 +1,41 @@+module MicroDNS.Server where++import Control.Monad (forever, void)+import Data.ByteString (ByteString)+import qualified Network.DNS as DNS+import Network.Socket (SockAddr, Socket)+import Network.Socket.ByteString (recvFrom, sendTo)+import Prod.Tracer (runTracer)+import qualified Prometheus as Prometheus++import MicroDNS.DAI+import MicroDNS.Runtime++serve :: Runtime -> Handler -> IO ()+serve rt@Runtime{dnsSocket = skt} handler = do+ forever $ do+ (bs, addr) <- recvFrom skt (fromIntegral DNS.maxUdpSize)+ Prometheus.incCounter $ cnt_packets $ counters rt+ case parseDNS bs of+ Left err -> parsingError err+ Right q -> do+ let req = Request addr q+ runTracer (tracer rt) $ HandlingRequest req+ handler req (reply req)+ where+ reply :: Request -> Response -> IO ()+ reply req rsp = do+ runTracer (tracer rt) $ RequestHandled req rsp+ case rsp of+ (RespondMessage resp) -> void $ sendTo skt (DNS.encode resp) (requestAddr req)+ Ignore _ -> pure ()++ parsingError :: DNS.DNSError -> IO ()+ parsingError = runTracer (tracer rt) . ParsingError++ parseDNS :: ByteString -> Either DNS.DNSError DNS.DNSMessage+ parseDNS bs = do+ q <- DNS.decode bs+ if DNS.qOrR (DNS.flags (DNS.header q)) == DNS.QR_Query+ then return q+ else Left DNS.FormatError