X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=NmcDom.hs;h=11b58dda3bdfd629467a7ba0c824c180b8ccd6ff;hp=25dd84fcc5d96e373e710cd06ef6ded854f9bb2a;hb=3a7ab2462416bb2e358f267630aa1a4e2acfdd5f;hpb=4525a07052ec3ad3fd7b094a4acf4e00201fbf9f diff --git a/NmcDom.hs b/NmcDom.hs index 25dd84f..11b58dd 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -2,38 +2,40 @@ module NmcDom ( NmcDom(..) , emptyNmcDom + , seedNmcDom , descendNmcDom - , queryNmcDom - , mergeImport ) where +import Prelude hiding (length) import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as L (pack) 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 Data.Vector (toList,(!),length) import Control.Applicative ((<$>), (<*>), empty) import Data.Aeson -data NmcRRService = NmcRRService -- unused +data NmcRRService = NmcRRService { srvName :: String , srvProto :: String , srvW1 :: Int , srvW2 :: Int , srvPort :: Int - , srvHost :: [String] + , srvHost :: String } deriving (Show, Eq) instance FromJSON NmcRRService where - parseJSON (Object o) = NmcRRService - <$> o .: "name" - <*> o .: "proto" - <*> o .: "w1" - <*> o .: "w2" - <*> o .: "port" - <*> o .: "host" - parseJSON _ = empty + parseJSON (Array a) = + if length a == 6 then NmcRRService + <$> parseJSON (a ! 0) + <*> parseJSON (a ! 1) + <*> parseJSON (a ! 2) + <*> parseJSON (a ! 3) + <*> parseJSON (a ! 4) + <*> parseJSON (a ! 5) + else empty + parseJSON _ = empty data NmcRRI2p = NmcRRI2p { i2pDestination :: String @@ -48,7 +50,7 @@ instance FromJSON NmcRRI2p where <*> o .: "b32" parseJSON _ = empty -data NmcDom = NmcDom { domService :: Maybe [[String]] -- [NmcRRService] +data NmcDom = NmcDom { domService :: Maybe [NmcRRService] , domIp :: Maybe [String] , domIp6 :: Maybe [String] , domTor :: Maybe String @@ -108,34 +110,6 @@ 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 - -descendNmcDom :: [String] -> NmcDom -> NmcDom -descendNmcDom 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 -> mergeNmcDom 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 -> descendNmcDom ds sub - -- FIXME -- I hope there exists a better way to merge records! mergeNmcDom :: NmcDom -> NmcDom -> NmcDom mergeNmcDom sub dom = dom { domService = choose domService @@ -152,6 +126,7 @@ mergeNmcDom 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 @@ -164,9 +139,9 @@ mergeNmcDom sub dom = dom { domService = choose domService -- | Perform query and return error string or parsed domain object queryNmcDom :: - (ByteString -> IO (Either String ByteString)) -- ^ query operation action - -> ByteString -- ^ key - -> IO (Either String NmcDom) -- ^ error string or domain + (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 @@ -176,20 +151,79 @@ queryNmcDom queryOp key = do Just dom -> return $ Right dom -- | Try to fetch "import" object and merge it into the base domain --- Any errors are ignored, and nothing is merged. -- Original "import" element is removed, but new imports from the -- imported objects are processed recursively until there are none. mergeImport :: - (ByteString -> IO (Either String ByteString)) -- ^ query operation action - -> NmcDom -- ^ base domain - -> IO NmcDom -- ^ result with merged import + (String -> IO (Either String ByteString)) -- ^ query operation action + -> NmcDom -- ^ base domain + -> IO (Either String NmcDom) -- ^ result with merged import mergeImport queryOp base = do - let base' = base {domImport = Nothing} - -- print base' - case domImport base of - Nothing -> return base' + let + mbase = mergeSelf base + base' = mbase {domImport = Nothing} + -- print base + case domImport mbase of + Nothing -> return $ Right base' Just key -> do - sub <- queryNmcDom queryOp (L.pack key) + sub <- queryNmcDom queryOp key case sub of - Left e -> return base' + 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 + 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) `mergeNmcDom` base' + +-- | Presence of some elements require removal of some others +normalizeDom :: NmcDom -> NmcDom +normalizeDom dom = foldr id dom [ translateNormalizer + -- , nsNormalizer -- FIXME retrun this + ] + 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 } + +-- | 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 $ fmap normalizeDom 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)}