json SRV data parser

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

diff --git a/NmcDom.hs b/NmcDom.hs
index 03eeb98582275db94d2554b48fb4d4a80bb15cf6..11b58dda3bdfd629467a7ba0c824c180b8ccd6ff 100644 (file)
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -6,32 +6,36 @@ module NmcDom   ( NmcDom(..)
                 , descendNmcDom
                 ) where
 
+import Prelude hiding (length)
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.Text as T (unpack)
 import Data.List.Split
 import Data.Char
 import Data.Map as M (Map, lookup, delete, size)
+import Data.Vector (toList,(!),length)
 import Control.Applicative ((<$>), (<*>), empty)
 import Data.Aeson
 
-data NmcRRService = NmcRRService -- unused
+data NmcRRService = NmcRRService
                         { srvName       :: String
                         , srvProto      :: String
                         , srvW1         :: Int
                         , srvW2         :: Int
                         , srvPort       :: Int
-                        , srvHost       :: [String]
+                        , srvHost       :: String
                         } 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
@@ -46,7 +50,7 @@ instance FromJSON NmcRRI2p where
                 <*> 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
@@ -171,10 +175,9 @@ mergeImport queryOp base = do
 mergeSelf :: NmcDom -> NmcDom
 mergeSelf base =
   let
-    nbase = normalizeDom base
-    map   = domMap nbase
-    base' = nbase {domMap = removeSelf map}
-    removeSelf (Nothing)  = Nothing
+    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
@@ -187,13 +190,16 @@ mergeSelf base =
 
 -- | Presence of some elements require removal of some others
 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
+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 ::
@@ -204,7 +210,7 @@ descendNmcDom ::
 descendNmcDom queryOp subdom base = do
   base' <- mergeImport queryOp base
   case subdom of
-    []   -> return base'
+    []   -> return $ fmap normalizeDom base'
     d:ds ->
       case base' of
         Left err     -> return base'