-
-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
- , domIp = choose domIp
- , domIp6 = choose domIp6
- , domTor = choose domTor
- , domI2p = choose domI2p
- , domFreenet = choose domFreenet
- , domAlias = choose domAlias
- , domTranslate = choose domTranslate
- , domEmail = choose domEmail
- , domLoc = choose domLoc
- , domInfo = choose domInfo
- , domNs = choose domNs
- , domDelegate = choose domDelegate
- , domImport = choose domImport
- , domFingerprint = choose domFingerprint
- , domTls = choose domTls
- , domDs = choose domDs
- }
- where
- choose :: (NmcDom -> Maybe a) -> Maybe a
- 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
--- In case of errors they 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 ::
- (String -> IO (Either String ByteString)) -- ^ query operation action
- -> NmcDom -- ^ base domain
- -> IO NmcDom -- ^ result with merged import
-mergeImport queryOp base = do
- let base' = base {domImport = Nothing}
- -- print base'
- case domImport base of
- Nothing -> return base'
- Just key -> do
- sub <- queryNmcDom queryOp key
- case sub of
- Left e -> return base'
- Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base'