update spec doc, notably FQDN requirement

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

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index 1786376112854000b368be6a410432a9875db356..f638851f3192dc751b5fbccad581cdf911e45767 100644 (file)
--- a/pdns-pipe-nmc.hs
+++ b/pdns-pipe-nmc.hs
@@ -18,8 +18,8 @@ import Data.List.Split
 import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
 import Data.Aeson (encode, decode, Value(..))
 import Network.HTTP.Types
 import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
 import Data.Aeson (encode, decode, Value(..))
 import Network.HTTP.Types

-import Data.Conduit
-import Network.HTTP.Conduit
+import Network.HTTP.Client
+import Data.Default (def)

 
 import JsonRpcClient
 import Config
 
 import JsonRpcClient
 import Config


@@ -32,7 +32,7 @@ confFile = "/etc/namecoin.conf"
 
 -- HTTP/JsonRpc interface
 
 
 -- HTTP/JsonRpc interface
 

-qReq :: Config -> String -> Int -> Request m
+qReq :: Config -> String -> Int -> Request

 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
              $ def { host           = (C.pack (rpchost cf))
                    , port           = (rpcport cf)
 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
              $ def { host           = (C.pack (rpchost cf))
                    , port           = (rpcport cf)


@@ -54,14 +54,14 @@ qRsp rsp =
     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
       Left  jerr -> 
         case (jrpcErrCode jerr) of
     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
       Left  jerr -> 
         case (jrpcErrCode jerr) of

-          -4 -> Right "{}"      -- this is how non-existent entry is returned
-          _  -> Left $ "JsonRpc error response: " ++ (show jerr)
+          (-4) -> Right "{}"    -- this is how non-existent entry is returned
+          _    -> Left $ "JsonRpc error response: " ++ (show jerr)

       Right jrsp -> Right $ resValue jrsp
 
 -- NMC interface
 
 queryOpNmc cfg mgr qid key =
       Right jrsp -> Right $ resValue jrsp
 
 -- NMC interface
 
 queryOpNmc cfg mgr qid key =

-  runResourceT (httpLbs (qReq cfg key qid) mgr) >>= return . qRsp
+  httpLbs (qReq cfg key qid) mgr >>= return . qRsp

 
 queryOpFile key = catch (readFile key >>= return . Right)
                         (\e -> return (Left (show (e :: IOException))))
 
 queryOpFile key = catch (readFile key >>= return . Right)
                         (\e -> return (Left (show (e :: IOException))))


@@ -96,7 +96,7 @@ mainPdnsNmc = do
 
   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 
 
   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 

-  mgr <- newManager def
+  mgr <- newManager defaultManagerSettings

 
   let
     fetch = lookup
 
   let
     fetch = lookup


@@ -118,7 +118,7 @@ mainPdnsNmc = do
           case preq of
             PdnsRequestQ qname qtype id _ _ _ -> do
               io $ queryDom (queryOpNmc cfg mgr id) qname
           case preq of
             PdnsRequestQ qname qtype id _ _ _ -> do
               io $ queryDom (queryOpNmc cfg mgr id) qname

-                     >>= putStr . (pdnsOut ver count qname qtype)
+                     >>= putStr . (pdnsOutQ ver count qname qtype)

   -- debug
               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
                            ++ " id: " ++ (show id)
   -- debug
               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
                            ++ " id: " ++ (show id)


@@ -139,28 +139,35 @@ mainPdnsNmc = do
 
   runStateT mainloop (0, empty) >> return ()
 
 
   runStateT mainloop (0, empty) >> return ()
 

+-- helper for command-line tools
+
+pdnsOut key qt dom =
+  case qt of
+    "AXFR" -> pdnsOutXfr 1 (-1) key dom
+    _      -> pdnsOutQ 1 (-1) key (rrType qt) dom
+

 -- query by key from Namecoin
 
 -- query by key from Namecoin
 

-mainOne key = do
+mainOne key qt = do

   cfg <- readConfig confFile
   cfg <- readConfig confFile

-  mgr <- newManager def
+  mgr <- newManager defaultManagerSettings

   dom <- queryDom (queryOpNmc cfg mgr (-1)) key
   putStrLn $ ppShow dom
   dom <- queryDom (queryOpNmc cfg mgr (-1)) key
   putStrLn $ ppShow dom

-  putStr $ pdnsOut 1 (-1) key RRTypeANY dom
+  putStr $ pdnsOut key qt dom

 
 -- using file backend for testing json domain data
 
 
 -- using file backend for testing json domain data
 

-mainFile key = do
+mainFile key qt = do

   dom <- queryDom queryOpFile key
   putStrLn $ ppShow dom
   dom <- queryDom queryOpFile key
   putStrLn $ ppShow dom

-  putStr $ pdnsOut 1 (-1) key RRTypeANY dom
+  putStr $ pdnsOut key qt dom

 
 -- Entry point
 
 main = do
   args <- getArgs
   case args of
 
 -- Entry point
 
 main = do
   args <- getArgs
   case args of

-    []         -> mainPdnsNmc
-    [key]      -> mainOne key
-    ["-f",key] -> mainFile key
-    _ -> error $ "usage: empty args, or \"[-f] <fqdn>\""
+    []                 -> mainPdnsNmc
+    [key, qtype]       -> mainOne key qtype
+    ["-f" ,key, qtype] -> mainFile key qtype
+    _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\" (type in caps)"