1 {-# LANGUAGE OverloadedStrings #-}
5 --import Control.Applicative
7 import Data.ByteString.Char8 (pack, unpack)
8 import Data.ByteString.Lazy hiding (pack, unpack, putStrLn)
10 import Data.Either.Utils
11 import Data.List.Split
12 import Data.Aeson (encode, decode, Value(..))
13 import Network.HTTP.Types
15 import Network.HTTP.Conduit
16 import Data.JsonRpcClient
19 confFile = "/etc/namecoin.conf"
21 -- Config file handling
23 data Config = Config { rpcuser :: String
24 , rpcpassword :: String
29 readConfig :: String -> IO Config
31 cp <- return . forceEither =<< readfile emptyCP f
32 return (Config { rpcuser = getSetting cp "rpcuser" ""
33 , rpcpassword = getSetting cp "rpcpassword" ""
34 , rpchost = getSetting cp "rpchost" "localhost"
35 , rpcport = getSetting cp "rpcport" 8336
38 getSetting cp x dfl = case get cp "DEFAULT" x of
42 -- HTTP/JsonRpc interface
44 qReq cf q = applyBasicAuth (pack (rpcuser cf)) (pack (rpcpassword cf))
45 $ def { host = (pack (rpchost cf))
48 , requestHeaders = [ (hAccept, "application/json")
49 , (hContentType, "application/json")
50 , (hConnection, "Keep-Alive")
52 , requestBody = RequestBodyLBS $ encode $
53 JsonRpcRequest JsonRpcV1
57 , checkStatus = \_ _ _ -> Nothing
63 queryNmc :: String -> String -> RRType -> String -> IO (Either String NmcDom)
64 queryNmc uri fqdn qtype qid = do
65 case reverse (splitOn "." fqdn) of
67 ans <- detailledRemote Version1 [] uri "name_show" $ "d/" ++ dn
68 let mdom = decode (resValue ans) :: Maybe NmcDom
70 Nothing -> return $ Left ("Unparseable: " ++ (show (resValue ans)))
71 Just dom -> return $ Right dom
73 return $ Left "Only \".bit\" domain is supported"
77 data RRType = RRTypeSRV | RRTypeA | RRTypeAAAA | RRTypeCNAME
78 | RRTypeDNAME | RRTypeSOA | RRTypeRP | RRTypeLOC
80 | RRTypeANY | RRTypeError String
83 data PdnsRequest = PdnsRequestQ
87 , remoteIpAddress :: String
88 , localIpAddress :: Maybe String
89 , ednsSubnetAddress :: Maybe String
91 | PdnsRequestAXFR String
101 "CNAME" -> RRTypeCNAME
102 "DNAME" -> RRTypeDNAME
111 | ver >= 2 = case xs of
114 | otherwise = Nothing
116 | ver >= 3 = case xs of
119 | otherwise = Nothing
122 "PING":[] -> Right PdnsRequestPing
123 "AXFR":x:[] -> Right (PdnsRequestAXFR x)
124 "Q":qn:"IN":qt:id:rip:xs -> Right (PdnsRequestQ
128 , remoteIpAddress = rip
129 , localIpAddress = getLIp ver xs
130 , ednsSubnetAddress = getRIp ver xs
135 pdnsOut :: String -> Either String PdnsRequest -> IO ()
136 pdnsOut _ (Left e) = putStrLn ("ERROR\tUnparseable request: " ++ e)
137 pdnsOut uri (Right rq) = case rq of
138 PdnsRequestQ qn qt id lip rip eip -> do
139 dom <- queryNmc uri qn qt id
141 Left e -> putStrLn ("ERROR\tNmc query error: " ++ e)
142 Right result -> print result
143 PdnsRequestAXFR xfrreq ->
144 putStrLn ("ERROR\t No support for AXFR " ++ xfrreq)
145 PdnsRequestPing -> putStrLn "OK"
152 cfg <- readConfig confFile
156 loopErr e = forever $ do
157 putStrLn $ "FAIL\t" ++ e
162 ["HELO", "1"] -> return 1
163 ["HELO", "2"] -> return 2
164 ["HELO", "3"] -> return 3
165 ["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x)
166 _ -> loopErr $ "bad HELO " ++ (show s)
168 putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
170 mgr <- newManager def
172 print $ qReq cfg "d/nosuchdomain"
173 rsp <- runResourceT $ httpLbs (qReq cfg "d/nosuchdomain") mgr
174 print $ (statusCode . responseStatus) rsp
175 putStrLn "===== complete response is:"
177 let rbody = responseBody rsp
178 putStrLn "===== response body is:"
180 let result = parseJsonRpc rbody :: Either JsonRpcError NmcRes
181 putStrLn "===== parsed response is:"
183 -- print $ parseJsonRpc (responseBody rsp)
185 --forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)