import Network.DNS.Message
import Network.DNS.Named
import Network.DNS.Named.Config
+import Network.DNS.Named.Zone
import Network.Socket
main :: IO ()
, SOAFields(..)
, WKSFields(..)
- , SomeQ
- , SomeRR
+ , SomeQ(..)
+ , SomeRR(..)
, A(..)
, NS(..)
wrapQuestion = SomeQ
wrapRecord :: (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt -> SomeRR
-wrapRecord = SomeRR
\ No newline at end of file
+wrapRecord = SomeRR
module Network.DNS.Named
- ( ZoneFinder(..)
- , Zone(..)
-
- , runNamed
-
- , defaultRootZone
+ ( runNamed
)
where
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 $
= 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 {
, hdIsAuthoritativeAnswer = False
, hdIsTruncated = False
, hdIsRecursionAvailable = False
- , hdResponseCode = ServerFailure
+ , hdResponseCode = err
}
}
in
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
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
projects / haskell-dns.git / commitdiff