From: Eugene Crosser <crosser@average.org>
Date: Sat, 12 Apr 2014 22:15:44 +0000 (+0400)
Subject: handle (and test) imports
X-Git-Tag: 0.9.0.0~86
X-Git-Url: http://average.org/gitweb/?a=commitdiff_plain;h=4525a07052ec3ad3fd7b094a4acf4e00201fbf9f;p=pdns-pipe-nmc.git

handle (and test) imports
---

diff --git a/NmcDom.hs b/NmcDom.hs
index f2ad26f..25dd84f 100644
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -2,12 +2,14 @@
 
 module NmcDom   ( NmcDom(..)
                 , emptyNmcDom
-                , descendNmc
-                , queryDom
+                , descendNmcDom
+                , queryNmcDom
+                , mergeImport
                 ) where
 
 import Data.ByteString.Lazy (ByteString)
-import Data.Text as T (unpack)
+import qualified Data.ByteString.Lazy.Char8 as L (pack)
+import qualified Data.Text as T (unpack)
 import Data.List.Split
 import Data.Char
 import Data.Map as M (Map, lookup)
@@ -59,7 +61,7 @@ data NmcDom = NmcDom    { domService     :: Maybe [[String]] -- [NmcRRService]
                         , domInfo        :: Maybe Value
                         , domNs          :: Maybe [String]
                         , domDelegate    :: Maybe [String]
-                        , domImport      :: Maybe [[String]]
+                        , domImport      :: Maybe String
                         , domMap         :: Maybe (Map String NmcDom)
                         , domFingerprint :: Maybe [String]
                         , domTls         :: Maybe (Map String
@@ -115,8 +117,8 @@ normalizeDom dom
   | domTranslate dom /= Nothing = dom { domMap = Nothing }
   | otherwise                   = dom
 
-descendNmc :: [String] -> NmcDom -> NmcDom
-descendNmc subdom rawdom =
+descendNmcDom :: [String] -> NmcDom -> NmcDom
+descendNmcDom subdom rawdom =
   let dom = normalizeDom rawdom
   in case subdom of
     []   ->
@@ -125,18 +127,18 @@ descendNmc subdom rawdom =
         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 -> mergeNmc sub dom  -- Or maybe drop it altogether...
+            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 -> descendNmc ds sub
+            Just sub -> descendNmcDom ds sub
 
 -- FIXME -- I hope there exists a better way to merge records!
-mergeNmc :: NmcDom -> NmcDom -> NmcDom
-mergeNmc sub dom = dom  { domService = choose domService
+mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
+mergeNmcDom sub dom = dom  { domService = choose domService
                         , domIp =          choose domIp
                         , domIp6 =         choose domIp6
                         , domTor =         choose domTor
@@ -161,14 +163,33 @@ mergeNmc sub dom = dom  { domService = choose domService
       Just x  -> Just x
 
 -- | Perform query and return error string or parsed domain object
-queryDom ::
+queryNmcDom ::
   (ByteString -> IO (Either String ByteString)) -- ^ query operation action
   -> ByteString                                 -- ^ key
   -> IO (Either String NmcDom)                  -- ^ error string or domain
-queryDom queryOp key = do
+queryNmcDom queryOp key = do
   l <- queryOp key
   case l of
     Left estr -> return $ Left estr
     Right str -> case decode str :: Maybe NmcDom of
       Nothing  -> return $ Left $ "Unparseable value: " ++ (show str)
       Just dom -> return $ Right dom
+
+-- | Try to fetch "import" object and merge it into the base domain
+--   Any errors are ignored, and nothing is merged.
+--   Original "import" element is removed, but new imports from the
+--   imported objects are processed recursively until there are none.
+mergeImport ::
+  (ByteString -> IO (Either String ByteString)) -- ^ query operation action
+  -> NmcDom                                     -- ^ base domain
+  -> IO NmcDom                                  -- ^ result with merged import
+mergeImport queryOp base = do
+  let base' = base {domImport = Nothing}
+  -- print base'
+  case domImport base of
+    Nothing  -> return base'
+    Just key -> do
+      sub <- queryNmcDom queryOp (L.pack key)
+      case sub of
+        Left  e    -> return base'
+        Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base'
diff --git a/d/extra1 b/d/extra1
new file mode 100644
index 0000000..273d05a
--- /dev/null
+++ b/d/extra1
@@ -0,0 +1 @@
+{"service":[["imap", "tcp", "0", "0", "143", "mail.host.com."],["smtp", "tcp", "0", "0", "143", "mail.host.com."]]}
diff --git a/d/root b/d/root
index a59957c..7f6874a 100644
--- a/d/root
+++ b/d/root
@@ -1 +1 @@
-{"info":{"description":"Dot-BIT Project - Official Website","registrar":"http://register.dot-bit.org"},"fingerprint":["30:B0:60:94:32:08:EC:F5:BE:DF:F4:BB:EE:52:90:2C:5D:47:62:46"],"ns":["ns0.web-sweet-web.net","ns1.web-sweet-web.net"],"map":{"":{"ns":["ns0.web-sweet-web.net","ns1.web-sweet-web.net"]}},"email":"register@dot-bit.org"}
+{"info":{"description":"Dot-BIT Project - Official Website","registrar":"http://register.dot-bit.org"},"fingerprint":["30:B0:60:94:32:08:EC:F5:BE:DF:F4:BB:EE:52:90:2C:5D:47:62:46"],"ns":["ns0.web-sweet-web.net","ns1.web-sweet-web.net"],"map":{"":{"ns":["ns0.web-sweet-web.net","ns1.web-sweet-web.net"]}},"email":"register@dot-bit.org","import":"d/extra1"}
diff --git a/test.hs b/test.hs
index 8f5b77c..966186f 100644
--- a/test.hs
+++ b/test.hs
@@ -11,10 +11,10 @@ import Control.Exception
 import NmcDom
 
 queryOp :: ByteString -> IO (Either String ByteString)
-queryOp key = catch (readFile ("d/" ++ (unpack key)) >>= return . Right)
+queryOp key = catch (readFile (unpack key) >>= return . Right)
                     (\e -> return (Left (show (e :: IOException))))
 
 main = do
-        d <- queryDom queryOp "root"
+        d <- mergeImport queryOp (emptyNmcDom {domImport = Just "d/root"})
         putStrLn $ show d