wip move 'synthetic' parsing into NmcDom

diff --git a/NmcDom.hs b/NmcDom.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

diff --git a/NmcTransform.hs b/NmcTransform.hs
index cf93db38f7793bb7725d51e2b44573cfce7a4197..858acf7de0e6c58229ad7a357e8bb273d66386f4 100644 (file)
--- a/NmcTransform.hs
+++ b/NmcTransform.hs
@@ -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

diff --git a/PowerDns.hs b/PowerDns.hs
index ef8211dfc373e6769eab671ee2b8d654bb331b47..606c5ca09f0e1644715810b4d259e528327e366b 100644 (file)
--- a/PowerDns.hs
+++ b/PowerDns.hs
@@ -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