dc5f0ff1e7663ef444fad55d4829f59173b61999
[pdns-pipe-nmc.git] / NmcTransform.hs
1 module NmcTransform ( seedNmcDom
2                     , descendNmcDom
3                     ) where
4
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)
12
13 import NmcDom
14
15 -- | Perform query and return error string or parsed domain object
16 queryNmcDom ::
17   (String -> IO (Either String ByteString)) -- ^ query operation action
18   -> String                                 -- ^ key
19   -> IO (Either String NmcDom)              -- ^ error string or domain
20 queryNmcDom queryOp key = do
21   l <- queryOp key
22   case l of
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
27
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.
31 mergeImport ::
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
37   let
38     mbase = (expandSrv . splitSubdoms . mergeSelf) base
39     base' = mbase {domImport = Nothing}
40   -- print base
41   if depth <= 0 then return $ Left "Nesting of imports is too deep"
42   else case domImport mbase of
43     Nothing  -> return $ Right base'
44     Just keys -> foldM mergeImport1 (Right base') keys
45       where
46         mergeImport1 (Left  err) _   = return $ Left err
47         mergeImport1 (Right acc) key = do
48           sub <- queryNmcDom queryOp key
49           case sub of
50             Left  err  -> return $ Left err
51             Right sub' -> mergeImport queryOp (depth - 1) $
52                                 sub' `mergeNmcDom` acc
53
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
57 mergeSelf base =
58   let
59     map   = domMap base
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
64   in
65     case map of
66       Nothing   -> base'
67       Just map' ->
68         case lookup "" map' of
69           Nothing  -> base'
70           Just sub -> (mergeSelf sub) `mergeNmcDom` base'
71         -- recursion depth limited by the size of the record
72
73 -- | replace Service with Srv down in the Map
74 expandSrv :: NmcDom -> NmcDom
75 expandSrv base =
76   let
77     base' = base { domService = Nothing }
78   in
79     case domService base of
80       Nothing -> base'
81       Just sl -> foldr addSrvMx base' sl
82         where
83           addSrvMx sr acc = sub1 `mergeNmcDom` acc
84             where
85               sub1 = emptyNmcDom { domMap = Just (singleton proto sub2)
86                                  , domMx = maybemx}
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)) ++ " "
94                      ++ (srvHost sr)
95               maybemx =
96                 if srvName sr == "smtp"
97                    && srvProto sr == "tcp"
98                    && srvPort sr == 25
99                 then Just [(show (srvPrio sr)) ++ " " ++ (srvHost sr)]
100                 else Nothing
101
102 -- | Convert map elements of the form "subN...sub2.sub1.dom.bit"
103 --   into nested map and merge it
104 splitSubdoms :: NmcDom -> NmcDom
105 splitSubdoms base =
106   let
107     base' = base { domMap = Nothing }
108   in
109     case domMap base of
110       Nothing -> base'
111       Just sdmap -> (emptyNmcDom { domMap = Just sdmap' }) `mergeNmcDom` base'
112         where
113           sdmap' = foldrWithKey stow empty sdmap
114           stow fqdn sdom acc = insertWith mergeNmcDom fqdn' sdom' acc
115             where
116               (fqdn', sdom') =
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)
120               nest (k:ks, v) =
121                 nest (ks, emptyNmcDom { domMap = Just (singleton k v) })
122  
123 -- | Presence of some elements require removal of some others
124 normalizeDom :: NmcDom -> NmcDom
125 normalizeDom dom = foldr id dom [ translateNormalizer
126                                 , nsNormalizer
127                                 ]
128   where
129     nsNormalizer dom = case domNs dom of
130       Nothing  -> dom
131       Just ns  -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
132     translateNormalizer dom = case domTranslate dom of
133       Nothing  -> dom
134       Just tr  -> dom { domMap = Nothing }
135
136 -- | Merge imports and Selfs and follow the maps tree to get dom
137 descendNmcDom ::
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
144   case subdom of
145     []   -> return $ fmap normalizeDom base'
146     d:ds ->
147       case base' of
148         Left err     -> return base'
149         Right base'' ->
150           case domMap base'' of
151             Nothing  -> return $ Right emptyNmcDom
152             Just map ->
153               case lookup d map of
154                 Nothing  -> return $ Right emptyNmcDom
155                 Just sub -> descendNmcDom queryOp ds sub
156
157 -- | Initial NmcDom populated with "import" only, suitable for "descend"
158 seedNmcDom ::
159   String        -- ^ domain key (without namespace prefix)
160   -> NmcDom     -- ^ resulting seed domain
161 seedNmcDom dn = emptyNmcDom { domImport = Just (["d/" ++ dn])}