X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=NmcDom.hs;h=505c5436cfccd4de417f2ae77fca3bb583727639;hp=731aa1cbb1f72b279377fc95f85bc22809fc6399;hb=ea1648a0a1a63ef82c0159864e5efa4fc6297a1d;hpb=749bf63c8755a574c336b7068d6dad47eeecd55e diff --git a/NmcDom.hs b/NmcDom.hs index 731aa1c..505c543 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -1,33 +1,52 @@ {-# LANGUAGE OverloadedStrings #-} module NmcDom ( NmcDom(..) - , emptyNmcDom - , seedNmcDom - , descendNmcDom + , NmcRRSrv(..) + , NmcRRI2p(..) + , NmcRRTlsa(..) + , NmcRRDs(..) + , merge ) where import Prelude hiding (length) -import Data.ByteString.Lazy (ByteString) -import qualified Data.Text as T (unpack) -import Data.List.Split +import Control.Applicative ((<$>), (<*>), liftA2, empty, pure) import Data.Char -import Data.Map as M (Map, lookup, delete, size) -import Data.Vector (toList,(!),length) -import Control.Applicative ((<$>), (<*>), empty) +import Data.Text (Text, unpack) +import Data.List (union) +import Data.List.Split +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 -data NmcRRService = NmcRRService - { srvName :: String - , srvProto :: String - , srvW1 :: Int - , srvW2 :: Int - , srvPort :: Int - , srvHost :: String - } deriving (Show, Eq) +-- Variant of Aeson's `.:?` that interprets a String as a +-- single-element list, so it is possible to have either +-- "ip":["1.2.3.4"] +-- or +-- "ip":"1.2.3.4" +-- with the same result. +(.:/) :: (FromJSON a) => Object -> Text -> Parser (Maybe a) +obj .:/ key = case H.lookup key obj of + Nothing -> pure Nothing + Just v -> case v of + 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 NmcRRService where +instance FromJSON IntRRService where parseJSON (Array a) = - if length a == 6 then NmcRRService + if length a == 6 then IntRRService <$> parseJSON (a ! 0) <*> parseJSON (a ! 1) <*> parseJSON (a ! 2) @@ -37,21 +56,170 @@ instance FromJSON NmcRRService where 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 + +instance (Ord k, Mergeable a) => Mergeable (Map k a) where + merge mx my = unionWith merge my mx + +-- Alas, the following is not possible in Haskell :-( +-- instance Mergeable String where +-- merge _ b = b + +instance Mergeable Value where + merge _ b = b + +instance Mergeable a => Mergeable (Maybe a) where + merge (Just x) (Just y) = Just (merge x y) + merge Nothing (Just y) = Just y + merge (Just x) Nothing = Just x + merge Nothing Nothing = Nothing + +instance Eq a => Mergeable [a] where + merge xs ys = union xs ys + +data NmcRRSrv = NmcRRSrv + { srvPrio :: Int + , srvWeight :: Int + , srvPort :: Int + , srvHost :: String + } deriving (Show, Eq) + +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 -data NmcDom = NmcDom { domService :: Maybe [NmcRRService] - , domIp :: Maybe [String] +instance Mergeable NmcRRI2p where + merge _ b = b + +data NmcRRTlsa = NmcRRTlsa + { tlsMatchType :: Int -- 0:exact 1:sha256 2:sha512 + , tlsMatchValue :: String + , tlsIncSubdoms :: Bool -- enforce on subdoms? + } deriving (Show, Eq) + +instance FromJSON NmcRRTlsa where + parseJSON (Array a) = + if length a == 3 then NmcRRTlsa + <$> parseJSON (a ! 0) + <*> parseJSON (a ! 1) + <*> case (a ! 2) of + Number 0 -> return False + Number 1 -> return True + _ -> empty + else empty + parseJSON _ = empty + +instance Mergeable NmcRRTlsa 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 { domIp :: Maybe [String] , domIp6 :: Maybe [String] , domTor :: Maybe String , domI2p :: Maybe NmcRRI2p @@ -62,33 +230,38 @@ data NmcDom = NmcDom { domService :: Maybe [NmcRRService] , domLoc :: Maybe String , domInfo :: Maybe Value , domNs :: Maybe [String] - , domDelegate :: Maybe [String] - , domImport :: Maybe String - , domMap :: Maybe (Map String NmcDom) + , domDelegate :: Maybe String + , domImport :: Maybe [String] + , domSubmap :: Maybe (Map String NmcDom) , domFingerprint :: Maybe [String] - , domTls :: Maybe (Map String - (Map String [[String]])) - , domDs :: Maybe [[String]] + , domDs :: Maybe [NmcRRDs] + , 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' = T.unpack s + s' = unpack s isIPv4 x = all isNibble $ splitOn "." x isNibble x = if all isDigit x then (read x :: Int) < 256 else False parseJSON (Object o) = NmcDom - <$> o .:? "service" - <*> o .:? "ip" - <*> o .:? "ip6" + <$> o .:/ "ip" + <*> o .:/ "ip6" <*> o .:? "tor" <*> o .:? "i2p" <*> o .:? "freenet" @@ -97,133 +270,43 @@ instance FromJSON NmcDom where <*> o .:? "email" <*> o .:? "loc" <*> o .:? "info" - <*> o .:? "ns" + <*> o .:/ "ns" <*> o .:? "delegate" - <*> o .:? "import" - <*> o .:? "map" - <*> o .:? "fingerprint" - <*> o .:? "tls" + <*> o .:/ "import" + <*> makeSubmap o + <*> o .:/ "fingerprint" <*> o .:? "ds" + <*> makeMx o + <*> return Nothing -- domSrv created in subdomains + <*> return Nothing -- domTlsa created in subdomains parseJSON _ = empty -emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing - --- FIXME -- I hope there exists a better way to merge records! -mergeNmcDom :: NmcDom -> NmcDom -> NmcDom -mergeNmcDom sub dom = dom { domService = choose domService - , domIp = choose domIp - , domIp6 = choose domIp6 - , domTor = choose domTor - , domI2p = choose domI2p - , domFreenet = choose domFreenet - , domAlias = choose domAlias - , domTranslate = choose domTranslate - , domEmail = choose domEmail - , domLoc = choose domLoc - , domInfo = choose domInfo - , domNs = choose domNs - , domDelegate = choose domDelegate - , domImport = choose domImport - , domMap = choose domMap - , domFingerprint = choose domFingerprint - , domTls = choose domTls - , domDs = choose domDs - } - where - choose :: (NmcDom -> Maybe a) -> Maybe a - choose field = case field dom of - Nothing -> field sub - Just x -> Just x - --- | Perform query and return error string or parsed domain object -queryNmcDom :: - (String -> IO (Either String ByteString)) -- ^ query operation action - -> String -- ^ key - -> IO (Either String NmcDom) -- ^ error string or domain -queryNmcDom queryOp key = do - l <- queryOp key - case l of - Left estr -> return $ Left estr - Right str -> case decode str :: Maybe NmcDom of - Nothing -> return $ Left $ "Unparseable value: " ++ (show str) - Just dom -> return $ Right dom - --- | Try to fetch "import" object and merge it into the base domain --- Original "import" element is removed, but new imports from the --- imported objects are processed recursively until there are none. -mergeImport :: - (String -> IO (Either String ByteString)) -- ^ query operation action - -> NmcDom -- ^ base domain - -> IO (Either String NmcDom) -- ^ result with merged import -mergeImport queryOp base = do - let - mbase = mergeSelf base - base' = mbase {domImport = Nothing} - -- print base - 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 $ sub' `mergeNmcDom` base' - --- | 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} - removeSelf Nothing = Nothing - removeSelf (Just map) = if size map' == 0 then Nothing else Just map' - where map' = M.delete "" map - in - case map of - Nothing -> base' - Just map' -> - case M.lookup "" map' of - Nothing -> base' - Just sub -> (mergeSelf sub) `mergeNmcDom` base' - --- | Presence of some elements require removal of some others -normalizeDom :: NmcDom -> NmcDom -normalizeDom dom = foldr id dom [ translateNormalizer - -- , nsNormalizer -- FIXME retrun this - ] - where - nsNormalizer dom = case domNs dom of - Nothing -> dom - Just ns -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom } - translateNormalizer dom = case domTranslate dom of - Nothing -> dom - Just tr -> dom { domMap = Nothing } - --- | Merge imports and Selfs and follow the maps tree to get dom -descendNmcDom :: - (String -> IO (Either String ByteString)) -- ^ query operation action - -> [String] -- ^ subdomain chain - -> NmcDom -- ^ base domain - -> IO (Either String NmcDom) -- ^ fully processed result -descendNmcDom queryOp subdom base = do - base' <- mergeImport queryOp base - case subdom of - [] -> return $ fmap normalizeDom base' - d:ds -> - case base' of - Left err -> return base' - Right base'' -> - case domMap base'' of - Nothing -> return $ Right emptyNmcDom - Just map -> - case M.lookup d map of - Nothing -> return $ Right emptyNmcDom - Just sub -> descendNmcDom queryOp ds sub - --- | Initial NmcDom populated with "import" only, suitable for "descend" -seedNmcDom :: - String -- ^ domain key (without namespace prefix) - -> NmcDom -- ^ resulting seed domain -seedNmcDom dn = emptyNmcDom { domImport = Just ("d/" ++ dn)} +instance Mergeable NmcDom where + merge sub dom = dom { domIp = mergelm domIp + , domIp6 = mergelm domIp6 + , domTor = choose domTor + , domI2p = mergelm domI2p + , domFreenet = choose domFreenet + , domAlias = choose domAlias + , domTranslate = choose domTranslate + , domEmail = choose domEmail + , domLoc = choose domLoc + , domInfo = mergelm domInfo + , domNs = mergelm domNs + , domDelegate = mergelm domDelegate + , domImport = mergelm domImport + , domSubmap = mergelm domSubmap + , domFingerprint = mergelm domFingerprint + , domDs = mergelm domDs + , domMx = mergelm domMx + , domSrv = mergelm domSrv + , domTlsa = mergelm domTlsa + } + where + mergelm x = merge (x sub) (x dom) +-- Because it is not possible to define instance of merge for Strings, +-- we have to treat string elements separately, otherwise strings are +-- 'unioned' along with the rest of lists. Ugly, but alternatives are worse. + choose field = case field dom of + Nothing -> field sub + Just x -> Just x