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])}