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
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
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]
, 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)
<*> o .:? "info"
<*> o .:/ "ns"
<*> o .:? "delegate"
- <*> o .:? "import"
+ <*> o .:/ "import"
<*> o .:? "map"
<*> o .:/ "fingerprint"
<*> o .:? "tls"
, domInfo = mergelm domInfo
, domNs = mergelm domNs
, domDelegate = mergelm domDelegate
- , domImport = choose domImport
+ , domImport = mergelm domImport
, domMap = mergelm domMap
, domFingerprint = mergelm domFingerprint
, domTls = mergelm domTls
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.
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])}