separate Namecoin RPC from domain data

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

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index d37491114a9adbc91091b26a95bd1ba4b86f60eb..4d47e5045bcc10c70b5d8c3bfcd56d99f432a669 100644 (file)
--- a/pdns-pipe-nmc.hs
+++ b/pdns-pipe-nmc.hs
@@ -2,20 +2,22 @@
 
 module Main where
 
 
 module Main where
 

+import System.IO

 import Control.Monad
 import qualified Data.ByteString.Char8 as C (pack, unpack)
 import qualified Data.ByteString.Lazy.Char8 as L (pack, unpack)
 import Control.Monad
 import qualified Data.ByteString.Char8 as C (pack, unpack)
 import qualified Data.ByteString.Lazy.Char8 as L (pack, unpack)

-import Data.ByteString.Lazy as BS hiding (reverse, putStrLn)
+import Data.ByteString.Lazy as BS hiding (reverse, putStr, putStrLn)

 import Data.List.Split
 import Data.Aeson (encode, decode, Value(..))
 import Network.HTTP.Types
 import Data.Conduit
 import Network.HTTP.Conduit
 import Data.List.Split
 import Data.Aeson (encode, decode, Value(..))
 import Network.HTTP.Types
 import Data.Conduit
 import Network.HTTP.Conduit

-import Data.JsonRpcClient

 
 

+import JsonRpcClient

 import Config
 import PowerDns
 import Config
 import PowerDns

-import NmcJson
+import NmcRpc
+import NmcDom

 
 confFile = "/etc/namecoin.conf"
 
 
 confFile = "/etc/namecoin.conf"
 


@@ -41,22 +43,30 @@ qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
 qRsp :: Response ByteString -> Either String NmcDom
 qRsp rsp =
     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
 qRsp :: Response ByteString -> Either String NmcDom
 qRsp rsp =
     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of

-      Left  jerr -> Left $ "Unparseable response: " ++ (show (responseBody rsp))
+      Left  jerr -> 
+        case (jrpcErrCode jerr) of
+          -4 -> Right emptyNmcDom
+          _  -> Left $ "JsonRpc error response: " ++ (show jerr)

       Right jrsp ->
       Right jrsp ->

-        case decode (resValue jrsp) :: Maybe NmcDom of
-          Nothing  -> Left $ "Unparseable value: " ++ (show (resValue jrsp))
-          Just dom -> Right dom
+        case resValue jrsp of
+          "" -> Right emptyNmcDom
+          vstr ->
+            case decode vstr :: Maybe NmcDom of
+              Nothing  -> Left $ "Unparseable value: " ++ (show vstr)
+              Just dom -> Right dom

 
 -- NMC interface
 
 
 -- NMC interface
 

-queryNmc :: Manager -> Config -> String -> RRType -> String
+queryNmc :: Manager -> Config -> String -> String

          -> IO (Either String NmcDom)
          -> IO (Either String NmcDom)

-queryNmc mgr cfg fqdn qtype qid = do
+queryNmc mgr cfg fqdn qid = do

   case reverse (splitOn "." fqdn) of
     "bit":dn:xs -> do
       rsp <- runResourceT $
              httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr
   case reverse (splitOn "." fqdn) of
     "bit":dn:xs -> do
       rsp <- runResourceT $
              httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr

-      return $ qRsp rsp
+      return $ case qRsp rsp of
+        Left  err -> Left err
+        Right dom -> Right $ descendNmc xs dom

     _           ->
       return $ Left "Only \".bit\" domain is supported"
 
     _           ->
       return $ Left "Only \".bit\" domain is supported"
 


@@ -66,6 +76,8 @@ main = do
 
   cfg <- readConfig confFile
 
 
   cfg <- readConfig confFile
 

+  hSetBuffering stdin  LineBuffering
+  hSetBuffering stdout LineBuffering

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


@@ -83,18 +95,21 @@ main = 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

-
-  print $ qReq cfg "d/nosuchdomain" "query-nmc"
-  rsp <- runResourceT $ httpLbs (qReq cfg "d/nosuchdomain" "query-nmc") mgr
-  print $ (statusCode . responseStatus) rsp
-  putStrLn "===== complete response is:"
-  print rsp
-  let rbody = responseBody rsp
-  putStrLn "===== response body is:"
-  print rbody
-  let result = parseJsonRpc rbody :: Either JsonRpcError NmcRes
-  putStrLn "===== parsed response is:"
-  print result
---  print $ parseJsonRpc (responseBody rsp)
-
-  --forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)
+  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 qname id >>= putStr . (pdnsOut ver id qname qtype)
+          PdnsRequestAXFR xfrreq ->
+            putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
+          PdnsRequestPing -> putStrLn "END"
+
+-- for testing
+
+ask str = do
+  cfg <- readConfig confFile
+  mgr <- newManager def
+  queryNmc mgr cfg str "askid" >>= putStr . (pdnsOut 1 "askid" str RRTypeANY)