wip move 'synthetic' parsing into NmcDom
authorEugene Crosser <crosser@average.org>
Thu, 1 May 2014 11:02:39 +0000 (15:02 +0400)
committerEugene Crosser <crosser@average.org>
Thu, 1 May 2014 11:02:39 +0000 (15:02 +0400)
NmcDom.hs
NmcTransform.hs
PowerDns.hs

index 1ccf836b9049b8bfe15aebbefda18d67bea4f233..98275f7d06c42c784c72551a16d12e514e62ba1c 100644 (file)
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -1,11 +1,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcDom   ( NmcDom(..)
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcDom   ( NmcDom(..)
-                , NmcRRService(..)
+                , NmcRRSrv(..)
                 , NmcRRI2p(..)
                 , NmcRRI2p(..)
-                , NmcRRTls(..)
+                , NmcRRTlsa(..)
                 , NmcRRDs(..)
                 , NmcRRDs(..)
-                , mergeNmcDom
+                , merge
                 ) where
 
 import Prelude hiding (length)
                 ) where
 
 import Prelude hiding (length)
@@ -34,6 +34,20 @@ obj .:/ key = case H.lookup key obj of
                         String s -> parseJSON $ Array (singleton v)
                         _        -> parseJSON v
 
                         String s -> parseJSON $ Array (singleton v)
                         _        -> parseJSON v
 
+makeMx :: Object -> Parser (Maybe [String])
+makeMx o = return Nothing -- FIXME
+{-
+  case H.lookup "service" o of
+    Nothing          -> pure Nothing
+    Just (Array saa) -> return $ Just $ fmap mxStr $ filter mxMatch saa
+      where
+        mxMatch sa = (sa ! 0) == "smtp" && (sa ! 1) == "tcp" && (sa ! 4) == 25
+        mxStr sa = (sa ! 2) ++ "\t" ++ (sa ! 5)
+    _                -> empty
+-}
+makeSubmap :: Object -> Parser (Maybe (Map String NmcDom))
+makeSubmap o = o .:? "map" -- FIXME
+
 class Mergeable a where
         merge :: a -> a -> a -- bias towads second arg
 
 class Mergeable a where
         merge :: a -> a -> a -- bias towads second arg
 
@@ -56,28 +70,14 @@ instance Mergeable a => Mergeable (Maybe a) where
 instance Eq a => Mergeable [a] where
         merge xs ys = union xs ys
 
 instance Eq a => Mergeable [a] where
         merge xs ys = union xs ys
 
-data NmcRRService = NmcRRService
-                        { srvName       :: String
-                        , srvProto      :: String
-                        , srvPrio       :: Int
+data NmcRRSrv = NmcRRSrv
+                        { srvPrio       :: Int
                         , srvWeight     :: Int
                         , srvPort       :: Int
                         , srvHost       :: String
                         } deriving (Show, Eq)
 
                         , srvWeight     :: Int
                         , srvPort       :: Int
                         , srvHost       :: String
                         } deriving (Show, Eq)
 
-instance FromJSON NmcRRService where
-        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
-
-instance Mergeable NmcRRService where
+instance Mergeable NmcRRSrv where
         merge _ b = b
 
 data NmcRRI2p = NmcRRI2p
         merge _ b = b
 
 data NmcRRI2p = NmcRRI2p
@@ -96,22 +96,13 @@ instance FromJSON NmcRRI2p where
 instance Mergeable NmcRRI2p where
         merge _ b = b
 
 instance Mergeable NmcRRI2p where
         merge _ b = b
 
-data NmcRRTls = NmcRRTls
+data NmcRRTlsa = NmcRRTlsa
                         { tlsMatchType  :: Int -- 0:exact 1:sha256 2:sha512
                         , tlsMatchValue :: String
                         , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
                         } deriving (Show, Eq)
 
                         { tlsMatchType  :: Int -- 0:exact 1:sha256 2:sha512
                         , tlsMatchValue :: String
                         , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
                         } deriving (Show, Eq)
 
