{-# LANGUAGE OverloadedStrings #-}
module NmcDom ( NmcDom(..)
- , NmcRRService(..)
+ , NmcRRSrv(..)
, NmcRRI2p(..)
- , NmcRRTls(..)
+ , NmcRRTlsa(..)
, NmcRRDs(..)
- , mergeNmcDom
+ , merge
) where
import Prelude hiding (length)
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
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)
-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
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)
-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
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
, domNs :: Maybe [String]
, domDelegate :: Maybe String
, domImport :: Maybe [String]
- , domMap :: Maybe (Map String NmcDom)
+ , domSubmap :: Maybe (Map String NmcDom)
, domFingerprint :: Maybe [String]
- , domTls :: Maybe (Map String
- (Map String [NmcRRTls]))
, 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
- 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
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 .:/ "ns"
<*> o .:? "delegate"
<*> o .:/ "import"
- <*> o .:? "map"
+ <*> makeSubmap o
<*> o .:/ "fingerprint"
- <*> o .:? "tls"
<*> 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
- 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
, domNs = mergelm domNs
, domDelegate = mergelm domDelegate
, domImport = mergelm domImport
- , domMap = mergelm domMap
+ , domSubmap = mergelm domSubmap
, domFingerprint = mergelm domFingerprint
- , domTls = mergelm domTls
, domDs = mergelm domDs
, domMx = mergelm domMx
, domSrv = mergelm domSrv
choose field = case field dom of
Nothing -> field sub
Just x -> Just x
-
-mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
-mergeNmcDom = merge
-> 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"
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
- 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
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
-
+{-
-- | replace Service with Srv down in the Map
expandSrv :: NmcDom -> NmcDom
expandSrv base =
Nothing -> base'
Just sl -> foldr addSrvMx base' sl
where
- addSrvMx sr acc = sub1 `mergeNmcDom` acc
+ addSrvMx sr acc = sub1 `merge` acc
where
- sub1 = def { domMap = Just (singleton proto sub2)
+ sub1 = def { domSubmap = Just (singleton proto sub2)
, 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)
&& 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
- base' = base { domMap = Nothing }
+ base' = base { domSubmap = Nothing }
in
- case domMap base of
+ case domSubmap base of
Nothing -> base'
- Just sdmap -> (def { domMap = Just sdmap' }) `mergeNmcDom` base'
+ Just sdmap -> (def { domSubmap = Just sdmap' }) `merge` base'
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)
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
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 ::
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
, 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
"" -> 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 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
projects / pdns-pipe-nmc.git / commitdiff