From 957d3f466cea2fa642f67f477ec4ad9a0d535a9b Mon Sep 17 00:00:00 2001 From: PHO Date: Tue, 26 May 2009 14:23:32 +0900 Subject: [PATCH] Farewell to the Sanity.hs --- ExampleDNSServer.hs | 70 +++++++++++++----- Network/DNS/Named.hs | 107 +++++++++++++++++++++------ Network/DNS/Named/Responder.hs | 96 ------------------------ Network/DNS/Named/ResponseBuilder.hs | 14 +++- Network/DNS/Named/Sanity.hs | 23 ------ Network/DNS/Named/Zone.hs | 60 ++++++++------- dns.cabal | 2 - 7 files changed, 177 insertions(+), 195 deletions(-) delete mode 100644 Network/DNS/Named/Responder.hs delete mode 100644 Network/DNS/Named/Sanity.hs diff --git a/ExampleDNSServer.hs b/ExampleDNSServer.hs index b366e14..8c99195 100644 --- a/ExampleDNSServer.hs +++ b/ExampleDNSServer.hs @@ -1,44 +1,74 @@ import Network.DNS.Message import Network.DNS.Named import Network.DNS.Named.Config -import Network.DNS.Named.Responder import Network.DNS.Named.Zone import Network.Socket import System.IO.Unsafe main :: IO () -main = runNamed cnf zoneFor +main = runNamed cnf (return . findZone) where cnf :: Config cnf = Config { cnfServerAddress = SockAddrInet 9090 iNADDR_ANY } - zoneFor :: DomainName -> Maybe Zone - zoneFor name + findZone :: DomainName -> Maybe Zone + findZone name | name `isInZone` zone = Just zone | otherwise = Nothing zone :: Zone zone = Zone { - zoneName = mkDN "cielonegro.org." - , zoneResponders = [ wrapResponder responderA - ] - , zoneIsAuthoritative = True + zoneName = mkDN "cielonegro.org." + , zoneSOA = Just SOAFields { + soaMasterNameServer = mkDN "ns.cielonegro.org." + , soaResponsibleMailbox = mkDN "root.ns.cielonegro.org." + , soaSerialNumber = 2008022148 + , soaRefreshInterval = 3600 + , soaRetryInterval = 900 + , soaExpirationLimit = 3600000 + , soaMinimumTTL = 3600 + } + , zoneRecordNames = return [ mkDN "cielonegro.org." + , mkDN "ns.cielonegro.org." + , mkDN "www.cielonegro.org." + , mkDN "git.cielonegro.org." + ] + , zoneResponder = return . responder } - responderA :: Responder A IN () - responderA = do name <- getQueryName - if name == mkDN "ns.cielonegro.org." then - respond ResourceRecord { - rrName = name - , rrType = A - , rrClass = IN - , rrTTL = 9600 - , rrData = inetAddr "127.0.0.1" - } - else - fail "FIXME: we want to throw NameError but we can't for now" + responder :: DomainName -> [SomeRR] + responder name + | name == mkDN "ns.cielonegro.org." + = [ wrapRecord ResourceRecord { + rrName = name + , rrType = A + , rrClass = IN + , rrTTL = 9600 + , rrData = inetAddr "127.0.0.1" + } + ] + | name == mkDN "www.cielonegro.org." + = [ wrapRecord ResourceRecord { + rrName = name + , rrType = A + , rrClass = IN + , rrTTL = 9600 + , rrData = inetAddr "127.0.0.2" + } + ] + | name == mkDN "git.cielonegro.org." + = [ wrapRecord ResourceRecord { + rrName = name + , rrType = CNAME + , rrClass = IN + , rrTTL = 9600 + , rrData = mkDN "www.cielonegro.org." + } + ] + | otherwise + = [] -- This means NXDOMAIN. inetAddr :: String -> HostAddress diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs index dbe8e71..1eaf27a 100644 --- a/Network/DNS/Named.hs +++ b/Network/DNS/Named.hs @@ -9,19 +9,19 @@ import Control.Monad import Data.Binary import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS +import Data.Dynamic import Data.Maybe import Network.Socket import qualified Network.Socket.ByteString as NB import Network.DNS.Message import Network.DNS.Named.Config -import Network.DNS.Named.Responder import Network.DNS.Named.ResponseBuilder import Network.DNS.Named.Zone import System.Posix.Signals -runNamed :: ZoneFinder zf => Config -> zf -> IO () -runNamed cnf zf +runNamed :: Config -> (DomainName -> IO (Maybe Zone)) -> IO () +runNamed cnf findZone = withSocketsDo $ do installHandler sigPIPE Ignore Nothing _tcpListenerTID <- forkIO $ tcpListen @@ -68,13 +68,86 @@ runNamed cnf zf handleQuestion :: SomeQ -> IO (Builder ()) handleQuestion (SomeQ q) - = do zone <- findZone zf (qName q) - -- FIXME: this is merely a bogus implementation. - -- It considers no additional or authoritative sections. - results <- mapM (runResponder' q) (zoneResponders zone) - return $ do mapM_ addAnswer $ concat results - unless (zoneIsAuthoritative zone) $ - unauthorise + = do zoneM <- findZone (qName q) + case zoneM of + Nothing + -> return $ do unauthorise + setResponseCode Refused + Just zone + -> handleQuestionForZone (SomeQ q) zone + + handleQuestionForZone :: SomeQ -> Zone -> IO (Builder ()) + handleQuestionForZone (SomeQ q) zone + | Just (qType q) == cast AXFR + = handleAXFR (SomeQ q) zone + | otherwise + = do allRecords <- zoneResponder zone (qName q) + let filtered = filterRecords (SomeQ q) allRecords + + additionals <- do xss <- mapM (getAdditionals zone) filtered + ys <- case zoneNSRecord zone of + Just rr -> getAdditionals zone rr + Nothing -> return [] + return (concat xss ++ ys) + + return $ do mapM_ addAnswer filtered + + when (qName q == zoneName zone) $ + do when (Just (qType q) == cast SOA || + Just (qType q) == cast ANY ) + $ case zoneSOARecord zone of + Just rr -> addAnswer rr + Nothing -> return () + + when (Just (qType q) == cast NS || + Just (qType q) == cast ANY ) + $ case zoneNSRecord zone of + Just rr -> addAnswer rr + Nothing -> return () + + mapM_ addAdditional additionals + + case zoneNSRecord zone of + Just rr -> addAuthority rr + Nothing -> unauthorise + + getAdditionals :: Zone -> SomeRR -> IO [SomeRR] + getAdditionals zone (SomeRR rr) + = case cast (rrData rr) :: Maybe DomainName of + Nothing + -> return [] + Just name + -> do allRecords <- zoneResponder zone name + + let filtered = filterRecords (SomeQ q') allRecords + q' = Question { + qName = name + , qType = A + , qClass = IN + } + return filtered + + filterRecords :: SomeQ -> [SomeRR] -> [SomeRR] + filterRecords (SomeQ q) + | Just (qType q) == cast ANY && + Just (qClass q) == cast ANY = id + | Just (qType q) == cast ANY = filter matchClass + | Just (qClass q) == cast ANY = filter matchType + | otherwise = filter matchBoth + where + matchClass (SomeRR rr) + = Just (qClass q) == cast (rrClass rr) + + matchType (SomeRR rr) + = Just (qType q) == cast (rrType rr) || + Just CNAME == cast (rrType rr) + + matchBoth rr + = matchType rr && matchClass rr + + handleAXFR :: SomeQ -> Zone -> IO (Builder ()) + handleAXFR (SomeQ _q) _zone + = fail "FIXME: not implemented yet" validateQuery :: Message -> ResponseCode @@ -140,15 +213,5 @@ unpackMessage = decode . LBS.fromChunks . return mkErrorReply :: ResponseCode -> Message -> Message mkErrorReply err msg - = let header = msgHeader msg - msg' = msg { - msgHeader = header { - hdMessageType = Response - , hdIsAuthoritativeAnswer = False - , hdIsTruncated = False - , hdIsRecursionAvailable = False - , hdResponseCode = err - } - } - in - msg' + = runBuilder msg $ do unauthorise + setResponseCode err diff --git a/Network/DNS/Named/Responder.hs b/Network/DNS/Named/Responder.hs deleted file mode 100644 index b94b7ca..0000000 --- a/Network/DNS/Named/Responder.hs +++ /dev/null @@ -1,96 +0,0 @@ -module Network.DNS.Named.Responder - ( Responder - , SomeResponder - - , runResponder - , runResponder' - , wrapResponder - - , getQuestion - , getQueryName - , respond - ) - where - -import Control.Monad -import Control.Monad.Trans -import Data.Typeable -import Network.DNS.Message -import Network.DNS.Named.Sanity - - -data (QueryType qt, QueryClass qc) => ResponderState qt qc - = ResponderState { - rsQuestion :: !(Question qt qc) - , rsAnswers :: ![SomeRR] - } - -newtype (QueryType qt, QueryClass qc) => Responder qt qc a - = Responder { - unR :: ResponderState qt qc -> IO (a, ResponderState qt qc) - } - deriving Typeable - -instance (QueryType qt, QueryClass qc) => Monad (Responder qt qc) where - return a = Responder $ \ s -> return (a, s) - m >>= k = Responder $ \ s -> do (a, s') <- unR m s - unR (k a) s' - fail err = Responder $ \ _ -> fail err - -instance (QueryType qt, QueryClass qc) => MonadIO (Responder qt qc) where - liftIO m = Responder $ \ s -> do a <- m - return (a, s) - - -runResponder :: (QueryType qt, QueryClass qc) => - Question qt qc - -> Responder qt qc () - -> IO [SomeRR] -runResponder q m - = do let s = ResponderState { - rsQuestion = q - , rsAnswers = [] - } - (_, s') <- unR m s - return $ rsAnswers s' - -runResponder' :: forall qt qc. - (QueryType qt, QueryClass qc) => - Question qt qc - -> SomeResponder - -> IO [SomeRR] -runResponder' q (SomeResponder r) - = case cast r :: Maybe (Responder qt qc ()) of - Nothing - -> return [] - Just m - -> runResponder q m - -getQuestion :: (QueryType qt, QueryClass qc) => Responder qt qc (Question qt qc) -getQuestion = Responder $ \ s -> - return (rsQuestion s, s) - -getQueryName :: (QueryType qt, QueryClass qc) => Responder qt qc DomainName -getQueryName = liftM qName getQuestion - -respond :: ( SaneAnswerType qt at, SaneAnswerClass qc ac - , QueryType qt, RecordType at dt - , QueryClass qc, RecordClass ac - ) => - ResourceRecord at ac dt - -> Responder qt qc () -respond rr - = Responder $ \ s -> - do let s' = s { - rsAnswers = rsAnswers s ++ [wrapRecord rr] - } - return ((), s') - -data SomeResponder - = forall qt qc. (Typeable qt, Typeable qc) => SomeResponder (Responder qt qc ()) - -wrapResponder :: (QueryType qt, QueryClass qc) => - Responder qt qc a - -> SomeResponder -wrapResponder m - = SomeResponder (m >> return ()) \ No newline at end of file diff --git a/Network/DNS/Named/ResponseBuilder.hs b/Network/DNS/Named/ResponseBuilder.hs index 487a678..4f08c40 100644 --- a/Network/DNS/Named/ResponseBuilder.hs +++ b/Network/DNS/Named/ResponseBuilder.hs @@ -4,6 +4,7 @@ module Network.DNS.Named.ResponseBuilder , runBuilder , unauthorise + , setResponseCode , addAnswer , addAuthority , addAdditional @@ -39,7 +40,14 @@ runBuilder query builder , hdIsRecursionAvailable = False , hdResponseCode = NoError } - (_, result) = unB (modHeader' >> builder) initialReply + setNameError = do aa <- get (hdIsRecursionAvailable . msgHeader) + rc <- get (hdResponseCode . msgHeader) + anss <- get msgAnswers + + when (aa && rc == NoError && null anss) + $ setResponseCode NameError + + (_, result) = unB (modHeader' >> builder >> setNameError) initialReply in result @@ -79,3 +87,7 @@ addAdditional rr unauthorise :: Builder () unauthorise = modifyHeader (\ h -> h { hdIsAuthoritativeAnswer = False }) + +setResponseCode :: ResponseCode -> Builder () +setResponseCode code + = modifyHeader (\ h -> h { hdResponseCode = code }) diff --git a/Network/DNS/Named/Sanity.hs b/Network/DNS/Named/Sanity.hs deleted file mode 100644 index 8d5c793..0000000 --- a/Network/DNS/Named/Sanity.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Network.DNS.Named.Sanity - ( SaneAnswerType - , SaneAnswerClass - ) - where - -import Network.DNS.Message - - -class SaneAnswerType q ans -instance (RecordType q dt) => SaneAnswerType q q -instance (RecordType q dt) => SaneAnswerType q CNAME -instance (RecordType ans dt) => SaneAnswerType ANY ans -instance (RecordType ans dt) => SaneAnswerType AXFR ans -instance SaneAnswerType MAILB MR -instance SaneAnswerType MAILB MB -instance SaneAnswerType MAILB MG -instance SaneAnswerType MAILB MINFO - - -class SaneAnswerClass q ans -instance RecordClass q => SaneAnswerClass q q -instance RecordClass ans => SaneAnswerClass ANY ans diff --git a/Network/DNS/Named/Zone.hs b/Network/DNS/Named/Zone.hs index 6cde400..c02ff4b 100644 --- a/Network/DNS/Named/Zone.hs +++ b/Network/DNS/Named/Zone.hs @@ -1,49 +1,47 @@ module Network.DNS.Named.Zone ( Zone(..) - , ZoneFinder(..) - , isInZone - , defaultRootZone + , zoneSOARecord + , zoneNSRecord ) where import Data.Maybe import Network.DNS.Message -import Network.DNS.Named.Responder data Zone = Zone { - zoneName :: !DomainName - , zoneResponders :: ![SomeResponder] - , zoneIsAuthoritative :: !Bool + zoneName :: !DomainName + , zoneSOA :: !(Maybe SOAFields) + , zoneRecordNames :: !(IO [DomainName]) + , zoneResponder :: !(DomainName -> IO [SomeRR]) } -class ZoneFinder a where - findZone :: a -> DomainName -> IO Zone - -instance ZoneFinder (DomainName -> Zone) where - findZone = (return .) - -instance ZoneFinder (DomainName -> IO Zone) where - findZone = id - -instance ZoneFinder (DomainName -> Maybe Zone) where - findZone = ((return . fromMaybe defaultRootZone) .) - -instance ZoneFinder (DomainName -> IO (Maybe Zone)) where - findZone = (fmap (fromMaybe defaultRootZone) .) - - isInZone :: DomainName -> Zone -> Bool isInZone name zone = zoneName zone `isZoneOf` name - -defaultRootZone :: Zone -defaultRootZone - = Zone { - zoneName = mkDomainName "." - , zoneResponders = [] -- FIXME - , zoneIsAuthoritative = False - } +zoneSOARecord :: Zone -> Maybe SomeRR +zoneSOARecord zone + = do soa <- zoneSOA zone + return $ wrapRecord + $ ResourceRecord { + rrName = zoneName zone + , rrType = SOA + , rrClass = IN + , rrTTL = soaMinimumTTL soa + , rrData = soa + } + +zoneNSRecord :: Zone -> Maybe SomeRR +zoneNSRecord zone + = do soa <- zoneSOA zone + return $ wrapRecord + $ ResourceRecord { + rrName = zoneName zone + , rrType = NS + , rrClass = IN + , rrTTL = soaMinimumTTL soa + , rrData = soaMasterNameServer soa + } diff --git a/dns.cabal b/dns.cabal index 7fc84fc..d6c194a 100644 --- a/dns.cabal +++ b/dns.cabal @@ -30,9 +30,7 @@ Library Network.DNS.Message Network.DNS.Named Network.DNS.Named.Config - Network.DNS.Named.Responder Network.DNS.Named.ResponseBuilder - Network.DNS.Named.Sanity Network.DNS.Named.Zone Network.DNS.Packer Network.DNS.Unpacker -- 2.40.0