diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for microdns + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/microdns.cabal b/microdns.cabal new file mode 100644 --- /dev/null +++ b/microdns.cabal @@ -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 diff --git a/src/MicroDNS.hs b/src/MicroDNS.hs new file mode 100644 --- /dev/null +++ b/src/MicroDNS.hs @@ -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 diff --git a/src/MicroDNS/DAI.hs b/src/MicroDNS/DAI.hs new file mode 100644 --- /dev/null +++ b/src/MicroDNS/DAI.hs @@ -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 diff --git a/src/MicroDNS/DynamicRegistration.hs b/src/MicroDNS/DynamicRegistration.hs new file mode 100644 --- /dev/null +++ b/src/MicroDNS/DynamicRegistration.hs @@ -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 diff --git a/src/MicroDNS/Handler.hs b/src/MicroDNS/Handler.hs new file mode 100644 --- /dev/null +++ b/src/MicroDNS/Handler.hs @@ -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 + } diff --git a/src/MicroDNS/MicroZone.hs b/src/MicroDNS/MicroZone.hs new file mode 100644 --- /dev/null +++ b/src/MicroDNS/MicroZone.hs @@ -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) diff --git a/src/MicroDNS/Runtime.hs b/src/MicroDNS/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/MicroDNS/Runtime.hs @@ -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 diff --git a/src/MicroDNS/Server.hs b/src/MicroDNS/Server.hs new file mode 100644 --- /dev/null +++ b/src/MicroDNS/Server.hs @@ -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