From c3a4cdbe13176c6b6327c7bac775d0bc6be2819c Mon Sep 17 00:00:00 2001 From: Eugene Crosser Date: Wed, 16 Apr 2014 11:18:58 +0400 Subject: [PATCH] split NmcTransform from NmcDom --- NmcDom.hs | 143 +++++------------------------------------------ NmcTransform.hs | 129 ++++++++++++++++++++++++++++++++++++++++++ pdns-pipe-nmc.hs | 1 + test.hs | 1 + 4 files changed, 144 insertions(+), 130 deletions(-) create mode 100644 NmcTransform.hs diff --git a/NmcDom.hs b/NmcDom.hs index e03f683..90c7966 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -2,24 +2,22 @@ module NmcDom ( NmcDom(..) , NmcRRService(..) + , NmcRRI2p(..) + , NmcRRTls(..) , emptyNmcDom - , seedNmcDom - , descendNmcDom + , mergeNmcDom ) where import Prelude hiding (length) -import Data.ByteString.Lazy (ByteString) +import Control.Applicative ((<$>), (<*>), empty, pure) +import Data.Char import Data.Text (Text, unpack) -import Data.List as L (union) +import Data.List (union) import Data.List.Split -import Data.Char -import Data.Map as M (Map, lookup, delete, size, unionWith) -import Data.Vector (toList,(!),length, singleton) -import Control.Monad (foldM) -import Control.Applicative ((<$>), (<*>), empty, pure) +import Data.Vector ((!), length, singleton) +import Data.Map (Map, unionWith) +import qualified Data.HashMap.Strict as H (lookup) import Data.Aeson - -import qualified Data.HashMap.Strict as H import Data.Aeson.Types -- Variant of Aeson's `.:?` that interprets a String as a @@ -39,7 +37,7 @@ class Mergeable a where merge :: a -> a -> a -- bias towads second arg instance (Ord k, Mergeable a) => Mergeable (Map k a) where - merge mx my = M.unionWith merge my mx + merge mx my = unionWith merge my mx -- Alas, the following is not possible in Haskell :-( -- instance Mergeable String where @@ -55,7 +53,7 @@ instance Mergeable a => Mergeable (Maybe a) where merge Nothing Nothing = Nothing instance Eq a => Mergeable [a] where - merge xs ys = L.union xs ys + merge xs ys = union xs ys data NmcRRService = NmcRRService { srvName :: String @@ -223,125 +221,10 @@ instance Mergeable NmcDom where Nothing -> field sub Just x -> Just x +mergeNmcDom :: NmcDom -> NmcDom -> NmcDom +mergeNmcDom = merge emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - --- | Perform query and return error string or parsed domain object -queryNmcDom :: - (String -> IO (Either String ByteString)) -- ^ query operation action - -> String -- ^ key - -> IO (Either String NmcDom) -- ^ error string or domain -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 --- Original "import" element is removed, but new imports from the --- imported objects are processed recursively until there are none. -mergeImport :: - (String -> IO (Either String ByteString)) -- ^ query operation action - -> Int -- ^ recursion counter - -> NmcDom -- ^ base domain - -> IO (Either String NmcDom) -- ^ result with merged import -mergeImport queryOp depth base = do - let - mbase = mergeSelf base - base' = mbase {domImport = Nothing} - -- print base - if depth <= 0 then return $ Left "Nesting of imports is too deep" - else case domImport mbase of - Nothing -> return $ Right base' - Just keys -> foldM mergeImport1 (Right base') keys - where - mergeImport1 (Left err) _ = return $ Left err - mergeImport1 (Right acc) key = do - sub <- queryNmcDom queryOp key - case sub of - Left err -> return $ Left err - Right sub' -> mergeImport queryOp (depth - 1) $ sub' `merge` acc - --- | 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 - map = domMap base - base' = base {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) `merge` base' - -- recursion depth limited by the size of the record - --- | SRV case - remove everyting and filter SRV records -normalizeSrv :: String -> String -> NmcDom -> NmcDom -normalizeSrv serv proto dom = - emptyNmcDom {domService = fmap (filter needed) (domService dom)} - where - needed r = srvName r == serv && srvProto r == proto - --- | Presence of some elements require removal of some others -normalizeDom :: NmcDom -> NmcDom -normalizeDom dom = foldr id dom [ srvNormalizer - , translateNormalizer - , nsNormalizer - ] - where - nsNormalizer dom = case domNs dom of - Nothing -> dom - Just ns -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom } - translateNormalizer dom = case domTranslate dom of - Nothing -> dom - Just tr -> dom { domMap = Nothing } - srvNormalizer dom = dom { domService = Nothing, domMx = makemx } - where - makemx = case domService dom of - Nothing -> Nothing - Just svl -> Just $ map makerec (filter needed svl) - where - needed sr = srvName sr == "smtp" - && srvProto sr == "tcp" - && srvPort sr == 25 - makerec sr = (show (srvPrio sr)) ++ " " ++ (srvHost sr) - --- | 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 10 base - case subdom of - [] -> return $ fmap normalizeDom base' - -- A hack to handle SRV records: don't descend if ["_prot","_serv"] - [('_':p),('_':s)] -> return $ fmap (normalizeSrv s p) 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/NmcTransform.hs b/NmcTransform.hs new file mode 100644 index 0000000..29c0008 --- /dev/null +++ b/NmcTransform.hs @@ -0,0 +1,129 @@ +module NmcTransform ( seedNmcDom + , descendNmcDom + ) where + +import Prelude hiding (lookup) +import Data.ByteString.Lazy (ByteString) +import Data.Map (lookup, delete, size) +import Control.Monad (foldM) +import Data.Aeson (decode) + +import NmcDom + +-- | Perform query and return error string or parsed domain object +queryNmcDom :: + (String -> IO (Either String ByteString)) -- ^ query operation action + -> String -- ^ key + -> IO (Either String NmcDom) -- ^ error string or domain +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 +-- Original "import" element is removed, but new imports from the +-- imported objects are processed recursively until there are none. +mergeImport :: + (String -> IO (Either String ByteString)) -- ^ query operation action + -> Int -- ^ recursion counter + -> NmcDom -- ^ base domain + -> IO (Either String NmcDom) -- ^ result with merged import +mergeImport queryOp depth base = do + let + mbase = mergeSelf base + base' = mbase {domImport = Nothing} + -- print base + if depth <= 0 then return $ Left "Nesting of imports is too deep" + else case domImport mbase of + Nothing -> return $ Right base' + Just keys -> foldM mergeImport1 (Right base') keys + where + mergeImport1 (Left err) _ = return $ Left err + mergeImport1 (Right acc) key = do + sub <- queryNmcDom queryOp key + case sub of + Left err -> return $ Left err + Right sub' -> mergeImport queryOp (depth - 1) $ + sub' `mergeNmcDom` acc + +-- | 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 + map = domMap base + base' = base {domMap = removeSelf map} + removeSelf Nothing = Nothing + removeSelf (Just map) = if size map' == 0 then Nothing else Just map' + where map' = delete "" map + in + case map of + Nothing -> base' + Just map' -> + case lookup "" map' of + Nothing -> base' + Just sub -> (mergeSelf sub) `mergeNmcDom` base' + -- recursion depth limited by the size of the record + +-- | SRV case - remove everyting and filter SRV records +normalizeSrv :: String -> String -> NmcDom -> NmcDom +normalizeSrv serv proto dom = + emptyNmcDom {domService = fmap (filter needed) (domService dom)} + where + needed r = srvName r == serv && srvProto r == proto + +-- | Presence of some elements require removal of some others +normalizeDom :: NmcDom -> NmcDom +normalizeDom dom = foldr id dom [ srvNormalizer + , translateNormalizer + , nsNormalizer + ] + where + nsNormalizer dom = case domNs dom of + Nothing -> dom + Just ns -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom } + translateNormalizer dom = case domTranslate dom of + Nothing -> dom + Just tr -> dom { domMap = Nothing } + srvNormalizer dom = dom { domService = Nothing, domMx = makemx } + where + makemx = case domService dom of + Nothing -> Nothing + Just svl -> Just $ map makerec (filter needed svl) + where + needed sr = srvName sr == "smtp" + && srvProto sr == "tcp" + && srvPort sr == 25 + makerec sr = (show (srvPrio sr)) ++ " " ++ (srvHost sr) + +-- | 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 10 base + case subdom of + [] -> return $ fmap normalizeDom base' + -- A hack to handle SRV records: don't descend if ["_prot","_serv"] + [('_':p),('_':s)] -> return $ fmap (normalizeSrv s p) base' + d:ds -> + case base' of + Left err -> return base' + Right base'' -> + case domMap base'' of + Nothing -> return $ Right emptyNmcDom + Just map -> + case 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 1d25637..6e42ac2 100644 --- a/pdns-pipe-nmc.hs +++ b/pdns-pipe-nmc.hs @@ -19,6 +19,7 @@ import Config import PowerDns import NmcRpc import NmcDom +import NmcTransform confFile = "/etc/namecoin.conf" diff --git a/test.hs b/test.hs index 117994d..6f98fc6 100644 --- a/test.hs +++ b/test.hs @@ -10,6 +10,7 @@ import System.IO.Error import Control.Exception import NmcDom +import NmcTransform queryOp :: String -> IO (Either String ByteString) queryOp key = catch (readFile key >>= return . Right) -- 2.39.2