{-# LANGUAGE OverloadedStrings #-} 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 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 JsonRpcClient import Config import PowerDns import NmcRpc import NmcDom confFile = "/etc/namecoin.conf" -- HTTP/JsonRpc interface qReq :: Config -> ByteString -> ByteString -> Request m qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf)) $ def { host = (C.pack (rpchost cf)) , port = (rpcport cf) , method = "PUT" , requestHeaders = [ (hAccept, "application/json") , (hContentType, "application/json") , (hConnection, "Keep-Alive") ] , requestBody = RequestBodyLBS $ encode $ JsonRpcRequest JsonRpcV1 "name_show" [q] (String "pdns-nmc") , checkStatus = \_ _ _ -> Nothing } qRsp :: Response ByteString -> Either String NmcDom 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 -- NMC interface queryNmc :: Manager -> Config -> String -> String -> IO (Either String NmcDom) 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 return $ case qRsp rsp of Left err -> Left err Right dom -> Right $ descendNmc xs dom _ -> return $ Left "Only \".bit\" domain is supported" -- Main entry main = do cfg <- readConfig confFile hSetBuffering stdin LineBuffering hSetBuffering stdout LineBuffering ver <- do let loopErr e = forever $ do putStrLn $ "FAIL\t" ++ e _ <- getLine return () s <- getLine case words s of ["HELO", "1"] -> return 1 ["HELO", "2"] -> return 2 ["HELO", "3"] -> return 3 ["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x) _ -> loopErr $ "bad HELO " ++ (show s) 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 cfg <- readConfig confFile mgr <- newManager def queryNmc mgr cfg str "askid" >>= putStr . (pdnsOut 1 "askid" str RRTypeANY)