From fbe7735ec10867611bc9d202fce4336c36c8af66 Mon Sep 17 00:00:00 2001 From: Eugene Crosser Date: Sun, 13 Apr 2014 15:07:22 +0400 Subject: [PATCH] incorporate resursive merges --- NmcDom.hs | 97 ++++++++++++++++++++++++++++++++---------------- pdns-pipe-nmc.hs | 10 +---- test.hs | 2 +- 3 files changed, 67 insertions(+), 42 deletions(-) diff --git a/NmcDom.hs b/NmcDom.hs index 61f7a19..03eeb98 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -2,15 +2,15 @@ module NmcDom ( NmcDom(..) , emptyNmcDom + , seedNmcDom , descendNmcDom - , mergeImport ) where import Data.ByteString.Lazy (ByteString) import qualified Data.Text as T (unpack) import Data.List.Split import Data.Char -import Data.Map as M (Map, lookup) +import Data.Map as M (Map, lookup, delete, size) import Control.Applicative ((<$>), (<*>), empty) import Data.Aeson @@ -106,34 +106,6 @@ emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing -normalizeDom :: NmcDom -> NmcDom -normalizeDom dom - | domNs dom /= Nothing = emptyNmcDom { domNs = domNs dom - , domEmail = domEmail dom - } - | domDelegate dom /= Nothing = emptyNmcDom -- FIXME - | domTranslate dom /= Nothing = dom { domMap = Nothing } - | otherwise = dom - -descendNmcDom :: [String] -> NmcDom -> NmcDom -descendNmcDom subdom rawdom = - let dom = normalizeDom rawdom - in case subdom of - [] -> - case domMap dom of - Nothing -> dom - Just map -> - case M.lookup "" map of -- Stupid, but there are "" in the map - Nothing -> dom -- Try to merge it with the root data - Just sub -> mergeNmcDom sub dom -- Or maybe drop it altogether... - d:ds -> - case domMap dom of - Nothing -> emptyNmcDom - Just map -> - case M.lookup d map of - Nothing -> emptyNmcDom - Just sub -> descendNmcDom ds sub - -- FIXME -- I hope there exists a better way to merge records! mergeNmcDom :: NmcDom -> NmcDom -> NmcDom mergeNmcDom sub dom = dom { domService = choose domService @@ -150,6 +122,7 @@ mergeNmcDom sub dom = dom { domService = choose domService , domNs = choose domNs , domDelegate = choose domDelegate , domImport = choose domImport + , domMap = choose domMap , domFingerprint = choose domFingerprint , domTls = choose domTls , domDs = choose domDs @@ -181,12 +154,70 @@ mergeImport :: -> NmcDom -- ^ base domain -> IO (Either String NmcDom) -- ^ result with merged import mergeImport queryOp base = do - let base' = base {domImport = Nothing} - -- print base' - case domImport base of + let + mbase = mergeSelf base + base' = mbase {domImport = Nothing} + -- print base + case domImport mbase of Nothing -> return $ Right base' Just key -> do sub <- queryNmcDom queryOp key case sub of Left e -> return $ Left e Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base' + +-- | 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 + nbase = normalizeDom base + map = domMap nbase + base' = nbase {domMap = removeSelf map} + removeSelf (Nothing) = Nothing + removeSelf (Just map) = if size map' == 0 then Nothing else Just map' + where map' = M.delete "" map + in + case map of + Nothing -> base' + Just map' -> + case M.lookup "" map' of + Nothing -> base' + Just sub -> (mergeSelf sub) `mergeNmcDom` base' + +-- | Presence of some elements require removal of some others +normalizeDom :: NmcDom -> NmcDom +normalizeDom dom + | domNs dom /= Nothing = emptyNmcDom { domNs = domNs dom + , domEmail = domEmail dom + } + | domDelegate dom /= Nothing = emptyNmcDom -- FIXME + | domTranslate dom /= Nothing = dom { domMap = Nothing } + | otherwise = dom + +-- | Merge imports and Selfs and follow the maps tree to get dom +descendNmcDom :: + (String -> IO (Either String ByteString)) -- ^ query operation action + -> [String] -- ^ subdomain chain + -> NmcDom -- ^ base domain + -> IO (Either String NmcDom) -- ^ fully processed result +descendNmcDom queryOp subdom base = do + base' <- mergeImport queryOp base + case subdom of + [] -> return base' + d:ds -> + case base' of + Left err -> return base' + Right base'' -> + case domMap base'' of + Nothing -> return $ Right emptyNmcDom + Just map -> + case M.lookup d map of + Nothing -> return $ Right emptyNmcDom + Just sub -> descendNmcDom queryOp ds sub + +-- | Initial NmcDom populated with "import" only, suitable for "descend" +seedNmcDom :: + String -- ^ domain key (without namespace prefix) + -> NmcDom -- ^ resulting seed domain +seedNmcDom dn = emptyNmcDom { domImport = Just ("d/" ++ dn)} diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs index 0e0d9e6..1d25637 100644 --- a/pdns-pipe-nmc.hs +++ b/pdns-pipe-nmc.hs @@ -56,14 +56,8 @@ queryNmc :: Manager -> Config -> String -> String -> IO (Either String NmcDom) queryNmc mgr cfg qid fqdn = case reverse (splitOn "." fqdn) of - "bit":dn:xs -> do - dom <- mergeImport queryOp $ - emptyNmcDom { domImport = Just ("d/" ++ dn)} - case dom of - Left err -> return $ Left err - Right dom' -> return $ Right $ descendNmcDom xs dom' - _ -> - return $ Left "Only \".bit\" domain is supported" + "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn + _ -> return $ Left "Only \".bit\" domain is supported" where queryOp key = do rsp <- runResourceT $ httpLbs (qReq cfg key qid) mgr diff --git a/test.hs b/test.hs index eb3bfb9..1f19426 100644 --- a/test.hs +++ b/test.hs @@ -15,6 +15,6 @@ queryOp key = catch (readFile key >>= return . Right) (\e -> return (Left (show (e :: IOException)))) main = do - d <- mergeImport queryOp (emptyNmcDom {domImport = Just "d/root"}) + d <- descendNmcDom queryOp [] $ seedNmcDom "root" putStrLn $ show d -- 2.39.2