X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=NmcDom.hs;h=03eeb98582275db94d2554b48fb4d4a80bb15cf6;hp=b975522095ef4416ab79741f621c381ae250e1fa;hb=fbe7735ec10867611bc9d202fce4336c36c8af66;hpb=35cea210f8d3a22afd24848441b5d34702d83239 diff --git a/NmcDom.hs b/NmcDom.hs index b975522..03eeb98 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -2,14 +2,15 @@ module NmcDom ( NmcDom(..) , emptyNmcDom - , descendNmc + , seedNmcDom + , descendNmcDom ) where import Data.ByteString.Lazy (ByteString) -import Data.Text as T (unpack) +import qualified Data.Text as T (unpack) import Data.List.Split import Data.Char -import Data.Map as M (Map, lookup) +import Data.Map as M (Map, lookup, delete, size) import Control.Applicative ((<$>), (<*>), empty) import Data.Aeson @@ -58,7 +59,7 @@ data NmcDom = NmcDom { domService :: Maybe [[String]] -- [NmcRRService] , domInfo :: Maybe Value , domNs :: Maybe [String] , domDelegate :: Maybe [String] - , domImport :: Maybe [[String]] + , domImport :: Maybe String , domMap :: Maybe (Map String NmcDom) , domFingerprint :: Maybe [String] , domTls :: Maybe (Map String @@ -105,37 +106,9 @@ emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing -normalizeDom :: NmcDom -> NmcDom -normalizeDom dom - | domNs dom /= Nothing = emptyNmcDom { domNs = domNs dom - , domEmail = domEmail dom - } - | domDelegate dom /= Nothing = emptyNmcDom -- FIXME - | domTranslate dom /= Nothing = dom { domMap = Nothing } - | otherwise = dom - -descendNmc :: [String] -> NmcDom -> NmcDom -descendNmc subdom rawdom = - let dom = normalizeDom rawdom - in case subdom of - [] -> - case domMap dom of - Nothing -> dom - Just map -> - case M.lookup "" map of -- Stupid, but there are "" in the map - Nothing -> dom -- Try to merge it with the root data - Just sub -> mergeNmc sub dom -- Or maybe drop it altogether... - d:ds -> - case domMap dom of - Nothing -> emptyNmcDom - Just map -> - case M.lookup d map of - Nothing -> emptyNmcDom - Just sub -> descendNmc ds sub - -- FIXME -- I hope there exists a better way to merge records! -mergeNmc :: NmcDom -> NmcDom -> NmcDom -mergeNmc sub dom = dom { domService = choose domService +mergeNmcDom :: NmcDom -> NmcDom -> NmcDom +mergeNmcDom sub dom = dom { domService = choose domService , domIp = choose domIp , domIp6 = choose domIp6 , domTor = choose domTor @@ -149,6 +122,7 @@ mergeNmc sub dom = dom { domService = choose domService , domNs = choose domNs , domDelegate = choose domDelegate , domImport = choose domImport + , domMap = choose domMap , domFingerprint = choose domFingerprint , domTls = choose domTls , domDs = choose domDs @@ -158,3 +132,92 @@ mergeNmc sub dom = dom { domService = choose domService choose field = case field dom of Nothing -> field sub Just x -> Just x + +-- | 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 + -> NmcDom -- ^ base domain + -> IO (Either String NmcDom) -- ^ result with merged import +mergeImport queryOp base = do + let + mbase = mergeSelf base + base' = mbase {domImport = Nothing} + -- print base + case domImport mbase of + Nothing -> return $ Right base' + Just key -> do + sub <- queryNmcDom queryOp key + case sub of + Left e -> return $ Left e + Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base' + +-- | 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 + nbase = normalizeDom base + map = domMap nbase + base' = nbase {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) `mergeNmcDom` base' + +-- | Presence of some elements require removal of some others +normalizeDom :: NmcDom -> NmcDom +normalizeDom dom + | domNs dom /= Nothing = emptyNmcDom { domNs = domNs dom + , domEmail = domEmail dom + } + | domDelegate dom /= Nothing = emptyNmcDom -- FIXME + | domTranslate dom /= Nothing = dom { domMap = Nothing } + | otherwise = dom + +-- | 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 base + case subdom of + [] -> return 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)}