From 4525a07052ec3ad3fd7b094a4acf4e00201fbf9f Mon Sep 17 00:00:00 2001 From: Eugene Crosser Date: Sun, 13 Apr 2014 02:15:44 +0400 Subject: [PATCH] handle (and test) imports --- NmcDom.hs | 45 +++++++++++++++++++++++++++++++++------------ d/extra1 | 1 + d/root | 2 +- test.hs | 4 ++-- 4 files changed, 37 insertions(+), 15 deletions(-) create mode 100644 d/extra1 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 -- 2.39.2