-instance FromJSON NmcRRTls where
-        parseJSON (Array a) =
-                if length a == 3 then NmcRRTls
-                        <$> parseJSON (a ! 0)
-                        <*> parseJSON (a ! 1)
-                        <*> parseJSON (a ! 2)
-                else empty
-        parseJSON _ = empty
-
-instance Mergeable NmcRRTls where
+instance Mergeable NmcRRTlsa where
         merge _ b = b
 
 data NmcRRDs = NmcRRDs
         merge _ b = b
 
 data NmcRRDs = NmcRRDs
@@ -134,8 +125,7 @@ instance FromJSON NmcRRDs where
 instance Mergeable NmcRRDs where
         merge _ b = b
 
 instance Mergeable NmcRRDs where
         merge _ b = b
 
-data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
-                        , domIp          :: Maybe [String]
+data NmcDom = NmcDom    { domIp          :: Maybe [String]
                         , domIp6         :: Maybe [String]
                         , domTor         :: Maybe String
                         , domI2p         :: Maybe NmcRRI2p
                         , domIp6         :: Maybe [String]
                         , domTor         :: Maybe String
                         , domI2p         :: Maybe NmcRRI2p
@@ -148,20 +138,18 @@ data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
                         , domNs          :: Maybe [String]
                         , domDelegate    :: Maybe String
                         , domImport      :: Maybe [String]
                         , domNs          :: Maybe [String]
                         , domDelegate    :: Maybe String
                         , domImport      :: Maybe [String]
-                        , domMap         :: Maybe (Map String NmcDom)
+                        , domSubmap      :: Maybe (Map String NmcDom)
                         , domFingerprint :: Maybe [String]
                         , domFingerprint :: Maybe [String]
-                        , domTls         :: Maybe (Map String
-                                                    (Map String [NmcRRTls]))
                         , domDs          :: Maybe [NmcRRDs]
                         , domDs          :: Maybe [NmcRRDs]
-                        , domMx          :: Maybe [String] -- Synthetic
-                        , domSrv         :: Maybe [String] -- Synthetic
-                        , domTlsa        :: Maybe [String] -- Synthetic
+                        , domMx          :: Maybe [String]    -- Synthetic
+                        , domSrv         :: Maybe [NmcRRSrv]  -- Synthetic
+                        , domTlsa        :: Maybe [NmcRRTlsa] -- Synthetic
                         } deriving (Show, Eq)
 
 instance Default NmcDom where
   def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
                Nothing Nothing Nothing Nothing Nothing Nothing Nothing
                         } deriving (Show, Eq)
 
 instance Default NmcDom where
   def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
                Nothing Nothing Nothing Nothing Nothing Nothing Nothing
-               Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+               Nothing Nothing Nothing Nothing Nothing
 
 instance FromJSON NmcDom where
         -- Wherever we expect a domain object, there may be a string
 
 instance FromJSON NmcDom where
         -- Wherever we expect a domain object, there may be a string
@@ -178,8 +166,7 @@ instance FromJSON NmcDom where
                               if all isDigit x then (read x :: Int) < 256
                               else False
         parseJSON (Object o) = NmcDom
                               if all isDigit x then (read x :: Int) < 256
                               else False
         parseJSON (Object o) = NmcDom
-                <$> o .:? "service"
-                <*> o .:/ "ip"
+                <$> o .:/ "ip"
                 <*> o .:/ "ip6"
                 <*> o .:? "tor"
                 <*> o .:? "i2p"
                 <*> o .:/ "ip6"
                 <*> o .:? "tor"
                 <*> o .:? "i2p"
@@ -192,18 +179,16 @@ instance FromJSON NmcDom where
                 <*> o .:/ "ns"
                 <*> o .:? "delegate"
                 <*> o .:/ "import"
                 <*> o .:/ "ns"
                 <*> o .:? "delegate"
                 <*> o .:/ "import"
-                <*> o .:? "map"
+                <*> makeSubmap o
                 <*> o .:/ "fingerprint"
                 <*> o .:/ "fingerprint"
