X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=NmcDom.hs;h=adb378999a064e81ce759d9b3d3e7c61a0dd34a0;hp=61f7a19642a4199a25f9f6a708e501d7bf05bb09;hb=e5636bafe23f4515a7a104bde8d2664d084f8cee;hpb=ea693af2c9b9eb7713f5d409b969cbf22df26326 diff --git a/NmcDom.hs b/NmcDom.hs index 61f7a19..adb3789 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -1,38 +1,84 @@ {-# LANGUAGE OverloadedStrings #-} module NmcDom ( NmcDom(..) + , NmcRRService(..) , emptyNmcDom + , seedNmcDom , descendNmcDom - , mergeImport ) where +import Prelude hiding (length) import Data.ByteString.Lazy (ByteString) -import qualified Data.Text as T (unpack) +import Data.Text (Text, unpack) +import Data.List as L (union) import Data.List.Split import Data.Char -import Data.Map as M (Map, lookup) -import Control.Applicative ((<$>), (<*>), empty) +import Data.Map as M (Map, lookup, delete, size, union) +import Data.Vector (toList,(!),length, singleton) +import Control.Applicative ((<$>), (<*>), empty, pure) import Data.Aeson -data NmcRRService = NmcRRService -- unused +import qualified Data.HashMap.Strict as H +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 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 = L.union xs ys + +data NmcRRService = NmcRRService { srvName :: String , srvProto :: String - , srvW1 :: Int - , srvW2 :: Int + , srvPrio :: Int + , srvWeight :: Int , srvPort :: Int - , srvHost :: [String] + , srvHost :: String } deriving (Show, Eq) instance FromJSON NmcRRService where - parseJSON (Object o) = NmcRRService - <$> o .: "name" - <*> o .: "proto" - <*> o .: "w1" - <*> o .: "w2" - <*> o .: "port" - <*> o .: "host" + 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 + merge _ b = b + data NmcRRI2p = NmcRRI2p { i2pDestination :: String , i2pName :: String @@ -46,7 +92,10 @@ instance FromJSON NmcRRI2p where <*> o .: "b32" parseJSON _ = empty -data NmcDom = NmcDom { domService :: Maybe [[String]] -- [NmcRRService] +instance Mergeable NmcRRI2p where + merge _ b = b + +data NmcDom = NmcDom { domService :: Maybe [NmcRRService] , domIp :: Maybe [String] , domIp6 :: Maybe [String] , domTor :: Maybe String @@ -58,13 +107,14 @@ data NmcDom = NmcDom { domService :: Maybe [[String]] -- [NmcRRService] , domLoc :: Maybe String , domInfo :: Maybe Value , domNs :: Maybe [String] - , domDelegate :: 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]] + , domMx :: Maybe [String] -- Synthetic } deriving (Show, Eq) instance FromJSON NmcDom where @@ -76,15 +126,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" @@ -93,72 +143,51 @@ instance FromJSON NmcDom where <*> o .:? "email" <*> o .:? "loc" <*> o .:? "info" - <*> o .:? "ns" + <*> o .:/ "ns" <*> o .:? "delegate" <*> o .:? "import" <*> o .:? "map" - <*> o .:? "fingerprint" + <*> o .:/ "fingerprint" <*> o .:? "tls" <*> o .:? "ds" + <*> return Nothing -- domMx not parsed parseJSON _ = empty +instance Mergeable NmcDom where + merge sub dom = dom { domService = mergelm domService + , 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 = choose domImport + , domMap = mergelm domMap + , domFingerprint = mergelm domFingerprint + , domTls = mergelm domTls + , domDs = mergelm domDs + , domMx = mergelm domMx + } + 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 + + emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - -normalizeDom :: NmcDom -> NmcDom -normalizeDom dom - | domNs dom /= Nothing = emptyNmcDom { domNs = domNs dom - , domEmail = domEmail dom - } - | domDelegate dom /= Nothing = emptyNmcDom -- FIXME - | domTranslate dom /= Nothing = dom { domMap = Nothing } - | otherwise = dom - -descendNmcDom :: [String] -> NmcDom -> NmcDom -descendNmcDom subdom rawdom = - let dom = normalizeDom rawdom - in case subdom of - [] -> - case domMap dom of - Nothing -> dom - Just map -> - case M.lookup "" map of -- Stupid, but there are "" in the map - Nothing -> dom -- Try to merge it with the root data - Just sub -> mergeNmcDom sub dom -- Or maybe drop it altogether... - d:ds -> - case domMap dom of - Nothing -> emptyNmcDom - Just map -> - case M.lookup d map of - Nothing -> emptyNmcDom - Just sub -> descendNmcDom ds sub - --- 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 - , 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 + Nothing -- | Perform query and return error string or parsed domain object queryNmcDom :: @@ -178,15 +207,98 @@ queryNmcDom queryOp key = do -- imported objects are processed recursively until there are none. mergeImport :: (String -> IO (Either String ByteString)) -- ^ query operation action + -> Int -- ^ recursion counter -> NmcDom -- ^ base domain -> IO (Either String NmcDom) -- ^ result with merged import -mergeImport queryOp base = do - let base' = base {domImport = Nothing} - -- print base' - case domImport base of +mergeImport queryOp depth base = do + let + mbase = mergeSelf base + base' = mbase {domImport = Nothing} + -- print base + 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 $ sub' `mergeNmcDom` base' + Right sub' -> mergeImport queryOp (depth - 1) $ 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' + -- recursion depth limited by the size of the record + +-- | SRV case - remove everyting and filter SRV records +normalizeSrv :: String -> String -> NmcDom -> NmcDom +normalizeSrv serv proto dom = + emptyNmcDom {domService = fmap (filter needed) (domService dom)} + where + needed r = srvName r == serv && srvProto r == proto + +-- | Presence of some elements require removal of some others +normalizeDom :: NmcDom -> NmcDom +normalizeDom dom = foldr id dom [ srvNormalizer + , translateNormalizer + , nsNormalizer + ] + 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 } + srvNormalizer dom = dom { domService = Nothing, domMx = makemx } + where + makemx = case domService dom of + Nothing -> Nothing + Just svl -> Just $ map makerec (filter needed svl) + where + needed sr = srvName sr == "smtp" + && srvProto sr == "tcp" + && srvPort sr == 25 + makerec sr = (show (srvPrio sr)) ++ " " ++ (srvHost sr) + +-- | 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 10 base + case subdom of + [] -> return $ fmap normalizeDom base' + -- A hack to handle SRV records: don't descend if ["_prot","_serv"] + [('_':p),('_':s)] -> return $ fmap (normalizeSrv s p) 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)}