2 {-# LANGUAGE OverloadedStrings #-}
6 import Prelude hiding (lookup, readFile)
7 import System.Environment
8 import System.Console.GetOpt
9 import System.IO hiding (readFile)
10 import System.IO.Error
11 import Data.Time.Clock.POSIX
12 import Control.Exception
13 import Text.Show.Pretty hiding (String)
15 import Control.Monad.State
16 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head, empty)
17 import qualified Data.ByteString.Char8 as C (pack)
18 import qualified Data.ByteString.Lazy.Char8 as L (pack)
19 import qualified Data.Text as T (pack)
20 import Data.List.Split
21 import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
22 import Data.Aeson (encode, decode, Value(..))
23 import Network.HTTP.Types
24 import Network.HTTP.Client
25 #if MIN_VERSION_http_client(0,3,0)
26 import Data.Default.Class (def)
28 import Data.Default (def)
38 confFile = "/etc/namecoin.conf"
40 -- HTTP/JsonRpc interface
42 qReq :: Config -> String -> Int -> Request
43 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
44 $ def { host = (C.pack (rpchost cf))
47 , requestHeaders = [ (hAccept, "application/json")
48 , (hContentType, "application/json")
49 , (hConnection, "Keep-Alive")
51 , requestBody = RequestBodyLBS $ encode $
52 JsonRpcRequest JsonRpcV1
55 (String (T.pack (show id)))
56 , checkStatus = \_ _ _ -> Nothing
59 qRsp :: Response ByteString -> Either String ByteString
61 case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
63 case (jrpcErrCode jerr) of
64 (-4) -> Right "{}" -- this is how non-existent entry is returned
65 _ -> Left $ "JsonRpc error response: " ++ (show jerr)
66 Right jrsp -> Right $ resValue jrsp
70 queryOpNmc cfg mgr qid key =
71 httpLbs (qReq cfg key qid) mgr >>= return . qRsp
73 queryOpFile key = catch (readFile key >>= return . Right)
74 (\e -> return (Left (show (e :: IOException))))
76 queryDom queryOp fqdn =
77 case reverse (splitOn "." fqdn) of
78 "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
79 _ -> return $ Left "Only \".bit\" domain is supported"
81 -- Number of ten minute intervals elapsed since creation of Namecoin
82 -- on April 18, 2011. Another option would be to use blockcount
83 -- but that would require another lookup, and we are cheap.
84 -- Yet another - to use (const - expires_in) from the lookup.
85 nmcAge = fmap (\x -> floor ((x - 1303070400) / 600)) getPOSIXTime
87 -- run a PowerDNS coprocess. Negotiate ABI version and execute requests.
91 cfg <- readConfig confFile
93 hSetBuffering stdin LineBuffering
94 hSetBuffering stdout LineBuffering
98 loopErr e = forever $ do
99 putStrLn $ "FAIL\t" ++ e
104 ["HELO", "1"] -> return 1
105 ["HELO", "2"] -> return 2
106 ["HELO", "3"] -> return 3
107 ["HELO", "4"] -> return 4
108 ["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x)
109 _ -> loopErr $ "bad HELO " ++ (show s)
111 putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
113 mgr <- newManager defaultManagerSettings
117 -- Save the name under current count, increment count for the next run
118 -- so the name is saved under the count that was put into the response.
119 stow name (count, cache) =
120 (if count >= 99 then 0 else count + 1
122 $ delete (if count >= 10 then count - 10 else count + 90) cache
126 mainloop = forever $ do
129 (count, cache) <- get
130 case pdnsParse ver l of
131 Left e -> io $ putStr $ pdnsReport e
134 PdnsRequestQ qname qtype id _ _ _ -> do
135 io $ queryDom (queryOpNmc cfg mgr id) qname
136 >>= putStr . (pdnsOutQ ver count gen qname qtype)
139 io $ putStrLn $ "LOG\tRequest number " ++ (show count)
140 ++ " id: " ++ (show id)
141 ++ " qname: " ++ qname
142 ++ " qtype: " ++ (show qtype)
143 ++ " cache size: " ++ (show (size cache))
146 put $ stow qname (count, cache)
147 PdnsRequestAXFR xrq zid -> do
150 io $ putStrLn $ "LOG\tAXFR request id=" ++ (show xrq)
151 ++ ", zone name: " ++ (show zid)
155 czone = fetch xrq cache
158 Just qname -> Just qname
159 -- if zid == czone then zid else Nothing -- paranoid
162 io $ queryDom (queryOpNmc cfg mgr xrq) qname
163 >>= putStr . (pdnsOutXfr ver count gen qname)
165 io $ putStr $ pdnsReport $ "AXFR cannot determine zone: "
166 ++ (show xrq) ++ ", " ++ (show zid)
167 PdnsRequestPing -> io $ putStrLn "END"
169 runStateT mainloop (0, empty) >> return ()
171 -- helper for command-line tools
173 pdnsOut gen key qt dom =
175 "AXFR" -> pdnsOutXfr 1 (-1) gen key dom
176 _ -> pdnsOutQ 1 (-1) gen key (rrType qt) dom
178 -- run one query by key from Namecoin, print domain object and answer
180 mainOne gen key qt = do
181 cfg <- readConfig confFile
182 mgr <- newManager defaultManagerSettings
183 dom <- queryDom (queryOpNmc cfg mgr (-1)) key
184 putStrLn $ ppShow dom
185 putStr $ pdnsOut gen key qt dom
187 -- get data from the file, print domain object and answer
189 mainFile gen key qt = do
190 dom <- queryDom queryOpFile key
191 putStrLn $ ppShow dom
192 putStr $ pdnsOut gen key qt dom
200 with f xs = case xs of
201 [qfqdn, qtype] -> f gen qfqdn qtype
202 _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\""
206 "-f":xs -> with mainFile xs
207 _ -> with mainOne args