From: Eugene Crosser Date: Sat, 3 May 2014 15:58:21 +0000 (+0400) Subject: wip split subdoms in the parser X-Git-Tag: 0.9.0.1~7 X-Git-Url: http://average.org/gitweb/?a=commitdiff_plain;h=444411783cdc992b99a6d9fe0e0a5922686d1931;p=pdns-pipe-nmc.git wip split subdoms in the parser --- diff --git a/NmcDom.hs b/NmcDom.hs index bcbfcd3..3b8f060 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -17,7 +17,7 @@ import Data.List.Split import Data.Vector ((!), length) import qualified Data.Vector as V (singleton) import Data.Map (Map, unionWith, foldrWithKey) -import qualified Data.Map as M (singleton, empty) +import qualified Data.Map as M (singleton, empty, insert, insertWith) import qualified Data.HashMap.Strict as H (lookup) import Data.Aeson import Data.Aeson.Types @@ -74,7 +74,25 @@ makeSubmap :: Object -> Parser (Maybe (Map String NmcDom)) makeSubmap o = ((.).(.)) merge merge <$> takeTls o <*> takeSrv o <*> takeMap o takeMap :: Object -> Parser (Maybe (Map String NmcDom)) -takeMap o = o .:? "map" -- FIXME split over dots here +takeMap o = + case H.lookup "map" o of + Nothing -> pure Nothing + Just (Object mo) -> do + unsplit <- (parseJSON (Object mo) :: Parser (Maybe (Map String NmcDom))) + let result = fmap splitup unsplit + return result + where + splitup :: Map String NmcDom -> Map String NmcDom + splitup x = foldrWithKey stow M.empty x + stow fqdn sdom acc = M.insertWith merge fqdn' sdom' acc + where + (fqdn', sdom') = nest (filter (/= "") (splitOnDots fqdn), sdom) + splitOnDots s = splitOn "." s + nest ([], v) = (fqdn, v) -- can split result be empty? + nest ([k], v) = (k, v) + nest (k:ks, v) = + nest (ks, def { domSubmap = Just (M.singleton k v) }) + _ -> empty takeSrv :: Object -> Parser (Maybe (Map String NmcDom)) takeSrv o = diff --git a/NmcTransform.hs b/NmcTransform.hs index d9a98d0..c461274 100644 --- a/NmcTransform.hs +++ b/NmcTransform.hs @@ -4,7 +4,6 @@ module NmcTransform ( seedNmcDom import Prelude hiding (lookup) import Data.ByteString.Lazy (ByteString) -import Data.Text.Lazy (splitOn, pack, unpack) import Data.Map.Lazy (empty, lookup, delete, size, singleton , foldrWithKey, insert, insertWith) import Control.Monad (foldM) @@ -39,7 +38,7 @@ mergeIncl :: -> IO (Either String NmcDom) -- ^ result with merged import mergeIncl queryOp depth base = do let - mbase = (splitSubdoms . mergeSelf) base + mbase = mergeSelf base base' = mbase {domDelegate = Nothing, domImport = Nothing} -- print base if depth <= 0 then return $ Left "Nesting of imports is too deep" @@ -74,28 +73,6 @@ mergeSelf base = Just sub -> (mergeSelf sub) `merge` base' -- recursion depth limited by the size of the record --- | 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 { domSubmap = Nothing } - in - case domSubmap base of - Nothing -> base' - Just sdmap -> (def { domSubmap = Just sdmap' }) `merge` base' - where - sdmap' = foldrWithKey stow empty sdmap - stow fqdn sdom acc = insertWith merge fqdn' sdom' acc - where - (fqdn', sdom') = - nest (filter (/= "") (splitOnDots fqdn), sdom) - splitOnDots s = map unpack (splitOn (pack ".") (pack s)) - nest ([], v) = (fqdn, v) -- can split result be empty? - nest ([k], v) = (k, v) - nest (k:ks, v) = - nest (ks, def { domSubmap = Just (singleton k v) }) - -- | transfer some elements of `base` into `sub`, notably TLSA propagate :: NmcDom -> NmcDom -> NmcDom propagate base sub = sub -- FIXME implement it