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