From: Eugene Crosser Date: Sun, 30 Mar 2014 14:15:12 +0000 (+0400) Subject: implement descent and (ugly) merge X-Git-Tag: 0.9.0.0~106 X-Git-Url: http://average.org/gitweb/?a=commitdiff_plain;h=6970cec92480e5b3ab3d82d120f5877181fa8589;p=pdns-pipe-nmc.git implement descent and (ugly) merge --- diff --git a/NmcJson.hs b/NmcJson.hs index e69f4f4..1d8bc9c 100644 --- a/NmcJson.hs +++ b/NmcJson.hs @@ -3,10 +3,11 @@ module NmcJson ( NmcRes(..) , NmcDom(..) , emptyNmcDom + , descendNmc ) where import Data.ByteString.Lazy (ByteString) -import Data.Map (Map) +import Data.Map as M (Map, lookup) import Control.Applicative ((<$>), (<*>), empty) import Data.Aeson @@ -17,7 +18,7 @@ data NmcRRService = NmcRRService -- unused , srvW2 :: Int , srvPort :: Int , srvHost :: [String] - } deriving (Show) + } deriving (Show, Eq) instance FromJSON NmcRRService where parseJSON (Object o) = NmcRRService @@ -33,7 +34,7 @@ data NmcRRI2p = NmcRRI2p { i2pDestination :: String , i2pName :: String , i2pB32 :: String - } deriving (Show) + } deriving (Show, Eq) instance FromJSON NmcRRI2p where parseJSON (Object o) = NmcRRI2p @@ -61,7 +62,7 @@ data NmcDom = NmcDom { domService :: Maybe [[String]] -- [NmcRRService] , domTls :: Maybe (Map String (Map String [[String]])) , domDs :: Maybe [[String]] - } deriving (Show) + } deriving (Show, Eq) instance FromJSON NmcDom where parseJSON (Object o) = NmcDom @@ -103,3 +104,46 @@ instance FromJSON NmcRes where <*> o .: "address" <*> o .: "expires_in" parseJSON _ = empty + +descendNmc :: [String] -> NmcDom -> NmcDom +descendNmc subdom dom = case subdom of + [] -> + case domMap dom of + Nothing -> dom + Just map -> + case M.lookup "" map of -- Stupid, but "" is allowed in the map + Nothing -> dom -- Try to merge it with the root data + Just sub -> mergeNmc sub dom + 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 dom domService sub + , domIp = choose dom domIp sub + , domIp6 = choose dom domIp6 sub + , domTor = choose dom domTor sub + , domI2p = choose dom domI2p sub + , domFreenet = choose dom domFreenet sub + , domAlias = choose dom domAlias sub + , domTranslate = choose dom domTranslate sub + , domEmail = choose dom domEmail sub + , domLoc = choose dom domLoc sub + , domInfo = choose dom domInfo sub + , domNs = choose dom domNs sub + , domDelegate = choose dom domDelegate sub + , domImport = choose dom domImport sub + , domFingerprint = choose dom domFingerprint sub + , domTls = choose dom domTls sub + , domDs = choose dom domDs sub + } + where + choose :: NmcDom -> (NmcDom -> Maybe a) -> NmcDom -> Maybe a + choose sub t dom = case t dom of + Nothing -> t sub + Just x -> Just x diff --git a/PowerDns.hs b/PowerDns.hs index b9c8093..696b9b5 100644 --- a/PowerDns.hs +++ b/PowerDns.hs @@ -93,16 +93,17 @@ nmc2pdns name RRTypeAAAA dom = mapto name "AAAA" $ domIp6 dom nmc2pdns name RRTypeCNAME dom = takejust name "CNAME" $ domAlias dom nmc2pdns name RRTypeDNAME dom = takejust name "DNAME" $ domTranslate dom nmc2pdns name RRTypeSOA dom = - let - email = case domEmail dom of - Nothing -> "hostmaster." ++ name - Just addr -> - let (aname, adom) = break (== '@') addr - in case adom of - "" -> aname - _ -> aname ++ "." ++ (tail adom) - in - [(name, "SOA", email ++ " 99999999 10800 3600 604800 86400")] + if dom == emptyNmcDom then [] + else + let + email = case domEmail dom of + Nothing -> "hostmaster." ++ name + Just addr -> + let (aname, adom) = break (== '@') addr + in case adom of + "" -> aname + _ -> aname ++ "." ++ (tail adom) + in [(name, "SOA", email ++ " 99999999 10800 3600 604800 86400")] nmc2pdns name RRTypeRP dom = [] --FIXME nmc2pdns name RRTypeLOC dom = takejust name "LOC" $ domLoc dom nmc2pdns name RRTypeNS dom = mapto name "NS" $ domNs dom diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs index 82c320d..603ea98 100644 --- a/pdns-pipe-nmc.hs +++ b/pdns-pipe-nmc.hs @@ -55,8 +55,6 @@ qRsp rsp = -- NMC interface -descend subdom dom = dom --FIXME - queryNmc :: Manager -> Config -> String -> String -> IO (Either String NmcDom) queryNmc mgr cfg fqdn qid = do @@ -66,7 +64,7 @@ queryNmc mgr cfg fqdn qid = do httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr return $ case qRsp rsp of Left err -> Left err - Right dom -> Right $ descend xs dom + Right dom -> Right $ descendNmc xs dom _ -> return $ Left "Only \".bit\" domain is supported"