X-Git-Url: http://average.org/gitweb/?a=blobdiff_plain;f=pdns-pipe-nmc.hs;h=079e3b9cd9ab4014cb85016cc4d2892f78a94b3f;hb=3d8f1365ed65330c2dca645df383eac050bae915;hp=aea5c0ae56e7841bc063bd3ebaaf67fe85203b0b;hpb=8234458b3e8d0f3a14ca178a34866aacf7772373;p=pdns-pipe-nmc.git

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index aea5c0a..079e3b9 100644
--- a/pdns-pipe-nmc.hs
+++ b/pdns-pipe-nmc.hs
@@ -11,7 +11,7 @@ import Data.Either.Utils
 import Data.List.Split
 import Data.Aeson (encode, decode, Value(..))
 import Network.HTTP.Types
--- does not exist -- import Network.HTTP.Client
+import Data.Conduit
 import Network.HTTP.Conduit
 import Data.JsonRpcClient
 import NmcJson
@@ -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
@@ -146,7 +148,9 @@ pdnsOut uri (Right rq) = case rq of
 -- Main entry
 
 main = do
+
   cfg <- readConfig confFile
+
   ver <- do
     let
       loopErr e = forever $ do
@@ -161,10 +165,21 @@ main = do
       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
       _             -> loopErr $ "bad HELO " ++ (show s)
 
---  mgr <- newManager conduitManagerSettings
-
   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 
-  print $ qReq cfg "samplequery"
+  mgr <- newManager def
+
+  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)