X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=NmcDom.hs;h=8153a1dd7dad2d0b3128b455cf465bf0a93aa381;hp=fe87270c728d31a51064c35c50742ec69e8d3b48;hb=25e3fdd1a8580a4436088d3f66c14cfa321ad52f;hpb=c9c0d66c2dddbdcc25f6bc6df18039471591c3df diff --git a/NmcDom.hs b/NmcDom.hs index fe87270..8153a1d 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -1,28 +1,45 @@ {-# LANGUAGE OverloadedStrings #-} module NmcDom ( NmcDom(..) + , NmcRRService(..) + , NmcRRI2p(..) + , NmcRRTls(..) , emptyNmcDom - , seedNmcDom - , descendNmcDom + , mergeNmcDom ) where import Prelude hiding (length) -import Data.ByteString.Lazy (ByteString) -import qualified Data.Text as T (unpack) -import Data.List as L (union) -import Data.List.Split +import Control.Applicative ((<$>), (<*>), empty, pure) import Data.Char -import Data.Map as M (Map, lookup, delete, size, union) -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, singleton) +import Data.Map (Map, unionWith) +import qualified Data.HashMap.Strict as H (lookup) import Data.Aeson +import Data.Aeson.Types + +-- 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 (singleton v) + _ -> parseJSON v 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 = unionWith merge my mx +-- Alas, the following is not possible in Haskell :-( -- instance Mergeable String where -- merge _ b = b @@ -36,13 +53,13 @@ instance Mergeable a => Mergeable (Maybe a) where merge Nothing Nothing = Nothing instance Eq a => Mergeable [a] where - merge xs ys = L.union xs ys + merge xs ys = union xs ys data NmcRRService = NmcRRService { srvName :: String , srvProto :: String - , srvW1 :: Int - , srvW2 :: Int + , srvPrio :: Int + , srvWeight :: Int , srvPort :: Int , srvHost :: String } deriving (Show, Eq) @@ -78,6 +95,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] @@ -90,13 +145,15 @@ data NmcDom = NmcDom { domService :: Maybe [NmcRRService] , domLoc :: Maybe String , domInfo :: Maybe Value , domNs :: Maybe [String] - , domDelegate :: Maybe [String] - , domImport :: Maybe String + , domDelegate :: 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 + , domSrv :: Maybe [String] -- Synthetic } deriving (Show, Eq) instance FromJSON NmcDom where @@ -108,15 +165,15 @@ instance FromJSON NmcDom where then emptyNmcDom { domIp = Just [s'] } else emptyNmcDom 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" @@ -125,13 +182,15 @@ instance FromJSON NmcDom where <*> o .:? "email" <*> o .:? "loc" <*> o .:? "info" - <*> o .:? "ns" + <*> o .:/ "ns" <*> o .:? "delegate" - <*> o .:? "import" + <*> o .:/ "import" <*> o .:? "map" - <*> o .:? "fingerprint" + <*> o .:/ "fingerprint" <*> o .:? "tls" <*> o .:? "ds" + <*> return Nothing -- domMx not parsed + <*> return Nothing -- domSrv not parsed parseJSON _ = empty instance Mergeable NmcDom where @@ -148,11 +207,13 @@ 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 , domDs = mergelm domDs + , domMx = mergelm domMx + , domSrv = mergelm domSrv } where mergelm x = merge (x sub) (x dom) @@ -163,98 +224,10 @@ instance Mergeable NmcDom where 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 - --- | 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' `merge` 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) `merge` 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)} + Nothing Nothing