From f5e9870ed6d3307c08e583a7874d8c35e0ea6978 Mon Sep 17 00:00:00 2001 From: Eugene Crosser Date: Thu, 1 May 2014 15:02:39 +0400 Subject: [PATCH] wip move 'synthetic' parsing into NmcDom --- NmcDom.hs | 89 +++++++++++++++++++------------------------------ NmcTransform.hs | 34 +++++++++---------- PowerDns.hs | 24 +++++++++++-- 3 files changed, 73 insertions(+), 74 deletions(-) diff --git a/NmcDom.hs b/NmcDom.hs index 1ccf836..98275f7 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module NmcDom ( NmcDom(..) - , NmcRRService(..) + , NmcRRSrv(..) , NmcRRI2p(..) - , NmcRRTls(..) + , NmcRRTlsa(..) , NmcRRDs(..) - , mergeNmcDom + , merge ) where import Prelude hiding (length) @@ -34,6 +34,20 @@ obj .:/ key = case H.lookup key obj of String s -> parseJSON $ Array (singleton v) _ -> parseJSON v +makeMx :: Object -> Parser (Maybe [String]) +makeMx o = return Nothing -- FIXME +{- + case H.lookup "service" o of + Nothing -> pure Nothing + Just (Array saa) -> return $ Just $ fmap mxStr $ filter mxMatch saa + where + mxMatch sa = (sa ! 0) == "smtp" && (sa ! 1) == "tcp" && (sa ! 4) == 25 + mxStr sa = (sa ! 2) ++ "\t" ++ (sa ! 5) + _ -> empty +-} +makeSubmap :: Object -> Parser (Maybe (Map String NmcDom)) +makeSubmap o = o .:? "map" -- FIXME + class Mergeable a where merge :: a -> a -> a -- bias towads second arg @@ -56,28 +70,14 @@ instance Mergeable a => Mergeable (Maybe a) where instance Eq a => Mergeable [a] where merge xs ys = union xs ys -data NmcRRService = NmcRRService - { srvName :: String - , srvProto :: String - , srvPrio :: Int +data NmcRRSrv = NmcRRSrv + { srvPrio :: Int , srvWeight :: Int , srvPort :: Int , srvHost :: String } deriving (Show, Eq) -instance FromJSON NmcRRService where - parseJSON (Array a) = - if length a == 6 then NmcRRService - <$> parseJSON (a ! 0) - <*> parseJSON (a ! 1) - <*> parseJSON (a ! 2) - <*> parseJSON (a ! 3) - <*> parseJSON (a ! 4) - <*> parseJSON (a ! 5) - else empty - parseJSON _ = empty - -instance Mergeable NmcRRService where +instance Mergeable NmcRRSrv where merge _ b = b data NmcRRI2p = NmcRRI2p @@ -96,22 +96,13 @@ instance FromJSON NmcRRI2p where instance Mergeable NmcRRI2p where merge _ b = b -data NmcRRTls = NmcRRTls +data NmcRRTlsa = NmcRRTlsa { tlsMatchType :: Int -- 0:exact 1:sha256 2:sha512 , tlsMatchValue :: String , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no } deriving (Show, Eq) -instance FromJSON NmcRRTls where - parseJSON (Array a) = - if length a == 3 then NmcRRTls - <$> parseJSON (a ! 0) - <*> parseJSON (a ! 1) - <*> parseJSON (a ! 2) - else empty - parseJSON _ = empty - -instance Mergeable NmcRRTls where +instance Mergeable NmcRRTlsa where merge _ b = b data NmcRRDs = NmcRRDs @@ -134,8 +125,7 @@ instance FromJSON NmcRRDs where instance Mergeable NmcRRDs where merge _ b = b -data NmcDom = NmcDom { domService :: Maybe [NmcRRService] - , domIp :: Maybe [String] +data NmcDom = NmcDom { domIp :: Maybe [String] , domIp6 :: Maybe [String] , domTor :: Maybe String , domI2p :: Maybe NmcRRI2p @@ -148,20 +138,18 @@ data NmcDom = NmcDom { domService :: Maybe [NmcRRService] , domNs :: Maybe [String] , domDelegate :: Maybe String , domImport :: Maybe [String] - , domMap :: Maybe (Map String NmcDom) + , domSubmap :: Maybe (Map String NmcDom) , domFingerprint :: Maybe [String] - , domTls :: Maybe (Map String - (Map String [NmcRRTls])) , domDs :: Maybe [NmcRRDs] - , domMx :: Maybe [String] -- Synthetic - , domSrv :: Maybe [String] -- Synthetic - , domTlsa :: Maybe [String] -- Synthetic + , domMx :: Maybe [String] -- Synthetic + , domSrv :: Maybe [NmcRRSrv] -- Synthetic + , domTlsa :: Maybe [NmcRRTlsa] -- Synthetic } deriving (Show, Eq) instance Default NmcDom where def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing instance FromJSON NmcDom where -- Wherever we expect a domain object, there may be a string @@ -178,8 +166,7 @@ instance FromJSON NmcDom where if all isDigit x then (read x :: Int) < 256 else False parseJSON (Object o) = NmcDom - <$> o .:? "service" - <*> o .:/ "ip" + <$> o .:/ "ip" <*> o .:/ "ip6" <*> o .:? "tor" <*> o .:? "i2p" @@ -192,18 +179,16 @@ instance FromJSON NmcDom where <*> o .:/ "ns" <*> o .:? "delegate" <*> o .:/ "import" - <*> o .:? "map" + <*> makeSubmap o <*> o .:/ "fingerprint" - <*> o .:? "tls" <*> o .:? "ds" - <*> return Nothing -- domMx not parsed - <*> return Nothing -- domSrv not parsed - <*> return Nothing -- domTlsa not parsed + <*> makeMx o + <*> return Nothing -- domSrv created in subdomains + <*> return Nothing -- domTlsa created in subdomains parseJSON _ = empty instance Mergeable NmcDom where - merge sub dom = dom { domService = mergelm domService - , domIp = mergelm domIp + merge sub dom = dom { domIp = mergelm domIp , domIp6 = mergelm domIp6 , domTor = choose domTor , domI2p = mergelm domI2p @@ -216,9 +201,8 @@ instance Mergeable NmcDom where , domNs = mergelm domNs , domDelegate = mergelm domDelegate , domImport = mergelm domImport - , domMap = mergelm domMap + , domSubmap = mergelm domSubmap , domFingerprint = mergelm domFingerprint - , domTls = mergelm domTls , domDs = mergelm domDs , domMx = mergelm domMx , domSrv = mergelm domSrv @@ -232,6 +216,3 @@ instance Mergeable NmcDom where choose field = case field dom of Nothing -> field sub Just x -> Just x - -mergeNmcDom :: NmcDom -> NmcDom -> NmcDom -mergeNmcDom = merge diff --git a/NmcTransform.hs b/NmcTransform.hs index cf93db3..858acf7 100644 --- a/NmcTransform.hs +++ b/NmcTransform.hs @@ -39,7 +39,7 @@ mergeIncl :: -> IO (Either String NmcDom) -- ^ result with merged import mergeIncl queryOp depth base = do let - mbase = (expandSrv . splitSubdoms . mergeSelf) base + mbase = ({-expandSrv .-} splitSubdoms . mergeSelf) base base' = mbase {domDelegate = Nothing, domImport = Nothing} -- print base if depth <= 0 then return $ Left "Nesting of imports is too deep" @@ -53,15 +53,15 @@ mergeIncl queryOp depth base = do sub <- queryNmcDom queryOp key case sub of Left err -> return $ Left err - Right sub' -> mergeIncl queryOp (depth - 1) $ sub' `mergeNmcDom` acc + Right sub' -> mergeIncl queryOp (depth - 1) $ sub' `merge` acc -- | If there is an element in the map with key "", merge the contents -- and remove this element. Do this recursively. mergeSelf :: NmcDom -> NmcDom mergeSelf base = let - map = domMap base - base' = base {domMap = removeSelf map} + map = domSubmap base + base' = base {domSubmap = removeSelf map} removeSelf Nothing = Nothing removeSelf (Just map) = if size map' == 0 then Nothing else Just map' where map' = delete "" map @@ -71,9 +71,9 @@ mergeSelf base = Just map' -> case lookup "" map' of Nothing -> base' - Just sub -> (mergeSelf sub) `mergeNmcDom` base' + Just sub -> (mergeSelf sub) `merge` base' -- recursion depth limited by the size of the record - +{- -- | replace Service with Srv down in the Map expandSrv :: NmcDom -> NmcDom expandSrv base = @@ -84,11 +84,11 @@ expandSrv base = Nothing -> base' Just sl -> foldr addSrvMx base' sl where - addSrvMx sr acc = sub1 `mergeNmcDom` acc + addSrvMx sr acc = sub1 `merge` acc where - sub1 = def { domMap = Just (singleton proto sub2) + sub1 = def { domSubmap = Just (singleton proto sub2) , domMx = maybemx} - sub2 = def { domMap = Just (singleton srvid sub3) } + sub2 = def { domSubmap = Just (singleton srvid sub3) } sub3 = def { domSrv = Just [srvStr] } proto = "_" ++ (srvProto sr) srvid = "_" ++ (srvName sr) @@ -102,20 +102,20 @@ expandSrv base = && srvPort sr == 25 then Just [(show (srvPrio sr)) ++ "\t" ++ (srvHost sr)] else Nothing - +-} -- | Convert map elements of the form "subN...sub2.sub1.dom.bit" -- into nested map and merge it splitSubdoms :: NmcDom -> NmcDom splitSubdoms base = let - base' = base { domMap = Nothing } + base' = base { domSubmap = Nothing } in - case domMap base of + case domSubmap base of Nothing -> base' - Just sdmap -> (def { domMap = Just sdmap' }) `mergeNmcDom` base' + Just sdmap -> (def { domSubmap = Just sdmap' }) `merge` base' where sdmap' = foldrWithKey stow empty sdmap - stow fqdn sdom acc = insertWith mergeNmcDom fqdn' sdom' acc + stow fqdn sdom acc = insertWith merge fqdn' sdom' acc where (fqdn', sdom') = nest (filter (/= "") (splitOnDots fqdn), sdom) @@ -123,7 +123,7 @@ splitSubdoms base = nest ([], v) = (fqdn, v) -- can split result be empty? nest ([k], v) = (k, v) nest (k:ks, v) = - nest (ks, def { domMap = Just (singleton k v) }) + nest (ks, def { domSubmap = Just (singleton k v) }) -- | transfer some elements of `base` into `sub`, notably TLSA propagate :: NmcDom -> NmcDom -> NmcDom @@ -140,7 +140,7 @@ normalizeDom dom = foldr id dom [ translateNormalizer Just ns -> def { domNs = domNs dom, domEmail = domEmail dom } translateNormalizer dom = case domTranslate dom of Nothing -> dom - Just tr -> dom { domMap = Nothing } + Just tr -> dom { domSubmap = Nothing } -- | Merge imports and Selfs and follow the maps tree to get dom descendNmcDom :: @@ -156,7 +156,7 @@ descendNmcDom queryOp subdom base = do case base' of Left err -> return base' Right base'' -> - case domMap base'' of + case domSubmap base'' of Nothing -> return $ Right def Just map -> case lookup d map of diff --git a/PowerDns.hs b/PowerDns.hs index ef8211d..606c5ca 100644 --- a/PowerDns.hs +++ b/PowerDns.hs @@ -127,7 +127,7 @@ pdnsOutXfr ver id gen name edom = , RRTypeDS, RRTypeMX, RRTypeSOA ] walkDom f acc name dom = - f name dom $ case domMap dom of + f name dom $ case domSubmap dom of Nothing -> acc Just dm -> foldrWithKey (\n d a -> walkDom f a (n ++ "." ++ name) d) acc dm @@ -165,9 +165,27 @@ dotmail addr = "" -> aname ++ "." _ -> aname ++ "." ++ (tail adom) ++ "." -dataRR RRTypeSRV = justl domSrv +dataRR RRTypeSRV = \ _ _ dom -> + case domSrv dom of + Nothing -> [] + Just srvs -> map srvStr srvs + where + srvStr x = (show (srvPrio x)) ++ "\t" + ++ (show (srvWeight x)) ++ " " + ++ (show (srvPort x)) ++ " " + ++ (srvHost x) + dataRR RRTypeMX = justl domMx -dataRR RRTypeTLSA = justl domTlsa +dataRR RRTypeTLSA = \ _ _ dom -> + case domTlsa dom of + Nothing -> [] + Just tlsas -> map tlsaStr tlsas + where + tlsaStr x = "(3 0 " + ++ (show (tlsMatchType x)) ++ " " + ++ (tlsMatchValue x) ++ ")" + -- tlsIncSubdoms is not displayed, it is used for `propagate`. + dataRR RRTypeA = justl domIp dataRR RRTypeAAAA = justl domIp6 dataRR RRTypeCNAME = justv domAlias -- 2.39.2