X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=pdns-pipe-nmc.hs;h=ab3e410de5951ed572dd20fdda70a0956a0b9f0e;hp=603ea987356ca793de89e94b27cad172a02eb918;hb=bf6a214e1b52fff6dae06c6fca1fad478553f1ae;hpb=6970cec92480e5b3ab3d82d120f5877181fa8589 diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs index 603ea98..ab3e410 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, putStr, 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,47 +44,42 @@ 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 -> case (jrpcErrCode jerr) of - -4 -> Right emptyNmcDom - _ -> Left $ "JsonRpc error response: " ++ (show jerr) - 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 + (-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 $ case qRsp rsp of - Left err -> Left err - Right dom -> Right $ descendNmc xs dom - _ -> - 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 @@ -91,21 +97,77 @@ 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 -> 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 + + 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 + +mainOne key qt = do cfg <- readConfig confFile mgr <- newManager def - queryNmc mgr cfg str "askid" >>= putStr . (pdnsOut 1 "askid" str RRTypeANY) + dom <- queryDom (queryOpNmc cfg mgr (-1)) key + putStrLn $ ppShow dom + putStr $ pdnsOut key qt dom + +-- using file backend for testing json domain data + +mainFile key qt = do + dom <- queryDom queryOpFile key + putStrLn $ ppShow dom + putStr $ pdnsOut key qt dom + +-- Entry point + +main = do + args <- getArgs + case args of + [] -> mainPdnsNmc + [key, qtype] -> mainOne key qtype + ["-f" ,key, qtype] -> mainFile key qtype + _ -> error $ "usage: empty args, or \"[-f] {|ANY|AXFR}\" (type in caps)"