-                <*> o .:? "tls"
                 <*> o .:? "ds"
                 <*> o .:? "ds"
-                <*> return Nothing -- domMx not parsed
-                <*> return Nothing -- domSrv not parsed
-                <*> return Nothing -- domTlsa not parsed
+                <*> makeMx o
+                <*> return Nothing -- domSrv created in subdomains
+                <*> return Nothing -- domTlsa created in subdomains
         parseJSON _ = empty
 
 instance Mergeable NmcDom where
         parseJSON _ = empty
 
 instance Mergeable NmcDom where
-        merge sub dom = dom     { domService =     mergelm domService
-                                , domIp =          mergelm domIp
+        merge sub dom = dom     { domIp =          mergelm domIp
                                 , domIp6 =         mergelm domIp6
                                 , domTor =         choose  domTor
                                 , domI2p =         mergelm domI2p
                                 , domIp6 =         mergelm domIp6
                                 , domTor =         choose  domTor
                                 , domI2p =         mergelm domI2p
@@ -216,9 +201,8 @@ instance Mergeable NmcDom where
                                 , domNs =          mergelm domNs
                                 , domDelegate =    mergelm domDelegate
                                 , domImport =      mergelm domImport
                                 , domNs =          mergelm domNs
                                 , domDelegate =    mergelm domDelegate
                                 , domImport =      mergelm domImport
-                                , domMap =         mergelm domMap
+                                , domSubmap =      mergelm domSubmap
                                 , domFingerprint = mergelm domFingerprint
                                 , domFingerprint = mergelm domFingerprint
-                                , domTls =         mergelm domTls
                                 , domDs =          mergelm domDs
                                 , domMx =          mergelm domMx
                                 , domSrv =         mergelm domSrv
                                 , domDs =          mergelm domDs
                                 , domMx =          mergelm domMx
                                 , domSrv =         mergelm domSrv
@@ -232,6 +216,3 @@ instance Mergeable NmcDom where
                 choose field = case field dom of
                         Nothing -> field sub
                         Just x  -> Just x
                 choose field = case field dom of
                         Nothing -> field sub
                         Just x  -> Just x
-
-mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
-mergeNmcDom = merge
index cf93db38f7793bb7725d51e2b44573cfce7a4197..858acf7de0e6c58229ad7a357e8bb273d66386f4 100644 (file)
@@ -39,7 +39,7 @@ mergeIncl ::
   -> IO (Either String NmcDom)              -- ^ result with merged import
 mergeIncl queryOp depth base = do
   let
   -> IO (Either String NmcDom)              -- ^ result with merged import
 mergeIncl queryOp depth base = do
   let
-    mbase = (expandSrv . splitSubdoms . mergeSelf) base
+    mbase = ({-expandSrv .-} splitSubdoms . mergeSelf) base
     base' = mbase {domDelegate = Nothing, domImport = Nothing}
   -- print base
   if depth <= 0 then return $ Left "Nesting of imports is too deep"
     base' = mbase {domDelegate = Nothing, domImport = Nothing}
   -- print base
   if depth <= 0 then return $ Left "Nesting of imports is too deep"
@@ -53,15 +53,15 @@ mergeIncl queryOp depth base = do
       sub <- queryNmcDom queryOp key
       case sub of
         Left  err  -> return $ Left err
       sub <- queryNmcDom queryOp key
       case sub of
         Left  err  -> return $ Left err
-        Right sub' -> mergeIncl queryOp (depth - 1) $ sub' `mergeNmcDom` acc
+        Right sub' -> mergeIncl queryOp (depth - 1) $ sub' `merge` acc
 
 -- | 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
 
 -- | 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}
+    map   = domSubmap base
+    base' = base {domSubmap = removeSelf map}
     removeSelf Nothing    = Nothing
     removeSelf (Just map) = if size map' == 0 then Nothing else Just map'
       where map' = delete "" map
     removeSelf Nothing    = Nothing
     removeSelf (Just map) = if size map' == 0 then Nothing else Just map'
       where map' = delete "" map
@@ -71,9 +71,9 @@ mergeSelf base =
       Just map' ->
         case lookup "" map' of
           Nothing  -> base'
       Just map' ->
         case lookup "" map' of
           Nothing  -> base'
-          Just sub -> (mergeSelf sub) `mergeNmcDom` base'
+          Just sub -> (mergeSelf sub) `merge` base'
         -- recursion depth limited by the size of the record
         -- recursion depth limited by the size of the record
-
+{-
 -- | replace Service with Srv down in the Map
 expandSrv :: NmcDom -> NmcDom
 expandSrv base =
 -- | replace Service with Srv down in the Map
 expandSrv :: NmcDom -> NmcDom
 expandSrv base =
@@ -84,11 +84,11 @@ expandSrv base =
       Nothing -> base'
       Just sl -> foldr addSrvMx base' sl
         where
       Nothing -> base'
       Just sl -> foldr addSrvMx base' sl
         where
-          addSrvMx sr acc = sub1 `mergeNmcDom` acc
+          addSrvMx sr acc = sub1 `merge` acc
             where
             where
-              sub1 = def { domMap = Just (singleton proto sub2)
+              sub1 = def { domSubmap = Just (singleton proto sub2)
                                  , domMx = maybemx}
                                  , domMx = maybemx}
-              sub2 = def { domMap = Just (singleton srvid sub3) }
+              sub2 = def { domSubmap = Just (singleton srvid sub3) }
               sub3 = def { domSrv = Just [srvStr] }
               proto = "_" ++ (srvProto sr)
               srvid = "_" ++ (srvName sr)
               sub3 = def { domSrv = Just [srvStr] }
               proto = "_" ++ (srvProto sr)
               srvid = "_" ++ (srvName sr)
@@ -102,20 +102,20 @@ expandSrv base =
                    && srvPort sr == 25
                 then Just [(show (srvPrio sr)) ++ "\t" ++ (srvHost sr)]
                 else Nothing
                    && srvPort sr == 25
                 then Just [(show (srvPrio sr)) ++ "\t" ++ (srvHost sr)]
                 else Nothing
-
+-}
 -- | Convert map elements of the form "subN...sub2.sub1.dom.bit"
 --   into nested map and merge it
 splitSubdoms :: NmcDom -> NmcDom
 splitSubdoms base =
   let
 -- | Convert map elements of the form "subN...sub2.sub1.dom.bit"
 --   into nested map and merge it
 splitSubdoms :: NmcDom -> NmcDom
 splitSubdoms base =
   let
-    base' = base { domMap = Nothing }
+    base' = base { domSubmap = Nothing }
   in
   in
-    case domMap base of
+    case domSubmap base of
       Nothing -> base'
       Nothing -> base'
-      Just sdmap -> (def { domMap = Just sdmap' }) `mergeNmcDom` base'
+      Just sdmap -> (def { domSubmap = Just sdmap' }) `merge` base'
         where
           sdmap' = foldrWithKey stow empty sdmap
         where
           sdmap' = foldrWithKey stow empty sdmap
-          stow fqdn sdom acc = insertWith mergeNmcDom fqdn' sdom' acc
+          stow fqdn sdom acc = insertWith merge fqdn' sdom' acc
             where
               (fqdn', sdom') =
                 nest (filter (/= "") (splitOnDots fqdn), sdom)
             where
               (fqdn', sdom') =
                 nest (filter (/= "") (splitOnDots fqdn), sdom)
@@ -123,7 +123,7 @@ splitSubdoms base =
               nest ([], v)   = (fqdn, v) -- can split result be empty?
               nest ([k], v)  = (k, v)
               nest (k:ks, v) =
               nest ([], v)   = (fqdn, v) -- can split result be empty?
               nest ([k], v)  = (k, v)
               nest (k:ks, v) =
-                nest (ks, def { domMap = Just (singleton k v) })
+                nest (ks, def { domSubmap = Just (singleton k v) })
 
 -- | transfer some elements of `base` into `sub`, notably TLSA
 propagate :: NmcDom -> NmcDom -> NmcDom
 
 -- | transfer some elements of `base` into `sub`, notably TLSA
 propagate :: NmcDom -> NmcDom -> NmcDom
@@ -140,7 +140,7 @@ normalizeDom dom = foldr id dom [ translateNormalizer
       Just ns  -> def { domNs = domNs dom, domEmail = domEmail dom }
     translateNormalizer dom = case domTranslate dom of
       Nothing  -> dom
       Just ns  -> def { domNs = domNs dom, domEmail = domEmail dom }
     translateNormalizer dom = case domTranslate dom of
       Nothing  -> dom
-      Just tr  -> dom { domMap = Nothing }
+      Just tr  -> dom { domSubmap = Nothing }
 
 -- | Merge imports and Selfs and follow the maps tree to get dom
 descendNmcDom ::
 
 -- | Merge imports and Selfs and follow the maps tree to get dom
 descendNmcDom ::
@@ -156,7 +156,7 @@ descendNmcDom queryOp subdom base = do
       case base' of
         Left err     -> return base'
         Right base'' ->
       case base' of
         Left err     -> return base'
         Right base'' ->
-          case domMap base'' of
+          case domSubmap base'' of
             Nothing  -> return $ Right def
             Just map ->
               case lookup d map of
             Nothing  -> return $ Right def
             Just map ->
               case lookup d map of
index ef8211dfc373e6769eab671ee2b8d654bb331b47..606c5ca09f0e1644715810b4d259e528327e366b 100644 (file)
@@ -127,7 +127,7 @@ pdnsOutXfr ver id gen name edom =
              , RRTypeDS, RRTypeMX, RRTypeSOA
              ]
     walkDom f acc name dom =
              , RRTypeDS, RRTypeMX, RRTypeSOA
              ]
     walkDom f acc name dom =
-      f name dom $ case domMap dom of
+      f name dom $ case domSubmap dom of
         Nothing -> acc
         Just dm ->
           foldrWithKey (\n d a -> walkDom f a (n ++ "." ++ name) d) acc dm
         Nothing -> acc
         Just dm ->
           foldrWithKey (\n d a -> walkDom f a (n ++ "." ++ name) d) acc dm
@@ -165,9 +165,27 @@ dotmail addr =
     "" -> aname ++ "."
     _  -> aname ++ "." ++ (tail adom) ++ "."
 
     "" -> aname ++ "."
     _  -> aname ++ "." ++ (tail adom) ++ "."
 
-dataRR RRTypeSRV   = justl domSrv
+dataRR RRTypeSRV   = \ _ _ dom ->
+  case domSrv dom of
+    Nothing  -> []
+    Just srvs -> map srvStr srvs
+      where
+        srvStr x = (show (srvPrio x)) ++ "\t"
+                ++ (show (srvWeight x)) ++ " "
+                ++ (show (srvPort x)) ++ " "
+                ++ (srvHost x)
+    
 dataRR RRTypeMX    = justl domMx
 dataRR RRTypeMX    = justl domMx
-dataRR RRTypeTLSA  = justl domTlsa
+dataRR RRTypeTLSA  = \ _ _ dom ->
+  case domTlsa dom of
+    Nothing  -> []
+    Just tlsas -> map tlsaStr tlsas
+      where
+        tlsaStr x = "(3 0 "
+                 ++ (show (tlsMatchType x)) ++ " "
+                 ++ (tlsMatchValue x) ++ ")"
+        -- tlsIncSubdoms is not displayed, it is used for `propagate`.
+
 dataRR RRTypeA     = justl domIp
 dataRR RRTypeAAAA  = justl domIp6
 dataRR RRTypeCNAME = justv domAlias
 dataRR RRTypeA     = justl domIp
 dataRR RRTypeAAAA  = justl domIp6
 dataRR RRTypeCNAME = justv domAlias