less ugly (but still ugly) merge

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

diff --git a/NmcJson.hs b/NmcJson.hs
index 1d8bc9c0acd2787416be65612b40ed1280e98a97..c92e363ce4b6a6f5d92e10f25806c8e58e45adf3 100644 (file)
--- a/NmcJson.hs
+++ b/NmcJson.hs
@@ -105,45 +105,56 @@ instance FromJSON NmcRes where
                 <*> o .: "expires_in"
         parseJSON _ = empty
 
+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 dom = case subdom of
-  []   ->
-    case domMap dom of
-      Nothing  -> dom
-      Just map ->
-        case M.lookup "" map of         -- Stupid, but "" is allowed in the map
-          Nothing  -> dom               -- Try to merge it with the root data
-          Just sub -> mergeNmc sub dom
-  d:ds ->
-    case domMap dom of
-      Nothing  -> emptyNmcDom
-      Just map ->
-        case M.lookup d map of
-          Nothing  -> emptyNmcDom
-          Just sub -> descendNmc ds sub
+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
+mergeNmc sub dom = dom  { domService = choose domService
+                        , domIp =          choose domIp
+                        , domIp6 =         choose domIp6
+                        , domTor =         choose domTor
+                        , domI2p =         choose domI2p
+                        , domFreenet =     choose domFreenet
+                        , domAlias =       choose domAlias
+                        , domTranslate =   choose domTranslate
+                        , domEmail =       choose domEmail
+                        , domLoc =         choose domLoc
+                        , domInfo =        choose domInfo
+                        , domNs =          choose domNs
+                        , domDelegate =    choose domDelegate
+                        , domImport =      choose domImport
+                        , domFingerprint = choose domFingerprint
+                        , domTls =         choose domTls
+                        , domDs =          choose domDs
                         }
   where
-    choose :: NmcDom -> (NmcDom -> Maybe a) -> NmcDom -> Maybe a
-    choose sub t dom = case t dom of
-      Nothing -> t sub
+    choose :: (NmcDom -> Maybe a) -> Maybe a
+    choose field = case field dom of
+      Nothing -> field sub
       Just x  -> Just x