1 {-# LANGUAGE OverloadedStrings #-}
5 import Prelude hiding (lookup, readFile)
6 import System.Environment
7 import System.Console.GetOpt
8 import System.IO hiding (readFile)
10 import Data.Time.Clock.POSIX
11 import Control.Exception
12 import Text.Show.Pretty hiding (String)
14 import Control.Monad.State
15 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head, empty)
16 import qualified Data.ByteString.Char8 as C (pack)
17 import qualified Data.ByteString.Lazy.Char8 as L (pack)
18 import qualified Data.Text as T (pack)
19 import Data.List.Split
20 import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
21 import Data.Aeson (encode, decode, Value(..))
22 import Network.HTTP.Types
23 import Network.HTTP.Client
24 import Data.Default (def)
33 confFile = "/etc/namecoin.conf"
35 -- HTTP/JsonRpc interface
37 qReq :: Config -> String -> Int -> Request
38 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
39 $ def { host = (C.pack (rpchost cf))
42 , requestHeaders = [ (hAccept, "application/json")
43 , (hContentType, "application/json")
44 , (hConnection, "Keep-Alive")
46 , requestBody = RequestBodyLBS $ encode $
47 JsonRpcRequest JsonRpcV1
50 (String (T.pack (show id)))
51 , checkStatus = \_ _ _ -> Nothing
54 qRsp :: Response ByteString -> Either String ByteString
56 case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
58 case (jrpcErrCode jerr) of
59 (-4) -> Right "{}" -- this is how non-existent entry is returned
60 _ -> Left $ "JsonRpc error response: " ++ (show jerr)
61 Right jrsp -> Right $ resValue jrsp
65 queryOpNmc cfg mgr qid key =
66 httpLbs (qReq cfg key qid) mgr >>= return . qRsp
68 queryOpFile key = catch (readFile key >>= return . Right)
69 (\e -> return (Left (show (e :: IOException))))
71 queryDom queryOp fqdn =
72 case reverse (splitOn "." fqdn) of
73 "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
74 _ -> return $ Left "Only \".bit\" domain is supported"
76 -- Number of ten minute intervals elapsed since creation of Namecoin
77 -- on April 18, 2011. Another option would be to use blockcount
78 -- but that would require another lookup, and we are cheap.
79 -- Yet another - to use (const - expires_in) from the lookup.
80 nmcAge = fmap (\x -> floor ((x - 1303070400) / 600)) getPOSIXTime
82 -- run a PowerDNS coprocess. Negotiate ABI version and execute requests.
86 cfg <- readConfig confFile
88 hSetBuffering stdin LineBuffering
89 hSetBuffering stdout LineBuffering
93 loopErr e = forever $ do
94 putStrLn $ "FAIL\t" ++ e
99 ["HELO", "1"] -> return 1
100 ["HELO", "2"] -> return 2
101 ["HELO", "3"] -> return 3
102 ["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x)
103 _ -> loopErr $ "bad HELO " ++ (show s)
105 putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
107 mgr <- newManager defaultManagerSettings
111 -- Save the name under current count, increment count for the next run
112 -- so the name is saved under the count that was put into the response.
113 stow name (count, cache) =
114 (if count >= 99 then 0 else count + 1
116 $ delete (if count >= 10 then count - 10 else count + 90) cache
120 mainloop = forever $ do
123 (count, cache) <- get
124 case pdnsParse ver l of
125 Left e -> io $ putStr $ pdnsReport e
128 PdnsRequestQ qname qtype id _ _ _ -> do
129 io $ queryDom (queryOpNmc cfg mgr id) qname
130 >>= putStr . (pdnsOutQ ver count gen qname qtype)
133 io $ putStrLn $ "LOG\tRequest number " ++ (show count)
134 ++ " id: " ++ (show id)
135 ++ " qname: " ++ qname
136 ++ " qtype: " ++ (show qtype)
137 ++ " cache size: " ++ (show (size cache))
140 put $ stow qname (count, cache)
141 PdnsRequestAXFR xrq ->
142 case fetch xrq cache of
145 pdnsReport ("AXFR for unknown id: " ++ (show xrq))
147 io $ queryDom (queryOpNmc cfg mgr xrq) qname
148 >>= putStr . (pdnsOutXfr ver count gen qname)
149 PdnsRequestPing -> io $ putStrLn "END"
151 runStateT mainloop (0, empty) >> return ()
153 -- helper for command-line tools
155 pdnsOut gen key qt dom =
157 "AXFR" -> pdnsOutXfr 1 (-1) gen key dom
158 _ -> pdnsOutQ 1 (-1) gen key (rrType qt) dom
160 -- run one query by key from Namecoin, print domain object and answer
162 mainOne gen key qt = do
163 cfg <- readConfig confFile
164 mgr <- newManager defaultManagerSettings
165 dom <- queryDom (queryOpNmc cfg mgr (-1)) key
166 putStrLn $ ppShow dom
167 putStr $ pdnsOut gen key qt dom
169 -- get data from the file, print domain object and answer
171 mainFile gen key qt = do
172 dom <- queryDom queryOpFile key
173 putStrLn $ ppShow dom
174 putStr $ pdnsOut gen key qt dom
182 with f xs = case xs of
183 [qfqdn, qtype] -> f gen qfqdn qtype
184 _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\""
188 "-f":xs -> with mainFile xs
189 _ -> with mainOne args