Merge branch 'master' of ssh://git.average.org/~/pdns-pipe-nmc

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

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index 2ef82c239e837a484c28b4b180b106a265055dd4..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))))


@@ -79,6 +79,7 @@ mainPdnsNmc = do
 
   hSetBuffering stdin  LineBuffering
   hSetBuffering stdout LineBuffering
 
   hSetBuffering stdin  LineBuffering
   hSetBuffering stdout LineBuffering

+

   ver <- do
     let
       loopErr e = forever $ do
   ver <- do
     let
       loopErr e = forever $ do


@@ -95,11 +96,19 @@ 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
   let

-    newcache count name = (insert count name)
-      . (delete (if count >= 10 then count - 10 else count + 90))
+    fetch = lookup
+    -- Save the name under current count, increment count for the next run
+    -- so the name is saved under the count that was put into the response.
+    stow name (count, cache) =
+      (if count >= 99 then 0 else count + 1
+      , insert count name
+          $ delete (if count >= 10 then count - 10 else count + 90) cache
+      )

     io = liftIO
     io = liftIO

+

     mainloop = forever $ do
       l <- io getLine
       (count, cache) <- get
     mainloop = forever $ do
       l <- io getLine
       (count, cache) <- get


@@ -109,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)


@@ -117,10 +126,9 @@ mainPdnsNmc = do
                            ++ " qtype: " ++ (show qtype)
                            ++ " cache size: " ++ (show (size cache))
   -- end debug
                            ++ " qtype: " ++ (show qtype)
                            ++ " cache size: " ++ (show (size cache))
   -- end debug

-              put (if count >= 99 then 0 else count + 1,
-                   newcache count qname cache)
+              put $ stow qname (count, cache)

             PdnsRequestAXFR xrq ->
             PdnsRequestAXFR xrq ->

-              case lookup xrq cache of
+              case fetch xrq cache of

                 Nothing ->
                   io $ putStr $
                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))
                 Nothing ->
                   io $ putStr $
                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))


@@ -128,30 +136,38 @@ mainPdnsNmc = do
                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
                     >>= putStr . (pdnsOutXfr ver count qname)
             PdnsRequestPing -> io $ putStrLn "END"
                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
                     >>= putStr . (pdnsOutXfr ver count qname)
             PdnsRequestPing -> io $ putStrLn "END"

+

   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)"