From 7a09a987b0369db0c013fb10272329c733ffc8a1 Mon Sep 17 00:00:00 2001 From: PHO Date: Mon, 25 May 2009 14:47:16 +0900 Subject: [PATCH] Many changes... --- ExampleDNSServer.hs | 1 + Network/DNS/Message.hs | 6 +- Network/DNS/Named.hs | 116 +++++++++++++++++++++------------ Network/DNS/Named/Responder.hs | 96 +++++++++++++++++++++++++++ Network/DNS/Named/Sanity.hs | 23 +++++++ Network/DNS/Named/Zone.hs | 37 +++++++++++ dns.cabal | 7 +- 7 files changed, 241 insertions(+), 45 deletions(-) create mode 100644 Network/DNS/Named/Responder.hs create mode 100644 Network/DNS/Named/Sanity.hs create mode 100644 Network/DNS/Named/Zone.hs diff --git a/ExampleDNSServer.hs b/ExampleDNSServer.hs index 9e1b4cd..e1aaa22 100644 --- a/ExampleDNSServer.hs +++ b/ExampleDNSServer.hs @@ -1,6 +1,7 @@ import Network.DNS.Message import Network.DNS.Named import Network.DNS.Named.Config +import Network.DNS.Named.Zone import Network.Socket main :: IO () diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs index 17c037f..fe595b4 100644 --- a/Network/DNS/Message.hs +++ b/Network/DNS/Message.hs @@ -19,8 +19,8 @@ module Network.DNS.Message , SOAFields(..) , WKSFields(..) - , SomeQ - , SomeRR + , SomeQ(..) + , SomeRR(..) , A(..) , NS(..) @@ -904,4 +904,4 @@ wrapQuestion :: (QueryType qt, QueryClass qc) => Question qt qc -> SomeQ wrapQuestion = SomeQ wrapRecord :: (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt -> SomeRR -wrapRecord = SomeRR \ No newline at end of file +wrapRecord = SomeRR diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs index 13297e8..137bdd5 100644 --- a/Network/DNS/Named.hs +++ b/Network/DNS/Named.hs @@ -1,10 +1,5 @@ module Network.DNS.Named - ( ZoneFinder(..) - , Zone(..) - - , runNamed - - , defaultRootZone + ( runNamed ) where @@ -19,34 +14,11 @@ 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.Zone import System.Posix.Signals -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) .) - - -data Zone - = Zone { - zoneName :: !DomainName - } - -defaultRootZone :: Zone -defaultRootZone = error "FIXME: defaultRootZone is not implemented yet" - - runNamed :: ZoneFinder zf => Config -> zf -> IO () runNamed cnf zf = withSocketsDo $ @@ -75,24 +47,88 @@ runNamed cnf zf = do msg <- evaluate $ unpackMessage packet msg' <- handleMessage msg `onException` - NB.sendTo so (packMessage $ makeServerFailure msg) cameFrom - _sent <- NB.sendTo so (packMessage $ msg' ) cameFrom + do let servfail = mkErrorReply ServerFailure msg + NB.sendTo so (packMessage (Just 512) servfail) cameFrom + _sent <- NB.sendTo so (packMessage (Just 512) msg') cameFrom return () handleMessage :: Message -> IO Message handleMessage msg - = fail (show msg) -- FIXME + = case validateQuery msg of + NoError + -> fail "FIXME: not impl" -- msgQuestions msg + err -> return $ mkErrorReply err msg + + handleQuestion :: SomeQ -> IO [SomeRR] + handleQuestion (SomeQ q) + = do zone <- findZone zf (qName q) + results <- mapM (runResponder' q) (zoneResponders zone) + return $ concat results + + +validateQuery :: Message -> ResponseCode +validateQuery = validateHeader . msgHeader + where + validateHeader :: Header -> ResponseCode + validateHeader hdr + | hdMessageType hdr /= Query = NotImplemented + | hdOpcode hdr /= StandardQuery = NotImplemented + | otherwise = NoError -packMessage :: Message -> BS.ByteString -packMessage = BS.concat . LBS.toChunks . encode +packMessage :: Maybe Int -> Message -> BS.ByteString +packMessage limM = BS.concat . LBS.toChunks . truncateMsg + where + truncateMsg :: Message -> LBS.ByteString + truncateMsg msg + = let packet = encode msg + needTrunc = fromMaybe False $ + do lim <- limM + return $ fromIntegral (LBS.length packet) > lim + in + if needTrunc then + truncateMsg $ trunc' msg + else + packet + + trunc' :: Message -> Message + trunc' msg + | notNull $ msgAdditionals msg + = msg { + msgAdditionals = truncList $ msgAdditionals msg + } + | notNull $ msgAuthorities msg + = msg { + msgHeader = setTruncFlag $ msgHeader msg + , msgAuthorities = truncList $ msgAuthorities msg + } + | notNull $ msgAnswers msg + = msg { + msgHeader = setTruncFlag $ msgHeader msg + , msgAnswers = truncList $ msgAnswers msg + } + | notNull $ msgQuestions msg + = msg { + msgHeader = setTruncFlag $ msgHeader msg + , msgQuestions = truncList $ msgQuestions msg + } + | otherwise + = error ("packMessage: You are already skinny and need no diet: " ++ show msg) + + setTruncFlag :: Header -> Header + setTruncFlag hdr = hdr { hdIsTruncated = True } + + notNull :: [a] -> Bool + notNull = not . null + + truncList :: [a] -> [a] + truncList xs = take (length xs - 1) xs unpackMessage :: BS.ByteString -> Message unpackMessage = decode . LBS.fromChunks . return - -makeServerFailure :: Message -> Message -makeServerFailure msg +mkErrorReply :: ResponseCode -> Message -> Message +mkErrorReply err msg = let header = msgHeader msg msg' = msg { msgHeader = header { @@ -100,7 +136,7 @@ makeServerFailure msg , hdIsAuthoritativeAnswer = False , hdIsTruncated = False , hdIsRecursionAvailable = False - , hdResponseCode = ServerFailure + , hdResponseCode = err } } in diff --git a/Network/DNS/Named/Responder.hs b/Network/DNS/Named/Responder.hs new file mode 100644 index 0000000..5148f2b --- /dev/null +++ b/Network/DNS/Named/Responder.hs @@ -0,0 +1,96 @@ +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 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 (RecordType qt dt, RecordClass 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 (RecordType qt dt, RecordClass 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 :: (RecordType qt dt, RecordClass qc) => Responder qt qc (Question qt qc) +getQuestion = Responder $ \ s -> + return (rsQuestion s, s) + +getQueryName :: (RecordType qt dt, RecordClass qc) => Responder qt qc DomainName +getQueryName = liftM qName getQuestion + +respond :: ( SaneAnswerType qt at, SaneAnswerClass qc ac + , QueryType qt, RecordType at dt + , RecordClass 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 :: (RecordType qt dt, RecordClass qc) => + Responder qt qc a + -> SomeResponder +wrapResponder m + = SomeResponder (m >> return ()) \ No newline at end of file diff --git a/Network/DNS/Named/Sanity.hs b/Network/DNS/Named/Sanity.hs new file mode 100644 index 0000000..8d5c793 --- /dev/null +++ b/Network/DNS/Named/Sanity.hs @@ -0,0 +1,23 @@ +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 new file mode 100644 index 0000000..da27c3e --- /dev/null +++ b/Network/DNS/Named/Zone.hs @@ -0,0 +1,37 @@ +module Network.DNS.Named.Zone + ( Zone(..) + , ZoneFinder(..) + + , defaultRootZone + ) + where + +import Data.Maybe +import Network.DNS.Message +import Network.DNS.Named.Responder + + +data Zone + = Zone { + zoneName :: !DomainName + , zoneResponders :: ![SomeResponder] + } + +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) .) + + +defaultRootZone :: Zone +defaultRootZone = error "FIXME: defaultRootZone is not implemented yet" \ No newline at end of file diff --git a/dns.cabal b/dns.cabal index 4378fd2..e55cc17 100644 --- a/dns.cabal +++ b/dns.cabal @@ -23,13 +23,16 @@ Flag build-test-suite Library Build-Depends: - base, binary, binary-strict, bytestring, containers, network, - network-bytestring, unix + base, binary, binary-strict, bytestring, containers, mtl, + network, network-bytestring, unix Exposed-Modules: Network.DNS.Message Network.DNS.Named Network.DNS.Named.Config + Network.DNS.Named.Responder + Network.DNS.Named.Sanity + Network.DNS.Named.Zone Network.DNS.Packer Network.DNS.Unpacker -- 2.40.0