X-Git-Url: http://average.org/gitweb/?a=blobdiff_plain;f=NmcJson.hs;h=c92e363ce4b6a6f5d92e10f25806c8e58e45adf3;hb=3677a8d0e1164eb4e7ba481a5e0d025fb1193005;hp=b7449297d3796aca706f78a645b0e49fba28f987;hpb=6e3dba2c2adb717490fb05b29e2bd50e2e9369a0;p=pdns-pipe-nmc.git

diff --git a/NmcJson.hs b/NmcJson.hs
index b744929..c92e363 100644
--- a/NmcJson.hs
+++ b/NmcJson.hs
@@ -1,11 +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
 
@@ -16,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
@@ -28,11 +30,11 @@ instance FromJSON NmcRRService where
                 <*> o .: "host"
         parseJSON _ = empty
 
-data NmcRRI2p = NmcRRI2p -- unused
+data NmcRRI2p = NmcRRI2p
                         { i2pDestination :: String
                         , i2pName        :: String
                         , i2pB32         :: String
-                        } deriving (Show)
+                        } deriving (Show, Eq)
 
 instance FromJSON NmcRRI2p where
         parseJSON (Object o) = NmcRRI2p
@@ -60,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
@@ -84,8 +86,12 @@ instance FromJSON NmcDom where
                 <*> o .:? "ds"
         parseJSON _ = empty
 
+emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
+                     Nothing Nothing Nothing Nothing Nothing Nothing
+                     Nothing Nothing Nothing Nothing Nothing Nothing
+
 data NmcRes = NmcRes    { resName       :: String
-                        , resValue      :: ByteString -- NmcDom
+                        , resValue      :: ByteString -- string with NmcDom
                         , resTxid       :: String
                         , resAddress    :: String
                         , resExpires_in :: Int
@@ -99,13 +105,56 @@ instance FromJSON NmcRes where
                 <*> o .: "expires_in"
         parseJSON _ = empty
 
-main = do
-  let l = "{\"name\":\"d/dot-bit\",\"value\":\"{\\\"info\\\":{\\\"description\\\":\\\"Dot-BIT Project - Official Website\\\",\\\"registrar\\\":\\\"http://register.dot-bit.org\\\"},\\\"fingerprint\\\":[\\\"30:B0:60:94:32:08:EC:F5:BE:DF:F4:BB:EE:52:90:2C:5D:47:62:46\\\"],\\\"ns\\\":[\\\"ns0.web-sweet-web.net\\\",\\\"ns1.web-sweet-web.net\\\"],\\\"map\\\":{\\\"\\\":{\\\"ns\\\":[\\\"ns0.web-sweet-web.net\\\",\\\"ns1.web-sweet-web.net\\\"]}},\\\"email\\\":\\\"register@dot-bit.org\\\"}\",\"txid\":\"7412603f2e6c3459be56accc6e1f3646b603f3d4a4188119a4072f125c1340d5\",\"address\":\"Mw3KCQcqC44nm75w7r79ZifZbEqT8RetWn\",\"expires_in\":18915}"
-  let r = decode l :: Maybe NmcRes
-  case r of
-    Just resp -> do
-      let value = (resValue resp)
-      let dom = decode value :: Maybe NmcDom
-      print dom
-    Nothing   ->
-      print "Unparseable NMC response"
+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
+                        , 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 -> Maybe a) -> Maybe a
+    choose field = case field dom of
+      Nothing -> field sub
+      Just x  -> Just x