reimplement SRV handling

diff --git a/NmcDom.hs b/NmcDom.hs
index 90c7966064afe24cfba4321d405aed70f0535de6..8153a1dd7dad2d0b3128b455cf465bf0a93aa381 100644 (file)
--- 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 29c00087904d0228dccf42992a3676063f57f89c..c753f80165e9d71c7337cd3cd145af5fe772eca7 100644 (file)
--- 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 c465a16a3017f7fc3c43876953d81d048b8234b4..12768508d55c72a32e71c777e7b746f049149eaa 100644 (file)
--- 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 78de00ea2da83cc95d4e23a840c3e53781aeb7e7..bfb5934a0c872a1d8e1027a15564df463e05bbb4 100644 (file)
--- 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 6f98fc677359edce6dabda7fe631a640a19ff247..3a9f8b4e0c4c2c92d4858fbdafbaa9dbf547ff26 100644 (file)
--- 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