, cnfAllowTransfer = True
}
- zones :: DomainMap Zone
+ zones :: DomainMap SomeZone
zones = fromZones
- [ Zone {
- zoneName = "cielonegro.org."
- , zoneSOA = Just SOAFields {
- soaMasterNameServer = "ns.cielonegro.org."
- , soaResponsibleMailbox = "root.ns.cielonegro.org."
- , soaSerialNumber = 2008022148
- , soaRefreshInterval = 3600
- , soaRetryInterval = 900
- , soaExpirationLimit = 3600000
- , soaMinimumTTL = 3600
- }
- , zoneRecordNames = return [ "ns.cielonegro.org."
- , "www.cielonegro.org."
- , "git.cielonegro.org."
+ [ wrapZone StaticZone {
+ szName = "cielonegro.org."
+ , szRecords = fromRecords
+ [ wrapRecord ResourceRecord {
+ rrName = "cielonegro.org."
+ , rrType = SOA
+ , rrClass = IN
+ , rrTTL = 3600
+ , rrData = SOAFields {
+ soaMasterNameServer = "ns.cielonegro.org."
+ , soaResponsibleMailbox = "root.ns.cielonegro.org."
+ , soaSerialNumber = 2008022148
+ , soaRefreshInterval = 3600
+ , soaRetryInterval = 900
+ , soaExpirationLimit = 3600000
+ , soaMinimumTTL = 3600
+ }
+ }
+ , wrapRecord ResourceRecord {
+ rrName = "cielonegro.org."
+ , rrType = NS
+ , rrClass = IN
+ , rrTTL = 3600
+ , rrData = "ns.cielonegro.org."
+ }
+ , wrapRecord ResourceRecord {
+ rrName = "ns.cielonegro.org."
+ , rrType = A
+ , rrClass = IN
+ , rrTTL = 9600
+ , rrData = "127.0.0.1"
+ }
+ , wrapRecord ResourceRecord {
+ rrName = "ns.cielonegro.org."
+ , rrType = AAAA
+ , rrClass = IN
+ , rrTTL = 9600
+ , rrData = "::1"
+ }
+ , wrapRecord ResourceRecord {
+ rrName = "www.cielonegro.org."
+ , rrType = A
+ , rrClass = IN
+ , rrTTL = 9600
+ , rrData = "127.0.0.2"
+ }
+ , wrapRecord ResourceRecord {
+ rrName = "www.cielonegro.org."
+ , rrType = AAAA
+ , rrClass = IN
+ , rrTTL = 9600
+ , rrData = "fe80::216:cbff:fe39:56a4"
+ }
+ , wrapRecord ResourceRecord {
+ rrName = "git.cielonegro.org."
+ , rrType = CNAME
+ , rrClass = IN
+ , rrTTL = 9600
+ , rrData = "www.cielonegro.org."
+ }
]
- , zoneResponder = return . responder
- }
+ }
]
-
- responder :: DomainName -> [SomeRR]
- responder name
- | name == "ns.cielonegro.org."
- = [ wrapRecord ResourceRecord {
- rrName = name
- , rrType = A
- , rrClass = IN
- , rrTTL = 9600
- , rrData = "127.0.0.1"
- }
- , wrapRecord ResourceRecord {
- rrName = name
- , rrType = AAAA
- , rrClass = IN
- , rrTTL = 9600
- , rrData = "::1"
- }
- ]
- | name == "www.cielonegro.org."
- = [ wrapRecord ResourceRecord {
- rrName = name
- , rrType = A
- , rrClass = IN
- , rrTTL = 9600
- , rrData = "127.0.0.2"
- }
- , wrapRecord ResourceRecord {
- rrName = name
- , rrType = AAAA
- , rrClass = IN
- , rrTTL = 9600
- , rrData = "fe80::216:cbff:fe39:56a4"
- }
- ]
- | name == "git.cielonegro.org."
- = [ wrapRecord ResourceRecord {
- rrName = name
- , rrType = CNAME
- , rrClass = IN
- , rrTTL = 9600
- , rrData = "www.cielonegro.org."
- }
- ]
- | otherwise
- = [] -- This means NXDOMAIN.
-
-> return $ do unauthorise
setResponseCode Refused
Just zone
- -> handleQuestionForZone (SomeQ q) zone
+ -> handleQuestionForZone q zone
- handleQuestionForZone :: SomeQ -> Zone -> IO (Builder ())
- handleQuestionForZone (SomeQ q) zone
+ handleQuestionForZone :: (Zone z, QueryType qt, QueryClass qc) => Question qt qc -> z -> IO (Builder ())
+ handleQuestionForZone q zone
| Just (qType q) == cast AXFR
- = handleAXFR (SomeQ q) zone
+ = handleAXFR 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 ()
-
+ = do answers <- getRecords zone q
+ authority <- getRecords zone (Question (zoneName zone) NS IN)
+ additionals <- liftM concat $ mapM (getAdditionals zone) (answers ++ authority)
+ isAuth <- isAuthoritativeZone zone
+ return $ do mapM_ addAnswer answers
+ mapM_ addAuthority authority
mapM_ addAdditional additionals
+ unless isAuth unauthorise
- case zoneNSRecord zone of
- Just rr -> addAuthority rr
- Nothing -> unauthorise
-
- getAdditionals :: Zone -> SomeRR -> IO [SomeRR]
+ getAdditionals :: Zone z => z -> SomeRR -> IO [SomeRR]
getAdditionals zone (SomeRR rr)
= case cast (rrData rr) :: Maybe DomainName of
Nothing
-> return []
Just name
- -> do allRecords <- zoneResponder zone name
-
- let rA = filterRecords (SomeQ qA) allRecords
- rB = filterRecords (SomeQ qB) allRecords
- qA = Question {
- qName = name
- , qType = A
- , qClass = IN
- }
- qB = Question {
- qName = name
- , qType = AAAA
- , qClass = IN
- }
- return (rA ++ rB)
-
- filterRecords :: SomeQ -> [SomeRR] -> [SomeRR]
- filterRecords (SomeQ q) = filter predicate
- where
- predicate rr
- = predForType rr && predForClass rr
-
- predForType (SomeRR rr)
- | typeOf (qType q) == typeOf ANY
- = True
-
- | typeOf (qType q) == typeOf MAILB
- = typeOf (rrType rr) == typeOf MR ||
- typeOf (rrType rr) == typeOf MB ||
- typeOf (rrType rr) == typeOf MG ||
- typeOf (rrType rr) == typeOf MINFO
-
- | otherwise
- = typeOf (rrType rr) == typeOf (qType q) ||
- typeOf (rrType rr) == typeOf CNAME
-
- predForClass (SomeRR rr)
- | typeOf (qClass q) == typeOf ANY
- = True
-
- | otherwise
- = typeOf (rrClass rr) == typeOf (qClass q)
-
- handleAXFR :: SomeQ -> Zone -> IO (Builder ())
- handleAXFR (SomeQ q) zone
- | qName q == zoneName zone &&
- isJust (zoneSOA zone) &&
- cnfAllowTransfer cnf
- = do names <- zoneRecordNames zone
- allRecords <- liftM concat $ mapM (zoneResponder zone) names
- return $ do addAnswer $ fromJust $ zoneSOARecord zone
- addAnswer $ fromJust $ zoneNSRecord zone
- mapM_ addAnswer allRecords
- addAnswerNonuniquely $ fromJust $ zoneSOARecord zone
+ -> do rrA <- getRecords zone (Question name A IN)
+ rrAAAA <- getRecords zone (Question name AAAA IN)
+ return (rrA ++ rrAAAA)
+
+ handleAXFR :: (Zone z, QueryType qt, QueryClass qc) => Question qt qc -> z -> IO (Builder ())
+ handleAXFR q zone
+ | cnfAllowTransfer cnf
+ = do rs <- getRecords zone q
+ return $ mapM_ addAnswerNonuniquely rs
| otherwise
= return $ return ()
( ZoneFinder(..)
, fromZones
- , Zone(..)
+ , Zone(zoneName)
+ , SomeZone(..)
+ , ExternalZone(..)
+ , FunctionalZone(..)
+ , StaticZone(..)
+ , fromRecords
, isInZone
+ , wrapZone
- , zoneSOARecord
- , zoneNSRecord
+ , isAuthoritativeZone
+ , getRecords
)
where
-import Data.Maybe
-import Network.DNS.Message
-import Network.DNS.DomainMap
+import Control.Monad
+import Data.List
+import qualified Data.Map as M
+import Data.Map (Map)
+import Data.Maybe
+import Data.Typeable
+import Network.DNS.Message
+import Network.DNS.DomainMap
class ZoneFinder a where
- findZone :: a -> DomainName -> IO (Maybe Zone)
+ findZone :: a -> DomainName -> IO (Maybe SomeZone)
-instance ZoneFinder (DomainMap Zone) where
+instance ZoneFinder (DomainMap SomeZone) where
findZone = (return .) . flip nearest
-instance ZoneFinder (IO (DomainMap Zone)) where
+instance ZoneFinder (IO (DomainMap SomeZone)) where
findZone = flip (fmap . nearest)
-instance ZoneFinder (DomainName -> Maybe Zone) where
+instance ZoneFinder (DomainMap (IO SomeZone)) where
+ findZone m n
+ = do let getZoneM = nearest n m
+ case getZoneM of
+ Just getZone -> liftM Just getZone
+ Nothing -> return Nothing
+
+instance ZoneFinder (DomainName -> Maybe SomeZone) where
findZone = (return .)
-instance ZoneFinder (DomainName -> IO (Maybe Zone)) where
+instance ZoneFinder (DomainName -> IO (Maybe SomeZone)) where
findZone = id
-fromZones :: [Zone] -> DomainMap Zone
+fromZones :: [SomeZone] -> DomainMap SomeZone
fromZones = fromList . map toPair
where
toPair z = (zoneName z, z)
-data Zone
- = Zone {
- zoneName :: !DomainName
- , zoneSOA :: !(Maybe SOAFields)
- , zoneRecordNames :: !(IO [DomainName])
- , zoneResponder :: !(DomainName -> IO [SomeRR])
+class Zone a where
+ zoneName :: a -> DomainName
+ getRecordNames :: a -> IO [DomainName]
+ getRecordsForName :: a -> DomainName -> IO [SomeRR]
+
+
+data SomeZone = forall a. Zone a => SomeZone a
+
+instance Zone SomeZone where
+ zoneName (SomeZone a) = zoneName a
+ getRecordNames (SomeZone a) = getRecordNames a
+ getRecordsForName (SomeZone a) = getRecordsForName a
+
+
+data ExternalZone
+ = ExternalZone {
+ ezName :: !DomainName
+ , ezRecordNames :: !(IO [DomainName])
+ , ezRecordsForName :: !(DomainName -> IO [SomeRR])
+ }
+instance Zone ExternalZone where
+ zoneName = ezName
+ getRecordNames = ezRecordNames
+ getRecordsForName = ezRecordsForName
+
+
+data FunctionalZone
+ = FunctionalZone {
+ fzName :: !DomainName
+ , fzRecordNames :: ![DomainName]
+ , fzRecordsForName :: !(DomainName -> [SomeRR])
+ }
+instance Zone FunctionalZone where
+ zoneName = fzName
+ getRecordNames = return . fzRecordNames
+ getRecordsForName = (return .) . fzRecordsForName
+
+
+data StaticZone
+ = StaticZone {
+ szName :: !DomainName
+ , szRecords :: !(Map DomainName [SomeRR])
}
+ deriving (Show, Eq)
+
+instance Zone StaticZone where
+ zoneName = szName
+ getRecordNames = return . M.keys . szRecords
+ getRecordsForName = ((return . fromMaybe []) .) . flip M.lookup . szRecords
+
+
+fromRecords :: [SomeRR] -> Map DomainName [SomeRR]
+fromRecords = foldl ins M.empty
+ where
+ ins m (SomeRR rr)
+ = case M.lookup (rrName rr) m of
+ Just l
+ -> M.insert (rrName rr) (l ++ [SomeRR rr]) m
+ Nothing
+ -> M.insert (rrName rr) [SomeRR rr] m
-isInZone :: DomainName -> Zone -> Bool
+
+isInZone :: Zone z => DomainName -> z -> Bool
isInZone name zone = zoneName zone `isZoneOf` name
-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
- }
+
+wrapZone :: Zone z => z -> SomeZone
+wrapZone = SomeZone
+
+
+isAuthoritativeZone :: Zone z => z -> IO Bool
+isAuthoritativeZone z
+ = do let q = Question {
+ qName = zoneName z
+ , qType = SOA
+ , qClass = IN -- Should we consider any classes other than the Internet?
+ }
+ rs <- getRecords z q
+ case rs of
+ [] -> return False
+ _ -> return True
+
+
+getRecords :: (QueryType qt, QueryClass qc, Zone z) =>
+ z
+ -> Question qt qc
+ -> IO [SomeRR]
+getRecords z q
+ | cast (qType q) == Just AXFR
+ = getRecordsForAXFR
+
+ | otherwise
+ = do rs <- getRecordsForName z (qName q)
+ return $ filterRecords q rs
+
+ where
+ getRecordsForAXFR
+ | qName q == zoneName z
+ = do names <- getRecordNames z
+ (soaM, rs) <- liftM (spitSOA . concat) $ mapM (getRecordsForName z) names
+ case soaM of
+ Just soa -> return ([soa] ++ rs ++ [soa])
+ Nothing -> return []
+ | otherwise
+ = return []
+
+ spitSOA :: [SomeRR] -> (Maybe SomeRR, [SomeRR])
+ spitSOA xs = (findSOA xs, collectNonSOA xs)
+
+ findSOA :: [SomeRR] -> Maybe SomeRR
+ findSOA [] = Nothing
+ findSOA (SomeRR x : xs)
+ | typeOf (rrType x) == typeOf SOA = Just (SomeRR x)
+ | otherwise = findSOA xs
+
+ collectNonSOA :: [SomeRR] -> [SomeRR]
+ collectNonSOA [] = []
+ collectNonSOA (SomeRR x : xs)
+ | typeOf (rrType x) == typeOf SOA = collectNonSOA xs
+ | otherwise = SomeRR x : collectNonSOA xs
+
+
+filterRecords :: (QueryType qt, QueryClass qc) =>
+ Question qt qc
+ -> [SomeRR]
+ -> [SomeRR]
+filterRecords q = filter predicate
+ where
+ predicate rr
+ = predForType rr && predForClass rr
+
+ predForType (SomeRR rr)
+ | typeOf (qType q) == typeOf ANY
+ = True
+
+ | typeOf (qType q) == typeOf MAILB
+ = typeOf (rrType rr) == typeOf MR ||
+ typeOf (rrType rr) == typeOf MB ||
+ typeOf (rrType rr) == typeOf MG ||
+ typeOf (rrType rr) == typeOf MINFO
+
+ | otherwise
+ = typeOf (rrType rr) == typeOf (qType q) ||
+ typeOf (rrType rr) == typeOf CNAME
+
+ predForClass (SomeRR rr)
+ | typeOf (qClass q) == typeOf ANY
+ = True
+
+ | otherwise
+ = typeOf (rrClass rr) == typeOf (qClass q)
projects / haskell-dns.git / commitdiff