X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=NmcDom.hs;h=e03f683bf2107166fe4bdca7ebfde45449f07888;hp=adb378999a064e81ce759d9b3d3e7c61a0dd34a0;hb=936facf5d3c482bdd9b95ef9fd38f3595f9eb0f2;hpb=e5636bafe23f4515a7a104bde8d2664d084f8cee

diff --git a/NmcDom.hs b/NmcDom.hs
index adb3789..e03f683 100644
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -13,8 +13,9 @@ import Data.Text (Text, unpack)
 import Data.List as L (union)
 import Data.List.Split
 import Data.Char
-import Data.Map as M (Map, lookup, delete, size, union)
+import Data.Map as M (Map, lookup, delete, size, unionWith)
 import Data.Vector (toList,(!),length, singleton)
+import Control.Monad (foldM)
 import Control.Applicative ((<$>), (<*>), empty, pure)
 import Data.Aeson
 
@@ -37,9 +38,10 @@ obj .:/ key = case H.lookup key obj of
 class Mergeable a where
         merge :: a -> a -> a -- bias towads second arg
 
-instance Ord k => Mergeable (Map k a) where
-        merge mx my = M.union my mx
+instance (Ord k, Mergeable a) => Mergeable (Map k a) where
+        merge mx my = M.unionWith merge my mx
 
+-- Alas, the following is not possible in Haskell :-(
 -- instance Mergeable String where
 --         merge _ b = b
 
@@ -95,6 +97,44 @@ instance FromJSON NmcRRI2p where
 instance Mergeable NmcRRI2p where
         merge _ b = b
 
+data NmcRRTls = NmcRRTls
+                        { 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
+        merge _ b = b
+
+data NmcRRDs = NmcRRDs
+                        { dsKeyTag      :: Int
+                        , dsAlgo        :: Int
+                        , dsHashType    :: Int
+                        , dsHashValue   :: String
+                        } deriving (Show, Eq)
+
+instance FromJSON NmcRRDs where
+        parseJSON (Array a) =
+                if length a == 4 then NmcRRDs
+                        <$> parseJSON (a ! 0)
+                        <*> parseJSON (a ! 1)
+                        <*> parseJSON (a ! 2)
+                        <*> parseJSON (a ! 3)
+                else empty
+        parseJSON _ = empty
+
+instance Mergeable NmcRRDs where
+        merge _ b = b
+
 data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
                         , domIp          :: Maybe [String]
                         , domIp6         :: Maybe [String]
@@ -108,12 +148,12 @@ data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
                         , domInfo        :: Maybe Value
                         , domNs          :: Maybe [String]
                         , domDelegate    :: Maybe String
-                        , domImport      :: Maybe String
+                        , domImport      :: Maybe [String]
                         , domMap         :: Maybe (Map String NmcDom)
                         , domFingerprint :: Maybe [String]
                         , domTls         :: Maybe (Map String
-                                                    (Map String [[String]]))
-                        , domDs          :: Maybe [[String]]
+                                                    (Map String [NmcRRTls]))
+                        , domDs          :: Maybe [NmcRRDs]
                         , domMx          :: Maybe [String] -- Synthetic
                         } deriving (Show, Eq)
 
@@ -145,7 +185,7 @@ instance FromJSON NmcDom where
                 <*> o .:? "info"
                 <*> o .:/ "ns"
                 <*> o .:? "delegate"
-                <*> o .:? "import"
+                <*> o .:/ "import"
                 <*> o .:? "map"
                 <*> o .:/ "fingerprint"
                 <*> o .:? "tls"
@@ -167,7 +207,7 @@ instance Mergeable NmcDom where
                                 , domInfo =        mergelm domInfo
                                 , domNs =          mergelm domNs
                                 , domDelegate =    mergelm domDelegate
-                                , domImport =      choose  domImport
+                                , domImport =      mergelm domImport
                                 , domMap =         mergelm domMap
                                 , domFingerprint = mergelm domFingerprint
                                 , domTls =         mergelm domTls
@@ -218,11 +258,14 @@ mergeImport queryOp depth base = do
   if depth <= 0 then return $ Left "Nesting of imports is too deep"
   else case domImport mbase of
     Nothing  -> return $ Right base'
-    Just key -> do
-      sub <- queryNmcDom queryOp key
-      case sub of
-        Left  e    -> return $ Left e
-        Right sub' -> mergeImport queryOp (depth - 1) $ sub' `merge` base'
+    Just keys -> foldM mergeImport1 (Right base') keys
+      where
+        mergeImport1 (Left  err) _   = return $ Left err
+        mergeImport1 (Right acc) key = do
+          sub <- queryNmcDom queryOp key
+          case sub of
+            Left  err  -> return $ Left err
+            Right sub' -> mergeImport 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.
@@ -301,4 +344,4 @@ descendNmcDom queryOp subdom base = do
 seedNmcDom ::
   String        -- ^ domain key (without namespace prefix)
   -> NmcDom     -- ^ resulting seed domain
-seedNmcDom dn = emptyNmcDom { domImport = Just ("d/" ++ dn)}
+seedNmcDom dn = emptyNmcDom { domImport = Just (["d/" ++ dn])}