wip split subdoms in the parser
[pdns-pipe-nmc.git] / NmcDom.hs
index 477def1b8b2418a7202b429d9cc864096fea9bd6..3b8f06018f039e69e324c40a48055be4386bf6cb 100644 (file)
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -1,12 +1,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcDom   ( NmcDom(..)
-                , NmcRRService(..)
+                , NmcRRSrv(..)
                 , NmcRRI2p(..)
-                , NmcRRTls(..)
+                , NmcRRTlsa(..)
                 , NmcRRDs(..)
-                , emptyNmcDom
-                , mergeNmcDom
+                , merge
                 ) where
 
 import Prelude hiding (length)
@@ -15,11 +14,14 @@ 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 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)
 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
@@ -31,9 +33,108 @@ 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 = ((.).(.)) merge merge <$> takeTls o <*> takeSrv o <*> takeMap o
+
+takeMap :: Object -> Parser (Maybe (Map String NmcDom))
+takeMap o =
+  case H.lookup "map" o of
+    Nothing          -> pure Nothing
+    Just (Object mo) -> do
+      unsplit <- (parseJSON (Object mo) :: Parser (Maybe (Map String NmcDom)))
+      let result = fmap splitup unsplit
+      return result
+        where
+          splitup :: Map String NmcDom -> Map String NmcDom
+          splitup x = foldrWithKey stow M.empty x
+          stow fqdn sdom acc = M.insertWith merge fqdn' sdom' acc
+            where
+              (fqdn', sdom') = nest (filter (/= "") (splitOnDots fqdn), sdom)
+              splitOnDots s = splitOn "." s
+              nest ([], v)   = (fqdn, v) -- can split result be empty?
+              nest ([k], v)  = (k, v)
+              nest (k:ks, v) =
+                nest (ks, def { domSubmap = Just (M.singleton k v) })
+    _                -> 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))
+                -- FIXME return parse error on invalid proto or port
+            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
 
@@ -56,62 +157,48 @@ 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
                         } 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)
                 else empty
         parseJSON _ = empty
 
-instance Mergeable NmcRRTls where
+instance Mergeable NmcRRTlsa where
         merge _ b = b
 
 data NmcRRDs = NmcRRDs
@@ -134,8 +221,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
@@ -148,23 +234,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
@@ -172,8 +262,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"
@@ -186,17 +275,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
@@ -209,12 +297,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)
@@ -224,11 +312,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