Scrap the plan to verify valid proto/port

[pdns-pipe-nmc.git] / NmcDom.hs

diff --git a/NmcDom.hs b/NmcDom.hs
index 8153a1dd7dad2d0b3128b455cf465bf0a93aa381..505c5436cfccd4de417f2ae77fca3bb583727639 100644 (file)
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -1,24 +1,27 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcDom   ( NmcDom(..)
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcDom   ( NmcDom(..)

-                , NmcRRService(..)
+                , NmcRRSrv(..)

                 , NmcRRI2p(..)
                 , NmcRRI2p(..)

-                , NmcRRTls(..)
-                , emptyNmcDom
-                , mergeNmcDom
+                , NmcRRTlsa(..)
+                , NmcRRDs(..)
+                , merge

                 ) where
 
 import Prelude hiding (length)
                 ) 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.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.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
 
 -- 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
 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
 
                         _        -> 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
 
 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
 
 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)
 
                         , 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
         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
                         } 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
 
         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
                         { 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)
 
                         } deriving (Show, Eq)
 

-instance FromJSON NmcRRTls where
+instance FromJSON NmcRRTlsa where

         parseJSON (Array a) =
         parseJSON (Array a) =

-                if length a == 3 then NmcRRTls
+                if length a == 3 then NmcRRTlsa

                         <$> parseJSON (a ! 0)
                         <*> parseJSON (a ! 1)
                         <$> 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
 
                 else empty
         parseJSON _ = empty
 

-instance Mergeable NmcRRTls where
+instance Mergeable NmcRRTlsa where

         merge _ b = b
 
 data NmcRRDs = NmcRRDs
         merge _ b = b
 
 data NmcRRDs = NmcRRDs


@@ -133,8 +219,7 @@ instance FromJSON NmcRRDs where
 instance Mergeable NmcRRDs where
         merge _ b = b
 
 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
                         , 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]
                         , domNs          :: Maybe [String]
                         , domDelegate    :: Maybe String
                         , domImport      :: Maybe [String]

-                        , domMap         :: Maybe (Map String NmcDom)
+                        , domSubmap      :: Maybe (Map String NmcDom)

                         , domFingerprint :: Maybe [String]
                         , domFingerprint :: Maybe [String]

-                        , domTls         :: Maybe (Map String
-                                                    (Map String [NmcRRTls]))

                         , domDs          :: Maybe [NmcRRDs]
                         , 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)
 
                         } 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'
 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
                           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
                               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"
                 <*> o .:/ "ip6"
                 <*> o .:? "tor"
                 <*> o .:? "i2p"


@@ -185,17 +273,16 @@ instance FromJSON NmcDom where
                 <*> o .:/ "ns"
                 <*> o .:? "delegate"
                 <*> o .:/ "import"
                 <*> o .:/ "ns"
                 <*> o .:? "delegate"
                 <*> o .:/ "import"

-                <*> o .:? "map"
+                <*> makeSubmap o

                 <*> o .:/ "fingerprint"
                 <*> o .:/ "fingerprint"

-                <*> o .:? "tls"

                 <*> o .:? "ds"
                 <*> 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
         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
                                 , 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
                                 , domNs =          mergelm domNs
                                 , domDelegate =    mergelm domDelegate
                                 , domImport =      mergelm domImport

-                                , domMap =         mergelm domMap
+                                , domSubmap =      mergelm domSubmap

                                 , domFingerprint = mergelm domFingerprint
                                 , domFingerprint = mergelm domFingerprint

-                                , domTls =         mergelm domTls

                                 , domDs =          mergelm domDs
                                 , domMx =          mergelm domMx
                                 , domSrv =         mergelm domSrv
                                 , domDs =          mergelm domDs
                                 , domMx =          mergelm domMx
                                 , domSrv =         mergelm domSrv

+                                , domTlsa =        mergelm domTlsa

                                 }
           where
                 mergelm x = merge (x sub) (x dom)
                                 }
           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
                 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