X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=NmcDom.hs;h=477def1b8b2418a7202b429d9cc864096fea9bd6;hp=e03f683bf2107166fe4bdca7ebfde45449f07888;hb=b32a00e89111ae2df516975162dd3fc1d9592e6f;hpb=936facf5d3c482bdd9b95ef9fd38f3595f9eb0f2 diff --git a/NmcDom.hs b/NmcDom.hs index e03f683..477def1 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -2,24 +2,23 @@ module NmcDom ( NmcDom(..) , NmcRRService(..) + , NmcRRI2p(..) + , NmcRRTls(..) + , NmcRRDs(..) , emptyNmcDom - , seedNmcDom - , descendNmcDom + , mergeNmcDom ) where import Prelude hiding (length) -import Data.ByteString.Lazy (ByteString) +import Control.Applicative ((<$>), (<*>), empty, pure) +import Data.Char import Data.Text (Text, unpack) -import Data.List as L (union) +import Data.List (union) import Data.List.Split -import Data.Char -import Data.Map as M (Map, lookup, delete, size, unionWith) -import Data.Vector (toList,(!),length, singleton) -import Control.Monad (foldM) -import Control.Applicative ((<$>), (<*>), empty, pure) +import Data.Vector ((!), length, singleton) +import Data.Map (Map, unionWith) +import qualified Data.HashMap.Strict as H (lookup) import Data.Aeson - -import qualified Data.HashMap.Strict as H import Data.Aeson.Types -- Variant of Aeson's `.:?` that interprets a String as a @@ -39,7 +38,7 @@ class Mergeable a where merge :: a -> a -> a -- bias towads second arg instance (Ord k, Mergeable a) => Mergeable (Map k a) where - merge mx my = M.unionWith merge my mx + merge mx my = unionWith merge my mx -- Alas, the following is not possible in Haskell :-( -- instance Mergeable String where @@ -55,7 +54,7 @@ instance Mergeable a => Mergeable (Maybe a) where merge Nothing Nothing = Nothing instance Eq a => Mergeable [a] where - merge xs ys = L.union xs ys + merge xs ys = union xs ys data NmcRRService = NmcRRService { srvName :: String @@ -155,6 +154,7 @@ data NmcDom = NmcDom { domService :: Maybe [NmcRRService] (Map String [NmcRRTls])) , domDs :: Maybe [NmcRRDs] , domMx :: Maybe [String] -- Synthetic + , domSrv :: Maybe [String] -- Synthetic } deriving (Show, Eq) instance FromJSON NmcDom where @@ -191,6 +191,7 @@ instance FromJSON NmcDom where <*> o .:? "tls" <*> o .:? "ds" <*> return Nothing -- domMx not parsed + <*> return Nothing -- domSrv not parsed parseJSON _ = empty instance Mergeable NmcDom where @@ -213,6 +214,7 @@ instance Mergeable NmcDom where , domTls = mergelm domTls , domDs = mergelm domDs , domMx = mergelm domMx + , domSrv = mergelm domSrv } where mergelm x = merge (x sub) (x dom) @@ -223,125 +225,10 @@ instance Mergeable NmcDom where Nothing -> field sub Just x -> Just x +mergeNmcDom :: NmcDom -> NmcDom -> NmcDom +mergeNmcDom = merge emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing - --- | Perform query and return error string or parsed domain object -queryNmcDom :: - (String -> IO (Either String ByteString)) -- ^ query operation action - -> String -- ^ key - -> IO (Either String NmcDom) -- ^ error string or domain -queryNmcDom queryOp key = do - l <- queryOp key - case l of - Left estr -> return $ Left estr - Right str -> case decode str :: Maybe NmcDom of - Nothing -> return $ Left $ "Unparseable value: " ++ (show str) - Just dom -> return $ Right dom - --- | Try to fetch "import" object and merge it into the base domain --- Original "import" element is removed, but new imports from the --- imported objects are processed recursively until there are none. -mergeImport :: - (String -> IO (Either String ByteString)) -- ^ query operation action - -> Int -- ^ recursion counter - -> NmcDom -- ^ base domain - -> IO (Either String NmcDom) -- ^ result with merged import -mergeImport queryOp depth base = do - let - mbase = mergeSelf base - base' = mbase {domImport = Nothing} - -- print base - if depth <= 0 then return $ Left "Nesting of imports is too deep" - else case domImport mbase of - Nothing -> return $ Right base' - Just keys -> foldM mergeImport1 (Right base') keys - where - mergeImport1 (Left err) _ = return $ Left err - mergeImport1 (Right acc) key = do - sub <- queryNmcDom queryOp key - case sub of - Left err -> return $ Left err - Right sub' -> mergeImport queryOp (depth - 1) $ sub' `merge` acc - --- | If there is an element in the map with key "", merge the contents --- and remove this element. Do this recursively. -mergeSelf :: NmcDom -> NmcDom -mergeSelf base = - let - map = domMap base - base' = base {domMap = removeSelf map} - removeSelf Nothing = Nothing - removeSelf (Just map) = if size map' == 0 then Nothing else Just map' - where map' = M.delete "" map - in - case map of - Nothing -> base' - Just map' -> - case M.lookup "" map' of - Nothing -> base' - Just sub -> (mergeSelf sub) `merge` base' - -- recursion depth limited by the size of the record - --- | SRV case - remove everyting and filter SRV records -normalizeSrv :: String -> String -> NmcDom -> NmcDom -normalizeSrv serv proto dom = - emptyNmcDom {domService = fmap (filter needed) (domService dom)} - where - needed r = srvName r == serv && srvProto r == proto - --- | Presence of some elements require removal of some others -normalizeDom :: NmcDom -> NmcDom -normalizeDom dom = foldr id dom [ srvNormalizer - , translateNormalizer - , nsNormalizer - ] - where - nsNormalizer dom = case domNs dom of - Nothing -> dom - Just ns -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom } - translateNormalizer dom = case domTranslate dom of - Nothing -> dom - Just tr -> dom { domMap = Nothing } - srvNormalizer dom = dom { domService = Nothing, domMx = makemx } - where - makemx = case domService dom of - Nothing -> Nothing - Just svl -> Just $ map makerec (filter needed svl) - where - needed sr = srvName sr == "smtp" - && srvProto sr == "tcp" - && srvPort sr == 25 - makerec sr = (show (srvPrio sr)) ++ " " ++ (srvHost sr) - --- | Merge imports and Selfs and follow the maps tree to get dom -descendNmcDom :: - (String -> IO (Either String ByteString)) -- ^ query operation action - -> [String] -- ^ subdomain chain - -> NmcDom -- ^ base domain - -> IO (Either String NmcDom) -- ^ fully processed result -descendNmcDom queryOp subdom base = do - base' <- mergeImport queryOp 10 base - case subdom of - [] -> return $ fmap normalizeDom base' - -- A hack to handle SRV records: don't descend if ["_prot","_serv"] - [('_':p),('_':s)] -> return $ fmap (normalizeSrv s p) base' - d:ds -> - case base' of - Left err -> return base' - Right base'' -> - case domMap base'' of - Nothing -> return $ Right emptyNmcDom - Just map -> - case M.lookup d map of - Nothing -> return $ Right emptyNmcDom - Just sub -> descendNmcDom queryOp ds sub - --- | Initial NmcDom populated with "import" only, suitable for "descend" -seedNmcDom :: - String -- ^ domain key (without namespace prefix) - -> NmcDom -- ^ resulting seed domain -seedNmcDom dn = emptyNmcDom { domImport = Just (["d/" ++ dn])} + Nothing Nothing