Scrap the plan to verify valid proto/port
[pdns-pipe-nmc.git] / NmcTransform.hs
1 module NmcTransform ( seedNmcDom
2                     , descendNmcDom
3                     ) where
4
5 import Prelude hiding (lookup, null)
6 import Data.ByteString.Lazy (ByteString)
7 import Data.Map.Lazy (Map, empty, lookup, delete, null, singleton
8                      , foldrWithKey, insert, insertWith)
9 import Control.Monad (foldM)
10 import Data.Maybe (fromMaybe)
11 import Data.Aeson (decode)
12 import Data.Default.Class (def)
13
14 import NmcDom
15
16 -- | Perform query and return error string or parsed domain object
17 queryNmcDom ::
18   (String -> IO (Either String ByteString)) -- ^ query operation action
19   -> String                                 -- ^ key
20   -> IO (Either String NmcDom)              -- ^ error string or domain
21 queryNmcDom queryOp key = do
22   l <- queryOp key
23   case l of
24     Left estr -> return $ Left estr
25     Right str -> case decode str :: Maybe NmcDom of
26       Nothing  -> return $ Left $ "Unparseable value: " ++ (show str)
27       Just dom -> return $ Right dom
28
29 -- | Try to fetch "delegate" or "import" object and merge them into the
30 --   base domain. Original "import" element is removed, but newly
31 --   merged data may contain new "import" or "delegate", so the objects
32 --   that are about to be merged are processed recursively until there
33 --   are no more "import" and "deletage" attributes (or the depth gauge
34 --   reaches zero).
35 mergeIncl ::
36   (String -> IO (Either String ByteString)) -- ^ query operation action
37   -> Int                                    -- ^ recursion counter
38   -> NmcDom                                 -- ^ base domain
39   -> IO (Either String NmcDom)              -- ^ result with merged import
40 mergeIncl queryOp depth base = do
41   let
42     mbase = mergeSelf base
43     base' = mbase {domDelegate = Nothing, domImport = Nothing}
44   -- print base
45   if depth <= 0 then return $ Left "Nesting of imports is too deep"
46     else case ((domDelegate mbase), (domImport mbase)) of
47       (Nothing,  Nothing  ) -> return $ Right base'
48       (Nothing,  Just keys) -> foldM mergeIncl1 (Right base') keys
49       (Just key, _        ) -> mergeIncl1 (Right def) key
50   where
51     mergeIncl1 (Left  err) _   = return $ Left err -- can never happen
52     mergeIncl1 (Right acc) key = do
53       sub <- queryNmcDom queryOp key
54       case sub of
55         Left  err  -> return $ Left err
56         Right sub' -> mergeIncl queryOp (depth - 1) $ sub' `merge` acc
57
58 -- | If there is an element in the map with key "", merge the contents
59 --   and remove this element. Do this recursively.
60 mergeSelf :: NmcDom -> NmcDom
61 mergeSelf base =
62   let
63     map   = domSubmap base
64     base' = base {domSubmap = removeSelf map}
65     removeSelf Nothing    = Nothing
66     removeSelf (Just map) = if null map' then Nothing else Just map'
67       where map' = delete "" map
68   in
69     case map of
70       Nothing   -> base'
71       Just map' ->
72         case lookup "" map' of
73           Nothing  -> base'
74           Just sub -> (mergeSelf sub) `merge` base'
75         -- recursion depth limited by the size of the record
76
77 -- | transfer some elements of `base` into `sub`, notably TLSA
78 propagate :: NmcDom -> NmcDom -> NmcDom
79 propagate base sub = sub `merge` (pickglobals base)
80   where
81     pickglobals dom = fromMaybe def (siftsubmap (siftsubmap taketlsa) dom)
82     siftsubmap f dom =
83       let
84         sdmap = fromMaybe empty (domSubmap dom)
85         sdmap' = foldrWithKey (\k x -> addifjust k (f x)) empty sdmap
86         addifjust k mdom acc = case mdom of
87           Nothing  -> acc
88           Just dom -> insert k dom acc -- dups are impossible here
89       in
90         if null sdmap' then Nothing else Just $ def { domSubmap = Just sdmap'}
91     taketlsa dom = case domTlsa dom of
92       Nothing   -> Nothing
93       Just tlsa -> case filter (\x -> tlsIncSubdoms x) tlsa of
94         []    -> Nothing
95         tlsa' -> Just $ def { domTlsa = Just tlsa' }
96
97 -- | Presence of some elements require removal of some others
98 normalizeDom :: NmcDom -> NmcDom
99 normalizeDom dom = foldr id dom [ translateNormalizer
100                                 , nsNormalizer
101                                 ]
102   where
103     nsNormalizer dom = case domNs dom of
104       Nothing  -> dom
105       Just ns  -> def { domNs = domNs dom, domEmail = domEmail dom }
106     translateNormalizer dom = case domTranslate dom of
107       Nothing  -> dom
108       Just tr  -> dom { domSubmap = Nothing }
109
110 -- | Merge imports and Selfs and follow the maps tree to get dom
111 descendNmcDom ::
112   (String -> IO (Either String ByteString)) -- ^ query operation action
113   -> [String]                               -- ^ subdomain chain
114   -> NmcDom                                 -- ^ base domain
115   -> IO (Either String NmcDom)              -- ^ fully processed result
116 descendNmcDom queryOp subdom base = do
117   base' <- mergeIncl queryOp 10 base
118   case subdom of
119     []   -> return $ fmap normalizeDom base'
120     d:ds ->
121       case base' of
122         Left err     -> return base'
123         Right base'' ->
124           case domSubmap base'' of
125             Nothing  -> return $ Right def
126             Just map ->
127               case lookup d map of
128                 Nothing  -> return $ Right def
129                 Just sub -> descendNmcDom queryOp ds $ propagate base'' sub
130
131 -- | Initial NmcDom populated with "import" only, suitable for "descend"
132 seedNmcDom ::
133   String        -- ^ domain key (without namespace prefix)
134   -> NmcDom     -- ^ resulting seed domain
135 seedNmcDom dn = def { domImport = Just (["d/" ++ dn])}