1 {-# LANGUAGE OverloadedStrings #-}
5 import Prelude hiding (lookup, readFile)
6 import System.Environment
7 import System.IO hiding (readFile)
9 import Data.Time.Clock.POSIX
10 import Control.Exception
11 import Text.Show.Pretty hiding (String)
13 import Control.Monad.State
14 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head, empty)
15 import qualified Data.ByteString.Char8 as C (pack)
16 import qualified Data.ByteString.Lazy.Char8 as L (pack)
17 import qualified Data.Text as T (pack)
18 import Data.List.Split
19 import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
20 import Data.Aeson (encode, decode, Value(..))
21 import Network.HTTP.Types
22 import Network.HTTP.Client
23 import Data.Default (def)
32 confFile = "/etc/namecoin.conf"
34 -- HTTP/JsonRpc interface
36 qReq :: Config -> String -> Int -> Request
37 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
38 $ def { host = (C.pack (rpchost cf))
41 , requestHeaders = [ (hAccept, "application/json")
42 , (hContentType, "application/json")
43 , (hConnection, "Keep-Alive")
45 , requestBody = RequestBodyLBS $ encode $
46 JsonRpcRequest JsonRpcV1
49 (String (T.pack (show id)))
50 , checkStatus = \_ _ _ -> Nothing
53 qRsp :: Response ByteString -> Either String ByteString
55 case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
57 case (jrpcErrCode jerr) of
58 (-4) -> Right "{}" -- this is how non-existent entry is returned
59 _ -> Left $ "JsonRpc error response: " ++ (show jerr)
60 Right jrsp -> Right $ resValue jrsp
64 queryOpNmc cfg mgr qid key =
65 httpLbs (qReq cfg key qid) mgr >>= return . qRsp
67 queryOpFile key = catch (readFile key >>= return . Right)
68 (\e -> return (Left (show (e :: IOException))))
70 queryDom queryOp fqdn =
71 case reverse (splitOn "." fqdn) of
72 "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
73 _ -> return $ Left "Only \".bit\" domain is supported"
75 -- Number of ten minute intervals elapsed since creation of Namecoin
76 -- on April 18, 2011. Another option would be to use blockcount
77 -- but that would require another lookup, and we are cheap.
78 -- Yet another - to use (const - expires_in) from the lookup.
79 nmcAge = fmap (\x -> floor ((x - 1303070400) / 600)) getPOSIXTime
85 cfg <- readConfig confFile
87 hSetBuffering stdin LineBuffering
88 hSetBuffering stdout LineBuffering
92 loopErr e = forever $ do
93 putStrLn $ "FAIL\t" ++ e
98 ["HELO", "1"] -> return 1
99 ["HELO", "2"] -> return 2
100 ["HELO", "3"] -> return 3
101 ["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x)
102 _ -> loopErr $ "bad HELO " ++ (show s)
104 putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
106 mgr <- newManager defaultManagerSettings
110 -- Save the name under current count, increment count for the next run
111 -- so the name is saved under the count that was put into the response.
112 stow name (count, cache) =
113 (if count >= 99 then 0 else count + 1
115 $ delete (if count >= 10 then count - 10 else count + 90) cache
119 mainloop = forever $ do
122 (count, cache) <- get
123 case pdnsParse ver l of
124 Left e -> io $ putStr $ pdnsReport e
127 PdnsRequestQ qname qtype id _ _ _ -> do
128 io $ queryDom (queryOpNmc cfg mgr id) qname
129 >>= putStr . (pdnsOutQ ver count gen qname qtype)
131 io $ putStrLn $ "LOG\tRequest number " ++ (show count)
132 ++ " id: " ++ (show id)
133 ++ " qname: " ++ qname
134 ++ " qtype: " ++ (show qtype)
135 ++ " cache size: " ++ (show (size cache))
137 put $ stow qname (count, cache)
138 PdnsRequestAXFR xrq ->
139 case fetch xrq cache of
142 pdnsReport ("AXFR for unknown id: " ++ (show xrq))
144 io $ queryDom (queryOpNmc cfg mgr xrq) qname
145 >>= putStr . (pdnsOutXfr ver count gen qname)
146 PdnsRequestPing -> io $ putStrLn "END"
148 runStateT mainloop (0, empty) >> return ()
150 -- helper for command-line tools
152 pdnsOut gen key qt dom =
154 "AXFR" -> pdnsOutXfr 1 (-1) gen key dom
155 _ -> pdnsOutQ 1 (-1) gen key (rrType qt) dom
157 -- query by key from Namecoin
159 mainOne gen key qt = do
160 cfg <- readConfig confFile
161 mgr <- newManager defaultManagerSettings
162 dom <- queryDom (queryOpNmc cfg mgr (-1)) key
163 putStrLn $ ppShow dom
164 putStr $ pdnsOut gen key qt dom
166 -- using file backend for testing json domain data
168 mainFile gen key qt = do
169 dom <- queryDom queryOpFile key
170 putStrLn $ ppShow dom
171 putStr $ pdnsOut gen key qt dom
180 [key, qtype] -> mainOne gen key qtype
181 ["-f" ,key, qtype] -> mainFile gen key qtype
182 _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\" (type in caps)"