json SRV data parser

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

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

+                , seedNmcDom

                 , descendNmcDom
                 , descendNmcDom

-                , queryNmcDom
-                , mergeImport

                 ) where
 
                 ) where
 

+import Prelude hiding (length)

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

-import qualified Data.ByteString.Lazy.Char8 as L (pack)

 import qualified Data.Text as T (unpack)
 import Data.List.Split
 import Data.Char
 import qualified Data.Text as T (unpack)
 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


@@ -48,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


@@ -108,34 +110,6 @@ 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
-
-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
 -- FIXME -- I hope there exists a better way to merge records!
 mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
 mergeNmcDom sub dom = dom  { domService = choose domService


@@ -152,6 +126,7 @@ mergeNmcDom 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


@@ -164,9 +139,9 @@ mergeNmcDom sub dom = dom  { domService = choose domService
 
 -- | Perform query and return error string or parsed domain object
 queryNmcDom ::
 
 -- | Perform query and return error string or parsed domain object
 queryNmcDom ::

-  (ByteString -> IO (Either String ByteString)) -- ^ query operation action
-  -> ByteString                                 -- ^ key
-  -> IO (Either String NmcDom)                  -- ^ error string or domain
+  (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
 queryNmcDom queryOp key = do
   l <- queryOp key
   case l of


@@ -176,20 +151,79 @@ queryNmcDom queryOp key = do
       Just dom -> return $ Right dom
 
 -- | Try to fetch "import" object and merge it into the base domain
       Just dom -> return $ Right dom
 
 -- | Try to fetch "import" object and merge it into the base domain

---   Any errors are ignored, and nothing is merged.

 --   Original "import" element is removed, but new imports from the
 --   imported objects are processed recursively until there are none.
 mergeImport ::
 --   Original "import" element is removed, but new imports from the
 --   imported objects are processed recursively until there are none.
 mergeImport ::

-  (ByteString -> IO (Either String ByteString)) -- ^ query operation action
-  -> NmcDom                                     -- ^ base domain
-  -> IO NmcDom                                  -- ^ result with merged import
+  (String -> IO (Either String ByteString)) -- ^ query operation action
+  -> NmcDom                                 -- ^ base domain
+  -> IO (Either String NmcDom)              -- ^ result with merged import

 mergeImport queryOp base = do
 mergeImport queryOp base = do

-  let base' = base {domImport = Nothing}
-  -- print base'
-  case domImport base of
-    Nothing  -> return base'
+  let
+    mbase = mergeSelf base
+    base' = mbase {domImport = Nothing}
+  -- print base
+  case domImport mbase of
+    Nothing  -> return $ Right base'

     Just key -> do
     Just key -> do

-      sub <- queryNmcDom queryOp (L.pack key)
+      sub <- queryNmcDom queryOp key

       case sub of
       case sub of

-        Left  e    -> return base'
+        Left  e    -> return $ Left e

         Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base'
         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)}