incorporate resursive merges

diff --git a/NmcDom.hs b/NmcDom.hs
index 61f7a19642a4199a25f9f6a708e501d7bf05bb09..03eeb98582275db94d2554b48fb4d4a80bb15cf6 100644 (file)
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -2,15 +2,15 @@
 
 module NmcDom   ( NmcDom(..)
                 , emptyNmcDom
 
 module NmcDom   ( NmcDom(..)
                 , emptyNmcDom

+                , seedNmcDom

                 , descendNmcDom
                 , descendNmcDom

-                , mergeImport

                 ) where
 
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.Text as T (unpack)
 import Data.List.Split
 import Data.Char
                 ) 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
 
 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
 
                      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
 -- 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
                         , domNs =          choose domNs
                         , domDelegate =    choose domDelegate
                         , domImport =      choose domImport

+                        , domMap =         choose domMap

                         , domFingerprint = choose domFingerprint
                         , domTls =         choose domTls
                         , domDs =          choose domDs
                         , 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
   -> 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'
     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 0e0d9e6c017f1123b748af3bb774527472f0bb9a..1d2563788d0f4fa938ac685322f7d785966ee3f2 100644 (file)
--- 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
          -> 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
   where
     queryOp key = do
       rsp <- runResourceT $ httpLbs (qReq cfg key qid) mgr

diff --git a/test.hs b/test.hs
index eb3bfb9c4b8208efa7fe3205d0772fa3aef02ea8..1f19426c139401552e0b9f066df0f9c1382376dd 100644 (file)
--- 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
                     (\e -> return (Left (show (e :: IOException))))
 
 main = do

-        d <- mergeImport queryOp (emptyNmcDom {domImport = Just "d/root"})
+        d <- descendNmcDom queryOp [] $ seedNmcDom "root"

         putStrLn $ show d
 
         putStrLn $ show d