formatting

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

diff --git a/NmcDom.hs b/NmcDom.hs
index 61f7a19642a4199a25f9f6a708e501d7bf05bb09..731aa1cbb1f72b279377fc95f85bc22809fc6399 100644 (file)
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -2,35 +2,39 @@
 
 module NmcDom   ( NmcDom(..)
                 , emptyNmcDom
 
 module NmcDom   ( NmcDom(..)
                 , emptyNmcDom

+                , seedNmcDom

                 , descendNmcDom
                 , descendNmcDom

-                , mergeImport

                 ) where
 
                 ) 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.ByteString.Lazy (ByteString)
 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 (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
         parseJSON _ = empty
 
 data NmcRRI2p = NmcRRI2p


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


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


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


@@ -181,12 +158,72 @@ mergeImport ::
   -> NmcDom                                 -- ^ base domain
   -> IO (Either String NmcDom)              -- ^ result with merged import
 mergeImport queryOp base = do
   -> NmcDom                                 -- ^ base domain
   -> IO (Either String NmcDom)              -- ^ result with merged import
 mergeImport queryOp base = do

-  let base' = base {domImport = Nothing}
-  -- print base'
-  case domImport base of
+  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'
     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)}