]> average.org Git - pdns-pipe-nmc.git/commitdiff
split NmcTransform from NmcDom
authorEugene Crosser <crosser@average.org>
Wed, 16 Apr 2014 07:18:58 +0000 (11:18 +0400)
committerEugene Crosser <crosser@average.org>
Wed, 16 Apr 2014 07:18:58 +0000 (11:18 +0400)
NmcDom.hs
NmcTransform.hs [new file with mode: 0644]
pdns-pipe-nmc.hs
test.hs

index e03f683bf2107166fe4bdca7ebfde45449f07888..90c7966064afe24cfba4321d405aed70f0535de6 100644 (file)
--- 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 (file)
index 0000000..29c0008
--- /dev/null
@@ -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])}
index 1d2563788d0f4fa938ac685322f7d785966ee3f2..6e42ac2a033f95e2a37f416c590a23e5ce54470c 100644 (file)
@@ -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 117994d76e6e706503b81982f0976af42d3d0b80..6f98fc677359edce6dabda7fe631a640a19ff247 100644 (file)
--- 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)