1 {-# LANGUAGE OverloadedStrings #-}
7 import qualified Data.ByteString.Char8 as C (pack, unpack)
8 import qualified Data.ByteString.Lazy.Char8 as L (pack, unpack)
9 import Data.ByteString.Lazy as BS hiding (reverse, putStr, putStrLn)
10 import Data.List.Split
11 import Data.Aeson (encode, decode, Value(..))
12 import Network.HTTP.Types
14 import Network.HTTP.Conduit
22 confFile = "/etc/namecoin.conf"
24 -- HTTP/JsonRpc interface
26 qReq :: Config -> ByteString -> ByteString -> Request m
27 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
28 $ def { host = (C.pack (rpchost cf))
31 , requestHeaders = [ (hAccept, "application/json")
32 , (hContentType, "application/json")
33 , (hConnection, "Keep-Alive")
35 , requestBody = RequestBodyLBS $ encode $
36 JsonRpcRequest JsonRpcV1
40 , checkStatus = \_ _ _ -> Nothing
43 qRsp :: Response ByteString -> Either String ByteString
45 case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
47 case (jrpcErrCode jerr) of
48 -4 -> Right "{}" -- this is how non-existent entry is returned
49 _ -> Left $ "JsonRpc error response: " ++ (show jerr)
50 Right jrsp -> Right $ resValue jrsp
54 queryOp :: Manager -> Config -> String -> String
55 -> IO (Either String ByteString)
56 queryOp mgr cfg qid key = do
58 httpLbs (qReq cfg (L.pack key) (L.pack qid)) mgr
61 queryNmc :: Manager -> Config -> String -> String
62 -> IO (Either String NmcDom)
63 queryNmc mgr cfg fqdn qid = do
64 case reverse (splitOn "." fqdn) of
66 dom <- mergeImport (queryOp mgr cfg qid) $
67 emptyNmcDom { domImport = Just ("d/" ++ dn)}
68 return $ Right $ descendNmcDom xs dom
70 return $ Left "Only \".bit\" domain is supported"
76 cfg <- readConfig confFile
78 hSetBuffering stdin LineBuffering
79 hSetBuffering stdout LineBuffering
82 loopErr e = forever $ do
83 putStrLn $ "FAIL\t" ++ e
88 ["HELO", "1"] -> return 1
89 ["HELO", "2"] -> return 2
90 ["HELO", "3"] -> return 3
91 ["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x)
92 _ -> loopErr $ "bad HELO " ++ (show s)
94 putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
99 case pdnsParse ver l of
100 Left e -> putStr $ pdnsReport e
103 PdnsRequestQ qname qtype id _ _ _ ->
104 queryNmc mgr cfg qname id >>= putStr . (pdnsOut ver id qname qtype)
105 PdnsRequestAXFR xfrreq ->
106 putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
107 PdnsRequestPing -> putStrLn "END"
112 cfg <- readConfig confFile
113 mgr <- newManager def
114 queryNmc mgr cfg str "askid" >>= putStr . (pdnsOut 1 "askid" str RRTypeANY)