From 25e3fdd1a8580a4436088d3f66c14cfa321ad52f Mon Sep 17 00:00:00 2001 From: Eugene Crosser Date: Wed, 16 Apr 2014 21:44:44 +0400 Subject: [PATCH] reimplement SRV handling --- NmcDom.hs | 5 ++++- NmcTransform.hs | 55 ++++++++++++++++++++++++++++--------------------- PowerDns.hs | 10 +-------- d/extra2 | 2 +- test.hs | 4 ++-- 5 files changed, 40 insertions(+), 36 deletions(-) diff --git a/NmcDom.hs b/NmcDom.hs index 90c7966..8153a1d 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -153,6 +153,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 @@ -189,6 +190,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 @@ -211,6 +213,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) @@ -227,4 +230,4 @@ mergeNmcDom = merge emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing + Nothing Nothing diff --git a/NmcTransform.hs b/NmcTransform.hs index 29c0008..c753f80 100644 --- a/NmcTransform.hs +++ b/NmcTransform.hs @@ -4,7 +4,7 @@ module NmcTransform ( seedNmcDom import Prelude hiding (lookup) import Data.ByteString.Lazy (ByteString) -import Data.Map (lookup, delete, size) +import Data.Map (empty, lookup, delete, size, singleton) import Control.Monad (foldM) import Data.Aeson (decode) @@ -33,7 +33,7 @@ mergeImport :: -> IO (Either String NmcDom) -- ^ result with merged import mergeImport queryOp depth base = do let - mbase = mergeSelf base + mbase = (expandSrv . mergeSelf) base base' = mbase {domImport = Nothing} -- print base if depth <= 0 then return $ Left "Nesting of imports is too deep" @@ -68,17 +68,38 @@ mergeSelf base = Just sub -> (mergeSelf sub) `mergeNmcDom` 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 - +-- | replace Service with Srv down in the Map +expandSrv :: NmcDom -> NmcDom +expandSrv base = + let + base' = base { domService = Nothing } + in + case domService base of + Nothing -> base' + Just sl -> foldr addSrvMx base' sl + where + addSrvMx sr acc = sub1 `mergeNmcDom` acc + where + sub1 = emptyNmcDom { domMap = Just (singleton proto sub2) + , domMx = maybemx} + sub2 = emptyNmcDom { domMap = Just (singleton srvid sub3) } + sub3 = emptyNmcDom { domSrv = Just [srvStr] } + proto = "_" ++ (srvProto sr) + srvid = "_" ++ (srvName sr) + srvStr = (show (srvPrio sr)) ++ " " + ++ (show (srvWeight sr)) ++ " " + ++ (show (srvPort sr)) ++ " " + ++ (srvHost sr) + maybemx = + if srvName sr == "smtp" + && srvProto sr == "tcp" + && srvPort sr == 25 + then Just [(show (srvPrio sr)) ++ " " ++ (srvHost sr)] + else Nothing + -- | Presence of some elements require removal of some others normalizeDom :: NmcDom -> NmcDom -normalizeDom dom = foldr id dom [ srvNormalizer - , translateNormalizer +normalizeDom dom = foldr id dom [ translateNormalizer , nsNormalizer ] where @@ -88,16 +109,6 @@ normalizeDom dom = foldr id dom [ srvNormalizer 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 :: @@ -109,8 +120,6 @@ 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' diff --git a/PowerDns.hs b/PowerDns.hs index c465a16..1276850 100644 --- a/PowerDns.hs +++ b/PowerDns.hs @@ -86,7 +86,7 @@ pdnsOut ver id name rrtype edom = case edom of foldr (\r accum -> (n2p r) ++ accum) [] [RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME, RRTypeDNAME, RRTypeSOA, RRTypeRP, RRTypeLOC, RRTypeNS, RRTypeDS, RRTypeMX] - n2p RRTypeSRV = makesrv "SRV" $ domService dom + n2p RRTypeSRV = mapto "SRV" $ domSrv dom n2p RRTypeMX = mapto "MX" $ domMx dom n2p RRTypeA = mapto "A" $ domIp dom n2p RRTypeAAAA = mapto "AAAA" $ domIp6 dom @@ -115,11 +115,3 @@ pdnsOut ver id name rrtype edom = case edom of takejust rrstr maybestr = case maybestr of Nothing -> [] Just str -> [(name, rrstr, str)] - makesrv rrstr mayberl = case mayberl of - Nothing -> [] - Just srl -> map (\x -> (name, rrstr, fmtsrv x)) srl - where - fmtsrv rl = (show (srvPrio rl)) ++ " " - ++ (show (srvWeight rl)) ++ " " - ++ (show (srvPort rl)) ++ " " - ++ (srvHost rl) diff --git a/d/extra2 b/d/extra2 index 78de00e..bfb5934 100644 --- a/d/extra2 +++ b/d/extra2 @@ -1 +1 @@ -{"ip":["5.6.7.8"],"alias":"extra2alias","service":[["imap", "tcp", 0, 0, 143, "mail.host.com."]],"map":{"ftp":"2.2.2.2","www":"2.2.2.2"}} +{"ip":["5.6.7.8"],"alias":"extra2alias","service":[["imap", "tcp", 0, 0, 143, "mail.host.com."],["sip","udp",0,0,5060,"sip.telephony.com."]],"map":{"ftp":"2.2.2.2","www":"2.2.2.2"}} diff --git a/test.hs b/test.hs index 6f98fc6..3a9f8b4 100644 --- a/test.hs +++ b/test.hs @@ -8,6 +8,7 @@ import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy.Char8 (readFile) import System.IO.Error import Control.Exception +import Text.Show.Pretty import NmcDom import NmcTransform @@ -18,6 +19,5 @@ queryOp key = catch (readFile key >>= return . Right) main = do (d:_) <- getArgs - descendNmcDom queryOp [] (seedNmcDom d) >>= print - descendNmcDom queryOp ["_tcp","_smtp"] (seedNmcDom d) >>= print + descendNmcDom queryOp [] (seedNmcDom d) >>= putStrLn . ppShow -- 2.43.0