X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=pdns-pipe-nmc.hs;h=2ef82c239e837a484c28b4b180b106a265055dd4;hp=9e4a72930691ab6b58e53e6220c4d6c495c5e4ce;hb=a8d263736c3b3f68ce8a70c4eb2c7c4024a9506a;hpb=b90215dda1c086c7c288ac9d7e3d75e0516f0fd5 diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs index 9e4a729..2ef82c2 100644 --- a/pdns-pipe-nmc.hs +++ b/pdns-pipe-nmc.hs @@ -2,11 +2,20 @@ module Main where +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 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 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 Data.Map.Lazy (Map, empty, lookup, insert, delete, size) import Data.Aeson (encode, decode, Value(..)) import Network.HTTP.Types import Data.Conduit @@ -15,13 +24,15 @@ import Network.HTTP.Conduit import JsonRpcClient import Config import PowerDns -import NmcJson +import NmcRpc +import NmcDom +import NmcTransform confFile = "/etc/namecoin.conf" -- HTTP/JsonRpc interface -qReq :: Config -> ByteString -> ByteString -> 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) @@ -33,42 +44,41 @@ qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf)) , requestBody = RequestBodyLBS $ encode $ JsonRpcRequest JsonRpcV1 "name_show" - [q] - (String "pdns-nmc") + [L.pack q] + (String (T.pack (show id))) , checkStatus = \_ _ _ -> Nothing } -qRsp :: Response ByteString -> Either String NmcDom +qRsp :: Response ByteString -> Either String ByteString qRsp rsp = case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of - Left jerr -> Left $ "Unparseable response: " ++ (show (responseBody rsp)) - Right jrsp -> - case resValue jrsp of - "" -> Right emptyNmcDom - vstr -> - case decode vstr :: Maybe NmcDom of - Nothing -> Left $ "Unparseable value: " ++ (show vstr) - 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 -queryNmc :: Manager -> Config -> String -> String - -> IO (Either String NmcDom) -queryNmc mgr cfg fqdn qid = do +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 -> do - rsp <- runResourceT $ - httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr - return $ qRsp rsp - _ -> - return $ Left "Only \".bit\" domain is supported" + "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn + _ -> return $ Left "Only \".bit\" domain is supported" --- Main entry +-- Main entries -main = do +mainPdnsNmc = do cfg <- readConfig confFile + hSetBuffering stdin LineBuffering + hSetBuffering stdout LineBuffering ver <- do let loopErr e = forever $ do @@ -86,17 +96,62 @@ main = do putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver) mgr <- newManager def - forever $ do - l <- getLine - case pdnsParse ver l of - Left e -> putStrLn $ "ERROR\t" ++ e - Right preq -> do - case preq of - PdnsRequestQ qname qtype id _ _ _ -> do - ncres <- queryNmc mgr cfg qname id - case ncres of - Left e -> putStrLn $ "ERROR\t" ++ e - Right dom -> putStrLn $ pdnsOut qtype dom - PdnsRequestAXFR xfrreq -> - putStrLn ("ERROR\tNo support for AXFR " ++ xfrreq) - PdnsRequestPing -> putStrLn "OK" + let + newcache count name = (insert count name) + . (delete (if count >= 10 then count - 10 else count + 90)) + 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 . (pdnsOut 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 (if count >= 99 then 0 else count + 1, + newcache count qname cache) + PdnsRequestAXFR xrq -> + case lookup 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 () + +-- query by key from Namecoin + +mainOne key = do + cfg <- readConfig confFile + mgr <- newManager def + dom <- queryDom (queryOpNmc cfg mgr (-1)) key + putStrLn $ ppShow dom + putStr $ pdnsOut 1 (-1) key RRTypeANY dom + +-- using file backend for testing json domain data + +mainFile key = do + dom <- queryDom queryOpFile key + putStrLn $ ppShow dom + putStr $ pdnsOut 1 (-1) key RRTypeANY dom + +-- Entry point + +main = do + args <- getArgs + case args of + [] -> mainPdnsNmc + [key] -> mainOne key + ["-f",key] -> mainFile key + _ -> error $ "usage: empty args, or \"[-f] \""