wip merging imports

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

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index d37491114a9adbc91091b26a95bd1ba4b86f60eb..d9ced8f3318629029611f1f5aff08e998dfebb73 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"
 


@@ -38,25 +40,32 @@ qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
                    , checkStatus    = \_ _ _ -> Nothing
                    }
 
                    , checkStatus    = \_ _ _ -> Nothing
                    }
 

-qRsp :: Response ByteString -> Either String NmcDom
+qRsp :: Response ByteString -> Either String ByteString

 qRsp rsp =
     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
 qRsp rsp =
     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of

-      Left  jerr -> Left $ "Unparseable response: " ++ (show (responseBody rsp))
-      Right jrsp ->
-        case decode (resValue jrsp) :: Maybe NmcDom of
-          Nothing  -> Left $ "Unparseable value: " ++ (show (resValue jrsp))
-          Just dom -> Right dom
+      Left  jerr -> 
+        case (jrpcErrCode jerr) of
+          -4 -> Right "{}"      -- this is how non-existent entry is returned
+          _  -> Left $ "JsonRpc error response: " ++ (show jerr)
+      Right jrsp -> Right $ resValue jrsp

 
 -- NMC interface
 
 
 -- NMC interface
 

-queryNmc :: Manager -> Config -> String -> RRType -> String
+queryOp :: Manager -> Config -> String -> String
+        -> IO (Either String ByteString)
+queryOp mgr cfg qid key = do
+  rsp <- runResourceT $
+    httpLbs (qReq cfg (L.pack key) (L.pack qid)) mgr
+  return $ qRsp rsp
+
+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
   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
+      dom <- mergeImport (queryOp mgr cfg qid) $
+                emptyNmcDom { domImport = Just ("d/" ++ dn)}
+      return $ Right $ descendNmcDom xs dom

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


@@ -66,6 +75,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 +94,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)