json SRV data parser

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

diff --git a/NmcDom.hs b/NmcDom.hs
index b975522095ef4416ab79741f621c381ae250e1fa..11b58dda3bdfd629467a7ba0c824c180b8ccd6ff 100644 (file)
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -2,35 +2,40 @@
 
 module NmcDom   ( NmcDom(..)
                 , emptyNmcDom
 
 module NmcDom   ( NmcDom(..)
                 , emptyNmcDom

-                , descendNmc
+                , seedNmcDom
+                , descendNmcDom

                 ) where
 
                 ) where
 

+import Prelude hiding (length)

 import Data.ByteString.Lazy (ByteString)
 import Data.ByteString.Lazy (ByteString)

-import Data.Text as T (unpack)
+import qualified Data.Text as T (unpack)

 import Data.List.Split
 import Data.Char
 import Data.List.Split
 import Data.Char

-import Data.Map as M (Map, lookup)
+import Data.Map as M (Map, lookup, delete, size)
+import Data.Vector (toList,(!),length)

 import Control.Applicative ((<$>), (<*>), empty)
 import Data.Aeson
 
 import Control.Applicative ((<$>), (<*>), empty)
 import Data.Aeson
 

-data NmcRRService = NmcRRService -- unused
+data NmcRRService = NmcRRService

                         { srvName       :: String
                         , srvProto      :: String
                         , srvW1         :: Int
                         , srvW2         :: Int
                         , srvPort       :: Int
                         { srvName       :: String
                         , srvProto      :: String
                         , srvW1         :: Int
                         , srvW2         :: Int
                         , srvPort       :: Int

-                        , srvHost       :: [String]
+                        , srvHost       :: String

                         } deriving (Show, Eq)
 
 instance FromJSON NmcRRService where
                         } deriving (Show, Eq)
 
 instance FromJSON NmcRRService where

-        parseJSON (Object o) = NmcRRService
-                <$> o .: "name"
-                <*> o .: "proto"
-                <*> o .: "w1"
-                <*> o .: "w2"
-                <*> o .: "port"
-                <*> o .: "host"
-        parseJSON _ = empty
+  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

 
 data NmcRRI2p = NmcRRI2p
                         { i2pDestination :: String
 
 data NmcRRI2p = NmcRRI2p
                         { i2pDestination :: String


@@ -45,7 +50,7 @@ instance FromJSON NmcRRI2p where
                 <*> o .: "b32"
         parseJSON _ = empty
 
                 <*> o .: "b32"
         parseJSON _ = empty
 

-data NmcDom = NmcDom    { domService     :: Maybe [[String]] -- [NmcRRService]
+data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]

                         , domIp          :: Maybe [String]
                         , domIp6         :: Maybe [String]
                         , domTor         :: Maybe String
                         , domIp          :: Maybe [String]
                         , domIp6         :: Maybe [String]
                         , domTor         :: Maybe String


@@ -58,7 +63,7 @@ data NmcDom = NmcDom    { domService     :: Maybe [[String]] -- [NmcRRService]
                         , domInfo        :: Maybe Value
                         , domNs          :: Maybe [String]
                         , domDelegate    :: Maybe [String]
                         , domInfo        :: Maybe Value
                         , domNs          :: Maybe [String]
                         , domDelegate    :: Maybe [String]

-                        , domImport      :: Maybe [[String]]
+                        , domImport      :: Maybe String

                         , domMap         :: Maybe (Map String NmcDom)
                         , domFingerprint :: Maybe [String]
                         , domTls         :: Maybe (Map String
                         , domMap         :: Maybe (Map String NmcDom)
                         , domFingerprint :: Maybe [String]
                         , domTls         :: Maybe (Map String


@@ -105,37 +110,9 @@ emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
                      Nothing Nothing Nothing Nothing Nothing Nothing
                      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
-
-descendNmc :: [String] -> NmcDom -> NmcDom
-descendNmc 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 -> mergeNmc 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 -> descendNmc ds sub
-

 -- FIXME -- I hope there exists a better way to merge records!
 -- FIXME -- I hope there exists a better way to merge records!

-mergeNmc :: NmcDom -> NmcDom -> NmcDom
-mergeNmc sub dom = dom  { domService = choose domService
+mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
+mergeNmcDom sub dom = dom  { domService = choose domService

                         , domIp =          choose domIp
                         , domIp6 =         choose domIp6
                         , domTor =         choose domTor
                         , domIp =          choose domIp
                         , domIp6 =         choose domIp6
                         , domTor =         choose domTor


@@ -149,6 +126,7 @@ mergeNmc sub dom = dom  { domService = choose domService
                         , domNs =          choose domNs
                         , domDelegate =    choose domDelegate
                         , domImport =      choose domImport
                         , domNs =          choose domNs
                         , domDelegate =    choose domDelegate
                         , domImport =      choose domImport

+                        , domMap =         choose domMap

                         , domFingerprint = choose domFingerprint
                         , domTls =         choose domTls
                         , domDs =          choose domDs
                         , domFingerprint = choose domFingerprint
                         , domTls =         choose domTls
                         , domDs =          choose domDs


@@ -158,3 +136,94 @@ mergeNmc sub dom = dom  { domService = choose domService
     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

+
+-- | 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' `mergeNmcDom` 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) `mergeNmcDom` 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)}