From: Eugene Crosser <crosser@average.org>
Date: Sun, 30 Mar 2014 14:15:12 +0000 (+0400)
Subject: implement descent and (ugly) merge
X-Git-Tag: 0.9.0.0~106
X-Git-Url: http://average.org/gitweb/?a=commitdiff_plain;h=6970cec92480e5b3ab3d82d120f5877181fa8589;p=pdns-pipe-nmc.git

implement descent and (ugly) merge
---

diff --git a/NmcJson.hs b/NmcJson.hs
index e69f4f4..1d8bc9c 100644
--- a/NmcJson.hs
+++ b/NmcJson.hs
@@ -3,10 +3,11 @@
 module NmcJson  ( NmcRes(..)
                 , 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,46 @@ instance FromJSON NmcRes where
                 <*> o .: "address"
                 <*> o .: "expires_in"
         parseJSON _ = empty
+
+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
+
+-- 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
diff --git a/PowerDns.hs b/PowerDns.hs
index b9c8093..696b9b5 100644
--- a/PowerDns.hs
+++ b/PowerDns.hs
@@ -93,16 +93,17 @@ nmc2pdns name RRTypeAAAA  dom = mapto name "AAAA" $ domIp6 dom
 nmc2pdns name RRTypeCNAME dom = takejust name "CNAME" $ domAlias dom
 nmc2pdns name RRTypeDNAME dom = takejust name "DNAME" $ domTranslate dom
 nmc2pdns name RRTypeSOA   dom =
-  let
-    email = case domEmail dom of
-      Nothing   -> "hostmaster." ++ name
-      Just addr ->
-        let (aname, adom) = break (== '@') addr
-        in case adom of
-          "" -> aname
-          _  -> aname ++ "." ++ (tail adom)
-  in
-    [(name, "SOA", email ++ " 99999999 10800 3600 604800 86400")]
+  if dom == emptyNmcDom then []
+  else
+    let
+      email = case domEmail dom of
+        Nothing   -> "hostmaster." ++ name
+        Just addr ->
+          let (aname, adom) = break (== '@') addr
+          in case adom of
+            "" -> aname
+            _  -> aname ++ "." ++ (tail adom)
+    in [(name, "SOA", email ++ " 99999999 10800 3600 604800 86400")]
 nmc2pdns name RRTypeRP    dom = [] --FIXME
 nmc2pdns name RRTypeLOC   dom = takejust name "LOC" $ domLoc dom
 nmc2pdns name RRTypeNS    dom = mapto name "NS" $ domNs dom
diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index 82c320d..603ea98 100644
--- a/pdns-pipe-nmc.hs
+++ b/pdns-pipe-nmc.hs
@@ -55,8 +55,6 @@ qRsp rsp =
 
 -- NMC interface
 
-descend subdom dom = dom --FIXME
-
 queryNmc :: Manager -> Config -> String -> String
          -> IO (Either String NmcDom)
 queryNmc mgr cfg fqdn qid = do
@@ -66,7 +64,7 @@ queryNmc mgr cfg fqdn qid = do
              httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr
       return $ case qRsp rsp of
         Left  err -> Left err
-        Right dom -> Right $ descend xs dom
+        Right dom -> Right $ descendNmc xs dom
     _           ->
       return $ Left "Only \".bit\" domain is supported"