1 {-# LANGUAGE OverloadedStrings #-}
6 import qualified Data.ByteString.Char8 as C (pack, unpack)
7 import qualified Data.ByteString.Lazy.Char8 as L (pack, unpack)
8 import Data.ByteString.Lazy as BS hiding (reverse, putStrLn)
10 import Data.Aeson (encode, decode, Value(..))
11 import Network.HTTP.Types
13 import Network.HTTP.Conduit
20 confFile = "/etc/namecoin.conf"
22 -- HTTP/JsonRpc interface
24 qReq :: Config -> ByteString -> ByteString -> Request m
25 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
26 $ def { host = (C.pack (rpchost cf))
29 , requestHeaders = [ (hAccept, "application/json")
30 , (hContentType, "application/json")
31 , (hConnection, "Keep-Alive")
33 , requestBody = RequestBodyLBS $ encode $
34 JsonRpcRequest JsonRpcV1
38 , checkStatus = \_ _ _ -> Nothing
41 qRsp :: Response ByteString -> Either String NmcDom
43 case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
45 case (jrpcErrCode jerr) of
46 -4 -> Right emptyNmcDom
47 _ -> Left $ "JsonRpc error response: " ++ (show jerr)
50 "" -> Right emptyNmcDom
52 case decode vstr :: Maybe NmcDom of
53 Nothing -> Left $ "Unparseable value: " ++ (show vstr)
58 queryNmc :: Manager -> Config -> String -> String
59 -> IO (Either String NmcDom)
60 queryNmc mgr cfg fqdn qid = do
61 case reverse (splitOn "." fqdn) of
64 httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr
67 return $ Left "Only \".bit\" domain is supported"
73 cfg <- readConfig confFile
77 loopErr e = forever $ do
78 putStrLn $ "FAIL\t" ++ e
83 ["HELO", "1"] -> return 1
84 ["HELO", "2"] -> return 2
85 ["HELO", "3"] -> return 3
86 ["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x)
87 _ -> loopErr $ "bad HELO " ++ (show s)
89 putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
94 case pdnsParse ver l of
95 Left e -> putStrLn $ "ERROR\t" ++ e
98 PdnsRequestQ qname qtype id _ _ _ -> do
99 ncres <- queryNmc mgr cfg qname id
101 Left e -> putStrLn $ "ERROR\t" ++ e
102 Right dom -> putStrLn $ pdnsOut qtype dom
103 PdnsRequestAXFR xfrreq ->
104 putStrLn ("ERROR\tNo support for AXFR " ++ xfrreq)
105 PdnsRequestPing -> putStrLn "OK"
110 cfg <- readConfig confFile
111 mgr <- newManager def
112 ncres <- queryNmc mgr cfg str "test-req-id"
114 Left e -> putStrLn $ "ERROR\t" ++ e
115 Right dom -> putStrLn $ pdnsOut RRTypeANY dom