make default SOA generation = 0

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

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index 737c9e771f4d0c81c32518eae45e97961a332231..ab3e410de5951ed572dd20fdda70a0956a0b9f0e 100644 (file)
--- a/pdns-pipe-nmc.hs
+++ b/pdns-pipe-nmc.hs
@@ -2,18 +2,20 @@
 
 module Main where
 
 
 module Main where
 

-import Prelude hiding (readFile)
+import Prelude hiding (lookup, readFile)

 import System.Environment
 import System.IO hiding (readFile)
 import System.IO.Error
 import Control.Exception
 import Text.Show.Pretty hiding (String)
 import Control.Monad
 import System.Environment
 import System.IO hiding (readFile)
 import System.IO.Error
 import Control.Exception
 import Text.Show.Pretty hiding (String)
 import Control.Monad

-import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head)
+import Control.Monad.State
+import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head, empty)

 import qualified Data.ByteString.Char8 as C (pack)
 import qualified Data.ByteString.Lazy.Char8 as L (pack)
 import qualified Data.Text as T (pack)
 import Data.List.Split
 import qualified Data.ByteString.Char8 as C (pack)
 import qualified Data.ByteString.Lazy.Char8 as L (pack)
 import qualified Data.Text as T (pack)
 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.Conduit
 import Data.Aeson (encode, decode, Value(..))
 import Network.HTTP.Types
 import Data.Conduit


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

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

 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)


@@ -43,7 +45,7 @@ qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
                                       JsonRpcRequest JsonRpcV1
                                                      "name_show"
                                                      [L.pack q]
                                       JsonRpcRequest JsonRpcV1
                                                      "name_show"
                                                      [L.pack q]

-                                                     (String (T.pack id))
+                                                     (String (T.pack (show id)))

                    , checkStatus    = \_ _ _ -> Nothing
                    }
 
                    , checkStatus    = \_ _ _ -> Nothing
                    }
 


@@ -52,8 +54,8 @@ 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
       Right jrsp -> Right $ resValue jrsp
 
 -- NMC interface


@@ -77,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


@@ -94,40 +97,77 @@ mainPdnsNmc = do
   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 
   mgr <- newManager def
   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 
   mgr <- newManager def

-  forever $ do
-    l <- getLine
-    case pdnsParse ver l of
-      Left e -> putStr $ pdnsReport e
-      Right preq -> do
-        case preq of
-          PdnsRequestQ qname qtype id _ _ _ ->
-            queryDom (queryOpNmc cfg mgr id) qname >>= putStr . (pdnsOut ver id qname qtype)
-          PdnsRequestAXFR xfrreq ->
-            putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
-          PdnsRequestPing -> putStrLn "END"
+
+  let
+    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
+
+    mainloop = forever $ do
+      l <- io getLine
+      (count, cache) <- get
+      case pdnsParse ver l of
+        Left e -> io $ putStr $ pdnsReport e
+        Right preq -> do
+          case preq of
+            PdnsRequestQ qname qtype id _ _ _ -> do
+              io $ queryDom (queryOpNmc cfg mgr id) qname
+                     >>= putStr . (pdnsOutQ ver count qname qtype)
+  -- debug
+              io $ putStrLn $ "LOG\tRequest number " ++ (show count)
+                           ++ " id: " ++ (show id)
+                           ++ " qname: " ++ qname
+                           ++ " qtype: " ++ (show qtype)
+                           ++ " cache size: " ++ (show (size cache))
+  -- end debug
+              put $ stow qname (count, cache)
+            PdnsRequestAXFR xrq ->
+              case fetch xrq cache of
+                Nothing ->
+                  io $ putStr $
+                    pdnsReport ("AXFR for unknown id: " ++ (show xrq))
+                Just qname ->
+                  io $ queryDom (queryOpNmc cfg mgr xrq) qname
+                    >>= putStr . (pdnsOutXfr ver count qname)
+            PdnsRequestPing -> io $ putStrLn "END"
+
+  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
   mgr <- newManager def
   cfg <- readConfig confFile
   mgr <- newManager def

-  dom <- queryDom (queryOpNmc cfg mgr "_") key
+  dom <- queryDom (queryOpNmc cfg mgr (-1)) key

   putStrLn $ ppShow dom
   putStrLn $ ppShow dom

-  putStr $ pdnsOut 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 "+" 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)"