split NmcTransform from NmcDom
[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 (lookup, delete, size)
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 = 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 -- | SRV case - remove everyting and filter SRV records
72 normalizeSrv :: String -> String -> NmcDom -> NmcDom
73 normalizeSrv serv proto dom =
74   emptyNmcDom {domService = fmap (filter needed) (domService dom)}
75     where
76       needed r = srvName r == serv && srvProto r == proto
77
78 -- | Presence of some elements require removal of some others
79 normalizeDom :: NmcDom -> NmcDom
80 normalizeDom dom = foldr id dom [ srvNormalizer
81                                 , translateNormalizer
82                                 , nsNormalizer
83                                 ]
84   where
85     nsNormalizer dom = case domNs dom of
86       Nothing  -> dom
87       Just ns  -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
88     translateNormalizer dom = case domTranslate dom of
89       Nothing  -> dom
90       Just tr  -> dom { domMap = Nothing }
91     srvNormalizer dom = dom { domService = Nothing, domMx = makemx }
92       where
93         makemx = case domService dom of
94           Nothing  -> Nothing
95           Just svl -> Just $ map makerec (filter needed svl)
96             where
97               needed sr = srvName sr == "smtp"
98                         && srvProto sr == "tcp"
99                         && srvPort sr == 25
100               makerec sr = (show (srvPrio sr)) ++ " " ++ (srvHost sr)
101
102 -- | Merge imports and Selfs and follow the maps tree to get dom
103 descendNmcDom ::
104   (String -> IO (Either String ByteString)) -- ^ query operation action
105   -> [String]                               -- ^ subdomain chain
106   -> NmcDom                                 -- ^ base domain
107   -> IO (Either String NmcDom)              -- ^ fully processed result
108 descendNmcDom queryOp subdom base = do
109   base' <- mergeImport queryOp 10 base
110   case subdom of
111     []   -> return $ fmap normalizeDom base'
112     -- A hack to handle SRV records: don't descend if ["_prot","_serv"]
113     [('_':p),('_':s)] -> return $ fmap (normalizeSrv s p) base'
114     d:ds ->
115       case base' of
116         Left err     -> return base'
117         Right base'' ->
118           case domMap base'' of
119             Nothing  -> return $ Right emptyNmcDom
120             Just map ->
121               case lookup d map of
122                 Nothing  -> return $ Right emptyNmcDom
123                 Just sub -> descendNmcDom queryOp ds sub
124
125 -- | Initial NmcDom populated with "import" only, suitable for "descend"
126 seedNmcDom ::
127   String        -- ^ domain key (without namespace prefix)
128   -> NmcDom     -- ^ resulting seed domain
129 seedNmcDom dn = emptyNmcDom { domImport = Just (["d/" ++ dn])}