domain normalization

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

diff --git a/NmcJson.hs b/NmcJson.hs
index 651aa46f1be2631fd8245f8ff899544af59546c8..f7733669e33b08f0ac8bd341d7702dee249d3699 100644 (file)
--- a/NmcJson.hs
+++ b/NmcJson.hs
@@ -1,12 +1,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcJson  ( NmcRes(..)
-                , NmcDom
+                , NmcDom(..)
                 , emptyNmcDom
+                , descendNmc
                 ) where
 
 import Data.ByteString.Lazy (ByteString)
-import Data.Map (Map)
+import Data.Map as M (Map, lookup)
 import Control.Applicative ((<$>), (<*>), empty)
 import Data.Aeson
 
@@ -17,7 +18,7 @@ data NmcRRService = NmcRRService -- unused
                         , srvW2         :: Int
                         , srvPort       :: Int
                         , srvHost       :: [String]
-                        } deriving (Show)
+                        } deriving (Show, Eq)
 
 instance FromJSON NmcRRService where
         parseJSON (Object o) = NmcRRService
@@ -33,7 +34,7 @@ data NmcRRI2p = NmcRRI2p
                         { i2pDestination :: String
                         , i2pName        :: String
                         , i2pB32         :: String
-                        } deriving (Show)
+                        } deriving (Show, Eq)
 
 instance FromJSON NmcRRI2p where
         parseJSON (Object o) = NmcRRI2p
@@ -61,7 +62,7 @@ data NmcDom = NmcDom    { domService     :: Maybe [[String]] -- [NmcRRService]
                         , domTls         :: Maybe (Map String
                                                     (Map String [[String]]))
                         , domDs          :: Maybe [[String]]
-                        } deriving (Show)
+                        } deriving (Show, Eq)
 
 instance FromJSON NmcDom where
         parseJSON (Object o) = NmcDom
@@ -103,3 +104,55 @@ instance FromJSON NmcRes where
                 <*> o .: "address"
                 <*> o .: "expires_in"
         parseJSON _ = empty
+
+normalizeDom :: NmcDom -> NmcDom
+normalizeDom dom
+  | domNs        dom /= Nothing = emptyNmcDom { domNs = domNs 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 dom domService sub
+                        , domIp = choose dom domIp sub
+                        , domIp6 = choose dom domIp6 sub
+                        , domTor = choose dom domTor sub
+                        , domI2p = choose dom domI2p sub
+                        , domFreenet = choose dom domFreenet sub
+                        , domAlias = choose dom domAlias sub
+                        , domTranslate = choose dom domTranslate sub
+                        , domEmail = choose dom domEmail sub
+                        , domLoc = choose dom domLoc sub
+                        , domInfo = choose dom domInfo sub
+                        , domNs = choose dom domNs sub
+                        , domDelegate = choose dom domDelegate sub
+                        , domImport = choose dom domImport sub
+                        , domFingerprint = choose dom domFingerprint sub
+                        , domTls = choose dom domTls sub
+                        , domDs = choose dom domDs sub
+                        }
+  where
+    choose :: NmcDom -> (NmcDom -> Maybe a) -> NmcDom -> Maybe a
+    choose sub t dom = case t dom of
+      Nothing -> t sub
+      Just x  -> Just x