1 {-# LANGUAGE OverloadedStrings #-}
5 import Prelude hiding (lookup, readFile)
6 import System.Environment
7 import System.IO hiding (readFile)
9 import Control.Exception
10 import Text.Show.Pretty hiding (String)
12 import Control.Monad.State
13 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head, empty)
14 import qualified Data.ByteString.Char8 as C (pack)
15 import qualified Data.ByteString.Lazy.Char8 as L (pack)
16 import qualified Data.Text as T (pack)
17 import Data.List.Split
18 import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
19 import Data.Aeson (encode, decode, Value(..))
20 import Network.HTTP.Types
22 import Network.HTTP.Conduit
31 confFile = "/etc/namecoin.conf"
33 -- HTTP/JsonRpc interface
35 qReq :: Config -> String -> Int -> Request m
36 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
37 $ def { host = (C.pack (rpchost cf))
40 , requestHeaders = [ (hAccept, "application/json")
41 , (hContentType, "application/json")
42 , (hConnection, "Keep-Alive")
44 , requestBody = RequestBodyLBS $ encode $
45 JsonRpcRequest JsonRpcV1
48 (String (T.pack (show id)))
49 , checkStatus = \_ _ _ -> Nothing
52 qRsp :: Response ByteString -> Either String ByteString
54 case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
56 case (jrpcErrCode jerr) of
57 -4 -> Right "{}" -- this is how non-existent entry is returned
58 _ -> Left $ "JsonRpc error response: " ++ (show jerr)
59 Right jrsp -> Right $ resValue jrsp
63 queryOpNmc cfg mgr qid key =
64 runResourceT (httpLbs (qReq cfg key qid) mgr) >>= return . qRsp
66 queryOpFile key = catch (readFile key >>= return . Right)
67 (\e -> return (Left (show (e :: IOException))))
69 queryDom queryOp fqdn =
70 case reverse (splitOn "." fqdn) of
71 "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
72 _ -> return $ Left "Only \".bit\" domain is supported"
78 cfg <- readConfig confFile
80 hSetBuffering stdin LineBuffering
81 hSetBuffering stdout LineBuffering
85 loopErr e = forever $ do
86 putStrLn $ "FAIL\t" ++ e
91 ["HELO", "1"] -> return 1
92 ["HELO", "2"] -> return 2
93 ["HELO", "3"] -> return 3
94 ["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x)
95 _ -> loopErr $ "bad HELO " ++ (show s)
97 putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
103 -- Save the name under current count, increment count for the next run
104 -- so the name is saved under the count that was put into the response.
105 stow name (count, cache) =
106 (if count >= 99 then 0 else count + 1
108 $ delete (if count >= 10 then count - 10 else count + 90) cache
112 mainloop = forever $ do
114 (count, cache) <- get
115 case pdnsParse ver l of
116 Left e -> io $ putStr $ pdnsReport e
119 PdnsRequestQ qname qtype id _ _ _ -> do
120 io $ queryDom (queryOpNmc cfg mgr id) qname
121 >>= putStr . (pdnsOut ver count qname qtype)
123 io $ putStrLn $ "LOG\tRequest number " ++ (show count)
124 ++ " id: " ++ (show id)
125 ++ " qname: " ++ qname
126 ++ " qtype: " ++ (show qtype)
127 ++ " cache size: " ++ (show (size cache))
129 put $ stow qname (count, cache)
130 PdnsRequestAXFR xrq ->
131 case fetch xrq cache of
134 pdnsReport ("AXFR for unknown id: " ++ (show xrq))
136 io $ queryDom (queryOpNmc cfg mgr xrq) qname
137 >>= putStr . (pdnsOutXfr ver count qname)
138 PdnsRequestPing -> io $ putStrLn "END"
140 runStateT mainloop (0, empty) >> return ()
142 -- query by key from Namecoin
145 cfg <- readConfig confFile
146 mgr <- newManager def
147 dom <- queryDom (queryOpNmc cfg mgr (-1)) key
148 putStrLn $ ppShow dom
149 putStr $ pdnsOut 1 (-1) key qt dom
151 -- using file backend for testing json domain data
154 dom <- queryDom queryOpFile key
155 putStrLn $ ppShow dom
156 putStr $ pdnsOut 1 (-1) key qt dom
164 [key, qtype] -> mainOne key (rrType qtype)
165 ["-f" ,key, qtype] -> mainFile key (rrType qtype)
166 _ -> error $ "usage: empty args, or \"[-f] <fqdn> <QTYPE>\" (type in caps)"