json SRV data parser
[pdns-pipe-nmc.git] / NmcDom.hs
index f2ad26f3f1e6ec793e2229633c622c3b85287408..11b58dda3bdfd629467a7ba0c824c180b8ccd6ff 100644 (file)
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -2,36 +2,40 @@
 
 module NmcDom   ( NmcDom(..)
                 , emptyNmcDom
-                , descendNmc
-                , queryDom
+                , seedNmcDom
+                , descendNmcDom
                 ) where
 
+import Prelude hiding (length)
 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.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
 
-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
@@ -59,7 +63,7 @@ data NmcDom = NmcDom    { domService     :: Maybe [[String]] -- [NmcRRService]
                         , 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
@@ -106,37 +110,9 @@ emptyNmcDom = NmcDom 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!
-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
@@ -150,6 +126,7 @@ mergeNmc sub dom = dom  { domService = choose domService
                         , domNs =          choose domNs
                         , domDelegate =    choose domDelegate
                         , domImport =      choose domImport
+                        , domMap =         choose domMap
                         , domFingerprint = choose domFingerprint
                         , domTls =         choose domTls
                         , domDs =          choose domDs
@@ -161,14 +138,92 @@ mergeNmc sub dom = dom  { domService = choose domService
       Just x  -> Just x
 
 -- | Perform query and return error string or parsed domain object
-queryDom ::
-  (ByteString -> IO (Either String ByteString)) -- ^ query operation action
-  -> ByteString                                 -- ^ key
-  -> IO (Either String NmcDom)                  -- ^ error string or domain
-queryDom queryOp key = do
+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)}