update build script

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

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index f2669a23489ef7eae103838bf29ed2dd45c8ce80..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,32 +54,32 @@ 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
 

-queryNmc :: Manager -> Config -> String -> String
-         -> IO (Either String NmcDom)
-queryNmc mgr cfg qid fqdn =
+queryOpNmc cfg mgr qid key =
+  runResourceT (httpLbs (qReq cfg key qid) mgr) >>= return . qRsp
+
+queryOpFile key = catch (readFile key >>= return . Right)
+                        (\e -> return (Left (show (e :: IOException))))
+
+queryDom queryOp fqdn =

   case reverse (splitOn "." fqdn) of
     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
     _           -> return $ Left "Only \".bit\" domain is supported"
   case reverse (splitOn "." fqdn) of
     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
     _           -> return $ Left "Only \".bit\" domain is supported"

-  where
-    queryOp key = do
-      rsp <- runResourceT $ httpLbs (qReq cfg key qid) mgr
-      -- print $ qRsp rsp
-      return $ qRsp rsp

 
 

--- Main entry
+-- Main entries

 
 

-mainNmc = do
+mainPdnsNmc = do

 
   cfg <- readConfig confFile
 
   hSetBuffering stdin  LineBuffering
   hSetBuffering stdout LineBuffering
 
   cfg <- readConfig confFile
 
   hSetBuffering stdin  LineBuffering
   hSetBuffering stdout LineBuffering

+

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


@@ -95,44 +97,77 @@ mainNmc = 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 _ _ _ ->
-            queryNmc mgr cfg 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 <- queryNmc mgr cfg "+" 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
 

-queryFile :: String -> IO (Either String ByteString)
-queryFile key = catch (readFile key >>= return . Right)
-                      (\e -> return (Left (show (e :: IOException))))
-
-mainFile key = do
-  dom <- descendNmcDom queryFile [] (seedNmcDom key)
+mainFile key qt = do
+  dom <- queryDom queryOpFile key

   putStrLn $ ppShow dom
   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

-    []         -> mainNmc
-    [key]      -> mainOne key
-    ["-f",key] -> mainFile key
-    _ -> error $ "usage: empty args, or \"<key>\", or \"-f <key>\""
+    []                 -> 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)"