From: Eugene Crosser <crosser@average.org>
Date: Sun, 13 Apr 2014 11:07:22 +0000 (+0400)
Subject: incorporate resursive merges
X-Git-Tag: 0.9.0.0~82
X-Git-Url: http://average.org/gitweb/?a=commitdiff_plain;h=fbe7735ec10867611bc9d202fce4336c36c8af66;p=pdns-pipe-nmc.git

incorporate resursive merges
---

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