1 module NmcTransform ( seedNmcDom
5 import Prelude hiding (lookup)
6 import Data.ByteString.Lazy (ByteString)
7 import Data.Text.Lazy (splitOn, pack, unpack)
8 import Data.Map.Lazy (empty, lookup, delete, size, singleton
9 , foldrWithKey, insert, insertWith)
10 import Control.Monad (foldM)
11 import Data.Aeson (decode)
15 -- | Perform query and return error string or parsed domain object
17 (String -> IO (Either String ByteString)) -- ^ query operation action
19 -> IO (Either String NmcDom) -- ^ error string or domain
20 queryNmcDom queryOp key = do
23 Left estr -> return $ Left estr
24 Right str -> case decode str :: Maybe NmcDom of
25 Nothing -> return $ Left $ "Unparseable value: " ++ (show str)
26 Just dom -> return $ Right dom
28 -- | Try to fetch "import" object and merge it into the base domain
29 -- Original "import" element is removed, but new imports from the
30 -- imported objects are processed recursively until there are none.
32 (String -> IO (Either String ByteString)) -- ^ query operation action
33 -> Int -- ^ recursion counter
34 -> NmcDom -- ^ base domain
35 -> IO (Either String NmcDom) -- ^ result with merged import
36 mergeImport queryOp depth base = do
38 mbase = (expandSrv . splitSubdoms . mergeSelf) base
39 base' = mbase {domImport = Nothing}
41 if depth <= 0 then return $ Left "Nesting of imports is too deep"
42 else case ((domDelegate mbase), (domImport mbase)) of
43 (Nothing, Nothing ) -> return $ Right base'
44 (Nothing, Just keys) -> foldM mergeImport1 (Right base') keys
45 (Just key, _ ) -> mergeImport1 (Right emptyNmcDom) key
47 mergeImport1 (Left err) _ = return $ Left err -- can never happen
48 mergeImport1 (Right acc) key = do
49 sub <- queryNmcDom queryOp key
51 Left err -> return $ Left err
52 Right sub' -> mergeImport queryOp (depth - 1) $ sub' `mergeNmcDom` acc
54 -- | If there is an element in the map with key "", merge the contents
55 -- and remove this element. Do this recursively.
56 mergeSelf :: NmcDom -> NmcDom
60 base' = base {domMap = removeSelf map}
61 removeSelf Nothing = Nothing
62 removeSelf (Just map) = if size map' == 0 then Nothing else Just map'
63 where map' = delete "" map
68 case lookup "" map' of
70 Just sub -> (mergeSelf sub) `mergeNmcDom` base'
71 -- recursion depth limited by the size of the record
73 -- | replace Service with Srv down in the Map
74 expandSrv :: NmcDom -> NmcDom
77 base' = base { domService = Nothing }
79 case domService base of
81 Just sl -> foldr addSrvMx base' sl
83 addSrvMx sr acc = sub1 `mergeNmcDom` acc
85 sub1 = emptyNmcDom { domMap = Just (singleton proto sub2)
87 sub2 = emptyNmcDom { domMap = Just (singleton srvid sub3) }
88 sub3 = emptyNmcDom { domSrv = Just [srvStr] }
89 proto = "_" ++ (srvProto sr)
90 srvid = "_" ++ (srvName sr)
91 srvStr = (show (srvPrio sr)) ++ " "
92 ++ (show (srvWeight sr)) ++ " "
93 ++ (show (srvPort sr)) ++ " "
96 if srvName sr == "smtp"
97 && srvProto sr == "tcp"
99 then Just [(show (srvPrio sr)) ++ " " ++ (srvHost sr)]
102 -- | Convert map elements of the form "subN...sub2.sub1.dom.bit"
103 -- into nested map and merge it
104 splitSubdoms :: NmcDom -> NmcDom
107 base' = base { domMap = Nothing }
111 Just sdmap -> (emptyNmcDom { domMap = Just sdmap' }) `mergeNmcDom` base'
113 sdmap' = foldrWithKey stow empty sdmap
114 stow fqdn sdom acc = insertWith mergeNmcDom fqdn' sdom' acc
117 nest (map unpack (splitOn (pack ".") (pack fqdn)), sdom)
118 nest ([], v) = (fqdn, v) -- can split result be empty?
119 nest ([k], v) = (k, v)
121 nest (ks, emptyNmcDom { domMap = Just (singleton k v) })
123 -- | Presence of some elements require removal of some others
124 normalizeDom :: NmcDom -> NmcDom
125 normalizeDom dom = foldr id dom [ translateNormalizer
129 nsNormalizer dom = case domNs dom of
131 Just ns -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
132 translateNormalizer dom = case domTranslate dom of
134 Just tr -> dom { domMap = Nothing }
136 -- | Merge imports and Selfs and follow the maps tree to get dom
138 (String -> IO (Either String ByteString)) -- ^ query operation action
139 -> [String] -- ^ subdomain chain
140 -> NmcDom -- ^ base domain
141 -> IO (Either String NmcDom) -- ^ fully processed result
142 descendNmcDom queryOp subdom base = do
143 base' <- mergeImport queryOp 10 base
145 [] -> return $ fmap normalizeDom base'
148 Left err -> return base'
150 case domMap base'' of
151 Nothing -> return $ Right emptyNmcDom
154 Nothing -> return $ Right emptyNmcDom
155 Just sub -> descendNmcDom queryOp ds sub
157 -- | Initial NmcDom populated with "import" only, suitable for "descend"
159 String -- ^ domain key (without namespace prefix)
160 -> NmcDom -- ^ resulting seed domain
161 seedNmcDom dn = emptyNmcDom { domImport = Just (["d/" ++ dn])}