wip convert to other http client

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

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index 6874bb0d2790886693a54477ca006d60c2a97aa3..aea5c0ae56e7841bc063bd3ebaaf67fe85203b0b 100644 (file)
--- a/pdns-pipe-nmc.hs
+++ b/pdns-pipe-nmc.hs
@@ -2,13 +2,18 @@
 
 module Main where
 
-import Control.Applicative
+--import Control.Applicative
 import Control.Monad
+import Data.ByteString.Char8 (pack, unpack)
+import Data.ByteString.Lazy hiding (pack, unpack, putStrLn)
 import Data.ConfigFile
 import Data.Either.Utils
 import Data.List.Split
-import Data.Aeson (decode)
-import Network.JsonRpc.Client
+import Data.Aeson (encode, decode, Value(..))
+import Network.HTTP.Types
+-- does not exist -- import Network.HTTP.Client
+import Network.HTTP.Conduit
+import Data.JsonRpcClient
 import NmcJson
 
 confFile = "/etc/namecoin.conf"
@@ -18,24 +23,41 @@ confFile = "/etc/namecoin.conf"
 data Config = Config { rpcuser       :: String
                      , rpcpassword   :: String
                      , rpchost       :: String
-                     , rpcport       :: String
+                     , rpcport       :: Int
                      } deriving (Show)
 
 readConfig :: String -> IO Config
 readConfig f = do
   cp <- return . forceEither =<< readfile emptyCP f
-  return (Config     { rpcuser       = getSetting cp "rpcuser"     ""
-                     , rpcpassword   = getSetting cp "rpcpassword" ""
-                     , rpchost       = getSetting cp "rpchost"     "localhost"
-                     , rpcport       = getSetting cp "rpcport"     "8336"
-                     })
+  return (Config { rpcuser       = getSetting cp "rpcuser"     ""
+                 , rpcpassword   = getSetting cp "rpcpassword" ""
+                 , rpchost       = getSetting cp "rpchost"     "localhost"
+                 , rpcport       = getSetting cp "rpcport"     8336
+                 })
     where
       getSetting cp x dfl = case get cp "DEFAULT" x of
-                              Left _  -> dfl
+                              Left  _ -> dfl
                               Right x -> x
 
+-- HTTP/JsonRpc interface
+
+qReq cf q = applyBasicAuth (pack (rpcuser cf)) (pack (rpcpassword cf))
+          $ def { host           = (pack (rpchost cf))
+                , port           = (rpcport cf)
+                , method         = "PUT"
+                , requestHeaders = [ (hAccept,      "application/json")
+                                   , (hContentType, "application/json")
+                                   ]
+                , requestBody    = RequestBodyLBS $ encode $
+                                   JsonRpcRequest JsonRpcV1
+                                                  "name_show"
+                                                  [q]
+                                                  (String "pdns-nmc")
+                }
+
 -- NMC interface
 
+{-
 queryNmc :: String -> String -> RRType -> String -> IO (Either String NmcDom)
 queryNmc uri fqdn qtype qid = do
   case reverse  (splitOn "." fqdn) of
@@ -47,7 +69,7 @@ queryNmc uri fqdn qtype qid = do
         Just dom -> return $ Right dom
     _           ->
       return $ Left "Only \".bit\" domain is supported"
-
+-}
 -- PowerDNS ABI
 
 data RRType = RRTypeSRV   | RRTypeA   | RRTypeAAAA | RRTypeCNAME
@@ -98,15 +120,16 @@ pdnsParse ver s =
       "PING":[]                 -> Right PdnsRequestPing
       "AXFR":x:[]               -> Right (PdnsRequestAXFR x)
       "Q":qn:"IN":qt:id:rip:xs  -> Right (PdnsRequestQ
-                                        { qName = qn
-                                        , qType = getQt qt
-                                        , iD = id
-                                        , remoteIpAddress = rip
-                                        , localIpAddress = getLIp ver xs
-                                        , ednsSubnetAddress = getRIp ver xs
-                                        })
+                                            { qName = qn
+                                            , qType = getQt qt
+                                            , iD = id
+                                            , remoteIpAddress = rip
+                                            , localIpAddress = getLIp ver xs
+                                            , ednsSubnetAddress = getRIp ver xs
+                                            })
       _                         -> Left s
 
+{-
 pdnsOut :: String -> Either String PdnsRequest -> IO ()
 pdnsOut _   (Left e)   = putStrLn ("ERROR\tUnparseable request: " ++ e)
 pdnsOut uri (Right rq) = case rq of
@@ -118,13 +141,12 @@ pdnsOut uri (Right rq) = case rq of
     PdnsRequestAXFR xfrreq ->
       putStrLn ("ERROR\t No support for AXFR " ++ xfrreq)
     PdnsRequestPing -> putStrLn "OK"
+-}
 
 -- Main entry
 
 main = do
   cfg <- readConfig confFile
-  let uri = "http://" ++ rpcuser cfg ++ ":" ++ rpcpassword cfg ++
-            "@" ++ rpchost cfg ++ ":" ++ rpcport cfg ++ "/"
   ver <- do
     let
       loopErr e = forever $ do
@@ -139,5 +161,10 @@ 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)
-  forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)
+
+  print $ qReq cfg "samplequery"
+
+  --forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)