X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=NmcDom.hs;h=505c5436cfccd4de417f2ae77fca3bb583727639;hp=8153a1dd7dad2d0b3128b455cf465bf0a93aa381;hb=ea1648a0a1a63ef82c0159864e5efa4fc6297a1d;hpb=25e3fdd1a8580a4436088d3f66c14cfa321ad52f diff --git a/NmcDom.hs b/NmcDom.hs index 8153a1d..505c543 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -1,24 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} module NmcDom ( NmcDom(..) - , NmcRRService(..) + , NmcRRSrv(..) , NmcRRI2p(..) - , NmcRRTls(..) - , emptyNmcDom - , mergeNmcDom + , NmcRRTlsa(..) + , NmcRRDs(..) + , merge ) where import Prelude hiding (length) -import Control.Applicative ((<$>), (<*>), empty, pure) +import Control.Applicative ((<$>), (<*>), liftA2, empty, pure) import Data.Char import Data.Text (Text, unpack) import Data.List (union) import Data.List.Split -import Data.Vector ((!), length, singleton) -import Data.Map (Map, unionWith) -import qualified Data.HashMap.Strict as H (lookup) +import Data.Vector ((!), length) +import qualified Data.Vector as V (singleton) +import Data.Map (Map, unionWith, foldrWithKey) +import qualified Data.Map as M (singleton, empty, insert, insertWith) +import qualified Data.HashMap.Strict as H (lookup, foldrWithKey) import Data.Aeson import Data.Aeson.Types +import Data.Default.Class -- Variant of Aeson's `.:?` that interprets a String as a -- single-element list, so it is possible to have either @@ -30,9 +33,103 @@ import Data.Aeson.Types obj .:/ key = case H.lookup key obj of Nothing -> pure Nothing Just v -> case v of - String s -> parseJSON $ Array (singleton v) + String s -> parseJSON $ Array (V.singleton v) _ -> parseJSON v +data IntRRService = IntRRService { isvName :: String + , isvProto :: String + , isvPrio :: Int + , isvWeight :: Int + , isvPort :: Int + , isvHost :: String + } deriving (Show, Eq) + +instance FromJSON IntRRService where + parseJSON (Array a) = + if length a == 6 then IntRRService + <$> parseJSON (a ! 0) + <*> parseJSON (a ! 1) + <*> parseJSON (a ! 2) + <*> parseJSON (a ! 3) + <*> parseJSON (a ! 4) + <*> parseJSON (a ! 5) + else empty + parseJSON _ = empty + +makeMx :: Object -> Parser (Maybe [String]) +makeMx o = + case H.lookup "service" o of + Nothing -> pure Nothing + Just (Array a) -> do + isvl <- parseJSON (Array a) + return $ Just $ map mxStr $ filter mxMatch isvl + where + mxMatch isv = isvName isv == "smtp" + && isvProto isv == "tcp" + && isvPort isv == 25 + mxStr isv = (show (isvPrio isv)) ++ "\t" ++ (isvHost isv) + Just _ -> empty + +makeSubmap :: Object -> Parser (Maybe (Map String NmcDom)) +makeSubmap o = takeTls o `fmerge` takeSrv o `fmerge` takeMap o + where fmerge = liftA2 merge + +takeMap :: Object -> Parser (Maybe (Map String NmcDom)) +takeMap o = + case H.lookup "map" o of + Nothing -> pure Nothing + Just (Object mo) -> H.foldrWithKey addmapentry (pure (Just M.empty)) mo + where + addmapentry "" v acc = parseJSON v >>= inject acc "" + addmapentry k v acc = nest (splitOn "." (unpack k)) v acc + nest [] v acc = empty -- does not happen as a result of splitOn + nest [""] v acc = empty -- empty element of fqdn forbidden + nest [d] v acc = parseJSON v >>= inject acc d + nest (d:ds) v acc = + nest ds v acc >>= (inject acc d) . (\r -> def { domSubmap = r }) + inject acc d r = (fmap.fmap) (M.insertWith merge d r) acc + _ -> empty + +takeSrv :: Object -> Parser (Maybe (Map String NmcDom)) +takeSrv o = + case H.lookup "service" o of + Nothing -> pure Nothing + Just (Array a) -> do + isvl <- parseJSON (Array a) + return $ foldr addSrv (Just M.empty) isvl + where + addSrv isv acc = subm `merge` acc + where + subm = Just (M.singleton ("_" ++ isvProto isv) sub2) + sub2 = def { domSubmap = + Just (M.singleton ("_" ++ isvName isv) sub3) } + sub3 = def { domSrv = Just [ NmcRRSrv (isvPrio isv) + (isvWeight isv) + (isvPort isv) + (isvHost isv) ] } + Just _ -> empty + +-- takeTls is almost, but not quite, entirely unlike takeSrv +takeTls :: Object -> Parser (Maybe (Map String NmcDom)) +takeTls o = + case H.lookup "tls" o of + Nothing -> pure Nothing + Just (Object t) -> + (parseJSON (Object t) :: Parser (Map String (Map String [NmcRRTlsa]))) + >>= tmap2dmap + where + tmap2dmap :: Map String (Map String [NmcRRTlsa]) + -> Parser (Maybe (Map String NmcDom)) + tmap2dmap m1 = return $ foldrWithKey addprotoelem (Just M.empty) m1 + addprotoelem k1 m2 acc = protoelem k1 m2 `merge` acc + protoelem k1 m2 = Just (M.singleton ("_" ++ k1) (pmap2dmap m2)) + pmap2dmap m2 = foldrWithKey addportelem def m2 + addportelem k2 v acc = portelem k2 v `merge` acc + portelem k2 v = + def { domSubmap = Just (M.singleton ("_" ++ k2) + def { domTlsa = Just v }) } + Just _ -> empty + class Mergeable a where merge :: a -> a -> a -- bias towads second arg @@ -55,62 +152,51 @@ instance Mergeable a => Mergeable (Maybe a) where 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 - { i2pDestination :: String - , i2pName :: String - , i2pB32 :: String + { i2pDestination :: Maybe String + , i2pName :: Maybe String + , i2pB32 :: Maybe String } deriving (Show, Eq) instance FromJSON NmcRRI2p where parseJSON (Object o) = NmcRRI2p - <$> o .: "destination" - <*> o .: "name" - <*> o .: "b32" + <$> o .:? "destination" + <*> o .:? "name" + <*> o .:? "b32" parseJSON _ = empty 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 + , tlsIncSubdoms :: Bool -- enforce on subdoms? } deriving (Show, Eq) -instance FromJSON NmcRRTls where +instance FromJSON NmcRRTlsa where parseJSON (Array a) = - if length a == 3 then NmcRRTls + if length a == 3 then NmcRRTlsa <$> parseJSON (a ! 0) <*> parseJSON (a ! 1) - <*> parseJSON (a ! 2) + <*> case (a ! 2) of + Number 0 -> return False + Number 1 -> return True + _ -> empty else empty parseJSON _ = empty -instance Mergeable NmcRRTls where +instance Mergeable NmcRRTlsa where merge _ b = b data NmcRRDs = NmcRRDs @@ -133,8 +219,7 @@ instance FromJSON NmcRRDs where 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 @@ -147,23 +232,27 @@ data NmcDom = NmcDom { domService :: Maybe [NmcRRService] , 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 + , 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 + instance FromJSON NmcDom where -- Wherever we expect a domain object, there may be a string -- containing IPv4 address. Interpret it as such. -- Question: shall we try to recognize IPv6 addresses too? parseJSON (String s) = return $ if isIPv4 s' - then emptyNmcDom { domIp = Just [s'] } - else emptyNmcDom + then def { domIp = Just [s'] } + else def where s' = unpack s isIPv4 x = all isNibble $ splitOn "." x @@ -171,8 +260,7 @@ instance FromJSON NmcDom where 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" @@ -185,17 +273,16 @@ instance FromJSON NmcDom where <*> 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 + <*> 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 @@ -208,12 +295,12 @@ instance Mergeable NmcDom where , 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 + , domTlsa = mergelm domTlsa } where mergelm x = merge (x sub) (x dom) @@ -223,11 +310,3 @@ instance Mergeable NmcDom where choose field = case field dom of Nothing -> field sub Just x -> Just x - -mergeNmcDom :: NmcDom -> NmcDom -> NmcDom -mergeNmcDom = merge - -emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing