From: PHO Date: Thu, 28 May 2009 08:55:02 +0000 (+0900) Subject: Code clean up X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=e4ee321871e4ffed54d1378db5080389d76032c1;p=haskell-dns.git Code clean up --- diff --git a/ExampleDNSServer.hs b/ExampleDNSServer.hs index 1aae098..2dd9564 100644 --- a/ExampleDNSServer.hs +++ b/ExampleDNSServer.hs @@ -14,70 +14,68 @@ main = runNamed cnf zones , 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. - diff --git a/Network/DNS/Named.hs b/Network/DNS/Named.hs index 7abdcd0..3ce2a9a 100644 --- a/Network/DNS/Named.hs +++ b/Network/DNS/Named.hs @@ -124,103 +124,37 @@ runNamed cnf zf -> 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 () diff --git a/Network/DNS/Named/Zone.hs b/Network/DNS/Named/Zone.hs index f313beb..302fe66 100644 --- a/Network/DNS/Named/Zone.hs +++ b/Network/DNS/Named/Zone.hs @@ -2,72 +2,207 @@ module Network.DNS.Named.Zone ( 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)