reimplement SRV handling
[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.Map (empty, lookup, delete, size, singleton)
8 import Control.Monad (foldM)
9 import Data.Aeson (decode)
10
11 import NmcDom
12
13 -- | Perform query and return error string or parsed domain object
14 queryNmcDom ::
15   (String -> IO (Either String ByteString)) -- ^ query operation action
16   -> String                                 -- ^ key
17   -> IO (Either String NmcDom)              -- ^ error string or domain
18 queryNmcDom queryOp key = do
19   l <- queryOp key
20   case l of
21     Left estr -> return $ Left estr
22     Right str -> case decode str :: Maybe NmcDom of
23       Nothing  -> return $ Left $ "Unparseable value: " ++ (show str)
24       Just dom -> return $ Right dom
25
26 -- | Try to fetch "import" object and merge it into the base domain
27 --   Original "import" element is removed, but new imports from the
28 --   imported objects are processed recursively until there are none.
29 mergeImport ::
30   (String -> IO (Either String ByteString)) -- ^ query operation action
31   -> Int                                    -- ^ recursion counter
32   -> NmcDom                                 -- ^ base domain
33   -> IO (Either String NmcDom)              -- ^ result with merged import
34 mergeImport queryOp depth base = do
35   let
36     mbase = (expandSrv . mergeSelf) base
37     base' = mbase {domImport = Nothing}
38   -- print base
39   if depth <= 0 then return $ Left "Nesting of imports is too deep"
40   else case domImport mbase of
41     Nothing  -> return $ Right base'
42     Just keys -> foldM mergeImport1 (Right base') keys
43       where
44         mergeImport1 (Left  err) _   = return $ Left err
45         mergeImport1 (Right acc) key = do
46           sub <- queryNmcDom queryOp key
47           case sub of
48             Left  err  -> return $ Left err
49             Right sub' -> mergeImport queryOp (depth - 1) $
50                                 sub' `mergeNmcDom` acc
51
52 -- | If there is an element in the map with key "", merge the contents
53 --   and remove this element. Do this recursively.
54 mergeSelf :: NmcDom -> NmcDom
55 mergeSelf base =
56   let
57     map   = domMap base
58     base' = base {domMap = removeSelf map}
59     removeSelf Nothing    = Nothing
60     removeSelf (Just map) = if size map' == 0 then Nothing else Just map'
61       where map' = delete "" map
62   in
63     case map of
64       Nothing   -> base'
65       Just map' ->
66         case lookup "" map' of
67           Nothing  -> base'
68           Just sub -> (mergeSelf sub) `mergeNmcDom` base'
69         -- recursion depth limited by the size of the record
70
71 -- | replace Service with Srv down in the Map
72 expandSrv :: NmcDom -> NmcDom
73 expandSrv base =
74   let
75     base' = base { domService = Nothing }
76   in
77     case domService base of
78       Nothing -> base'
79       Just sl -> foldr addSrvMx base' sl
80         where
81           addSrvMx sr acc = sub1 `mergeNmcDom` acc
82             where
83               sub1 = emptyNmcDom { domMap = Just (singleton proto sub2)
84                                  , domMx = maybemx}
85               sub2 = emptyNmcDom { domMap = Just (singleton srvid sub3) }
86               sub3 = emptyNmcDom { domSrv = Just [srvStr] }
87               proto = "_" ++ (srvProto sr)
88               srvid = "_" ++ (srvName sr)
89               srvStr =  (show (srvPrio sr)) ++ " "
90                      ++ (show (srvWeight sr)) ++ " "
91                      ++ (show (srvPort sr)) ++ " "
92                      ++ (srvHost sr)
93               maybemx =
94                 if srvName sr == "smtp"
95                    && srvProto sr == "tcp"
96                    && srvPort sr == 25
97                 then Just [(show (srvPrio sr)) ++ " " ++ (srvHost sr)]
98                 else Nothing
99  
100 -- | Presence of some elements require removal of some others
101 normalizeDom :: NmcDom -> NmcDom
102 normalizeDom dom = foldr id dom [ translateNormalizer
103                                 , nsNormalizer
104                                 ]
105   where
106     nsNormalizer dom = case domNs dom of
107       Nothing  -> dom
108       Just ns  -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
109     translateNormalizer dom = case domTranslate dom of
110       Nothing  -> dom
111       Just tr  -> dom { domMap = Nothing }
112
113 -- | Merge imports and Selfs and follow the maps tree to get dom
114 descendNmcDom ::
115   (String -> IO (Either String ByteString)) -- ^ query operation action
116   -> [String]                               -- ^ subdomain chain
117   -> NmcDom                                 -- ^ base domain
118   -> IO (Either String NmcDom)              -- ^ fully processed result
119 descendNmcDom queryOp subdom base = do
120   base' <- mergeImport queryOp 10 base
121   case subdom of
122     []   -> return $ fmap normalizeDom base'
123     d:ds ->
124       case base' of
125         Left err     -> return base'
126         Right base'' ->
127           case domMap base'' of
128             Nothing  -> return $ Right emptyNmcDom
129             Just map ->
130               case lookup d map of
131                 Nothing  -> return $ Right emptyNmcDom
132                 Just sub -> descendNmcDom queryOp ds sub
133
134 -- | Initial NmcDom populated with "import" only, suitable for "descend"
135 seedNmcDom ::
136   String        -- ^ domain key (without namespace prefix)
137   -> NmcDom     -- ^ resulting seed domain
138 seedNmcDom dn = emptyNmcDom { domImport = Just (["d/" ++ dn])}