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
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
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
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
+++ /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 (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
, runBuilder
, unauthorise
+ , setResponseCode
, addAnswer
, addAuthority
, addAdditional
, 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
unauthorise :: Builder ()
unauthorise = modifyHeader (\ h -> h { hdIsAuthoritativeAnswer = False })
+
+setResponseCode :: ResponseCode -> Builder ()
+setResponseCode code
+ = modifyHeader (\ h -> h { hdResponseCode = code })
+++ /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
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
+ }
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
projects / haskell-dns.git / commitdiff