wip move 'synthetic' parsing into NmcDom
[pdns-pipe-nmc.git] / NmcDom.hs
index adb378999a064e81ce759d9b3d3e7c61a0dd34a0..98275f7d06c42c784c72551a16d12e514e62ba1c 100644 (file)
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -1,25 +1,25 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcDom   ( NmcDom(..)
-                , NmcRRService(..)
-                , emptyNmcDom
-                , seedNmcDom
-                , descendNmcDom
+                , NmcRRSrv(..)
+                , NmcRRI2p(..)
+                , NmcRRTlsa(..)
+                , NmcRRDs(..)
+                , merge
                 ) where
 
 import Prelude hiding (length)
-import Data.ByteString.Lazy (ByteString)
+import Control.Applicative ((<$>), (<*>), empty, pure)
+import Data.Char
 import Data.Text (Text, unpack)
-import Data.List as L (union)
+import Data.List (union)
 import Data.List.Split
-import Data.Char
-import Data.Map as M (Map, lookup, delete, size, union)
-import Data.Vector (toList,(!),length, singleton)
-import Control.Applicative ((<$>), (<*>), empty, pure)
+import Data.Vector ((!), length, singleton)
+import Data.Map (Map, unionWith)
+import qualified Data.HashMap.Strict as H (lookup)
 import Data.Aeson
-
-import qualified Data.HashMap.Strict as H
 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
@@ -34,12 +34,27 @@ obj .:/ key = case H.lookup key obj of
                         String s -> parseJSON $ Array (singleton v)
                         _        -> parseJSON v
 
+makeMx :: Object -> Parser (Maybe [String])
+makeMx o = return Nothing -- FIXME
+{-
+  case H.lookup "service" o of
+    Nothing          -> pure Nothing
+    Just (Array saa) -> return $ Just $ fmap mxStr $ filter mxMatch saa
+      where
+        mxMatch sa = (sa ! 0) == "smtp" && (sa ! 1) == "tcp" && (sa ! 4) == 25
+        mxStr sa = (sa ! 2) ++ "\t" ++ (sa ! 5)
+    _                -> empty
+-}
+makeSubmap :: Object -> Parser (Maybe (Map String NmcDom))
+makeSubmap o = o .:? "map" -- FIXME
+
 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
 
@@ -53,50 +68,64 @@ 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
-                        , 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 NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
-                        , domIp          :: Maybe [String]
+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 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
@@ -108,23 +137,28 @@ data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
                         , domInfo        :: Maybe Value
                         , domNs          :: Maybe [String]
                         , domDelegate    :: Maybe String
-                        , domImport      :: Maybe String
-                        , domMap         :: Maybe (Map String NmcDom)
+                        , domImport      :: Maybe [String]
+                        , domSubmap      :: Maybe (Map String NmcDom)
                         , domFingerprint :: Maybe [String]
-                        , domTls         :: Maybe (Map String
-                                                    (Map String [[String]]))
-                        , domDs          :: Maybe [[String]]
-                        , domMx          :: Maybe [String] -- Synthetic
+                        , 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' = unpack s
                             isIPv4 x = all isNibble $ splitOn "." x
@@ -132,8 +166,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"
@@ -145,17 +178,17 @@ instance FromJSON NmcDom where
                 <*> o .:? "info"
                 <*> o .:/ "ns"
                 <*> o .:? "delegate"
-                <*> o .:? "import"
-                <*> o .:? "map"
+                <*> o .:/ "import"
+                <*> makeSubmap o
                 <*> o .:/ "fingerprint"
-                <*> o .:? "tls"
                 <*> o .:? "ds"
-                <*> return Nothing -- domMx 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
@@ -167,12 +200,13 @@ instance Mergeable NmcDom where
                                 , domInfo =        mergelm domInfo
                                 , domNs =          mergelm domNs
                                 , domDelegate =    mergelm domDelegate
-                                , domImport =      choose  domImport
-                                , domMap =         mergelm domMap
+                                , domImport =      mergelm domImport
+                                , 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)
@@ -182,123 +216,3 @@ instance Mergeable NmcDom where
                 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
-                     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
-  -> Int                                    -- ^ recursion counter
-  -> NmcDom                                 -- ^ base domain
-  -> IO (Either String NmcDom)              -- ^ result with merged import
-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 (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)}