From 3d8f1365ed65330c2dca645df383eac050bae915 Mon Sep 17 00:00:00 2001
From: Eugene Crosser <crosser@average.org>
Date: Thu, 27 Mar 2014 19:48:29 +0400
Subject: [PATCH] wip handling response

---
 Data/JsonRpcClient.hs | 12 ++++++------
 pdns-pipe-nmc.hs      | 15 +++++++++++++--
 2 files changed, 19 insertions(+), 8 deletions(-)

diff --git a/Data/JsonRpcClient.hs b/Data/JsonRpcClient.hs
index 573e94d..6038695 100644
--- a/Data/JsonRpcClient.hs
+++ b/Data/JsonRpcClient.hs
@@ -46,9 +46,9 @@ data JsonRpcError = JsonRpcError { jrpcErrCode    :: Int
                                  } deriving (Show)
 instance FromJSON JsonRpcError where
   parseJSON (Object o) = JsonRpcError
-                                <$> o .: "code"
-                                <*> o .: "error"
-                                <*> o .: "data"
+                                <$> o .:  "code"
+                                <*> o .:  "message"
+                                <*> o .:? "data"
   parseJSON x = return $ JsonRpcError
                                 (-32600)
                                 "Unparseable error object"
@@ -60,9 +60,9 @@ data JsonRpcResponse = JsonRpcResponse { jrpcRspResult :: Maybe Value
                                        } deriving (Show)
 instance FromJSON JsonRpcResponse where
   parseJSON (Object o) = JsonRpcResponse
-                                <$> o .: "result"
-                                <*> o .: "error"
-                                <*> o .: "id"
+                                <$> o .:? "result"
+                                <*> o .:  "error"
+                                <*> o .:  "id"
   parseJSON x = return $ JsonRpcResponse
                                 Nothing
                                 (JsonRpcError
diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index 3d1e46d..079e3b9 100644
--- a/pdns-pipe-nmc.hs
+++ b/pdns-pipe-nmc.hs
@@ -47,12 +47,14 @@ qReq cf q = applyBasicAuth (pack (rpcuser cf)) (pack (rpcpassword cf))
                 , method         = "PUT"
                 , requestHeaders = [ (hAccept,      "application/json")
                                    , (hContentType, "application/json")
+                                   , (hConnection,  "Keep-Alive")
                                    ]
                 , requestBody    = RequestBodyLBS $ encode $
                                    JsonRpcRequest JsonRpcV1
                                                   "name_show"
                                                   [q]
                                                   (String "pdns-nmc")
+                , checkStatus    = \_ _ _ -> Nothing
                 }
 
 -- NMC interface
@@ -167,8 +169,17 @@ main = do
 
   mgr <- newManager def
 
-  print $ qReq cfg "d/dot-bit"
-  rsp <- runResourceT $ httpLbs (qReq cfg "d/dot-bit") mgr
+  print $ qReq cfg "d/nosuchdomain"
+  rsp <- runResourceT $ httpLbs (qReq cfg "d/nosuchdomain") mgr
+  print $ (statusCode . responseStatus) rsp
+  putStrLn "===== complete response is:"
   print rsp
+  let rbody = responseBody rsp
+  putStrLn "===== response body is:"
+  print rbody
+  let result = parseJsonRpc rbody :: Either JsonRpcError NmcRes
+  putStrLn "===== parsed response is:"
+  print result
+--  print $ parseJsonRpc (responseBody rsp)
 
   --forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)
-- 
2.39.2