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.Class (def)
25 -- if you have data-default-0.5.1 import this instead of Data.Default.Class:
26 -- import Data.Default (def)
35 confFile = "/etc/namecoin.conf"
37 -- HTTP/JsonRpc interface
39 qReq :: Config -> String -> Int -> Request
40 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
41 $ def { host = (C.pack (rpchost cf))
44 , requestHeaders = [ (hAccept, "application/json")
45 , (hContentType, "application/json")
46 , (hConnection, "Keep-Alive")
48 , requestBody = RequestBodyLBS $ encode $
49 JsonRpcRequest JsonRpcV1
52 (String (T.pack (show id)))
53 , checkStatus = \_ _ _ -> Nothing
56 qRsp :: Response ByteString -> Either String ByteString
58 case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
60 case (jrpcErrCode jerr) of
61 (-4) -> Right "{}" -- this is how non-existent entry is returned
62 _ -> Left $ "JsonRpc error response: " ++ (show jerr)
63 Right jrsp -> Right $ resValue jrsp
67 queryOpNmc cfg mgr qid key =
68 httpLbs (qReq cfg key qid) mgr >>= return . qRsp
70 queryOpFile key = catch (readFile key >>= return . Right)
71 (\e -> return (Left (show (e :: IOException))))
73 queryDom queryOp fqdn =
74 case reverse (splitOn "." fqdn) of
75 "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
76 _ -> return $ Left "Only \".bit\" domain is supported"
78 -- Number of ten minute intervals elapsed since creation of Namecoin
79 -- on April 18, 2011. Another option would be to use blockcount
80 -- but that would require another lookup, and we are cheap.
81 -- Yet another - to use (const - expires_in) from the lookup.
82 nmcAge = fmap (\x -> floor ((x - 1303070400) / 600)) getPOSIXTime
84 -- run a PowerDNS coprocess. Negotiate ABI version and execute requests.
88 cfg <- readConfig confFile
90 hSetBuffering stdin LineBuffering
91 hSetBuffering stdout LineBuffering
95 loopErr e = forever $ do
96 putStrLn $ "FAIL\t" ++ e
101 ["HELO", "1"] -> return 1
102 ["HELO", "2"] -> return 2
103 ["HELO", "3"] -> return 3
104 ["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x)
105 _ -> loopErr $ "bad HELO " ++ (show s)
107 putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
109 mgr <- newManager defaultManagerSettings
113 -- Save the name under current count, increment count for the next run
114 -- so the name is saved under the count that was put into the response.
115 stow name (count, cache) =
116 (if count >= 99 then 0 else count + 1
118 $ delete (if count >= 10 then count - 10 else count + 90) cache
122 mainloop = forever $ do
125 (count, cache) <- get
126 case pdnsParse ver l of
127 Left e -> io $ putStr $ pdnsReport e
130 PdnsRequestQ qname qtype id _ _ _ -> do
131 io $ queryDom (queryOpNmc cfg mgr id) qname
132 >>= putStr . (pdnsOutQ ver count gen qname qtype)
135 io $ putStrLn $ "LOG\tRequest number " ++ (show count)
136 ++ " id: " ++ (show id)
137 ++ " qname: " ++ qname
138 ++ " qtype: " ++ (show qtype)
139 ++ " cache size: " ++ (show (size cache))
142 put $ stow qname (count, cache)
143 PdnsRequestAXFR xrq ->
144 case fetch xrq cache of
147 pdnsReport ("AXFR for unknown id: " ++ (show xrq))
149 io $ queryDom (queryOpNmc cfg mgr xrq) qname
150 >>= putStr . (pdnsOutXfr ver count gen qname)
151 PdnsRequestPing -> io $ putStrLn "END"
153 runStateT mainloop (0, empty) >> return ()
155 -- helper for command-line tools
157 pdnsOut gen key qt dom =
159 "AXFR" -> pdnsOutXfr 1 (-1) gen key dom
160 _ -> pdnsOutQ 1 (-1) gen key (rrType qt) dom
162 -- run one query by key from Namecoin, print domain object and answer
164 mainOne gen key qt = do
165 cfg <- readConfig confFile
166 mgr <- newManager defaultManagerSettings
167 dom <- queryDom (queryOpNmc cfg mgr (-1)) key
168 putStrLn $ ppShow dom
169 putStr $ pdnsOut gen key qt dom
171 -- get data from the file, print domain object and answer
173 mainFile gen key qt = do
174 dom <- queryDom queryOpFile key
175 putStrLn $ ppShow dom
176 putStr $ pdnsOut gen key qt dom
184 with f xs = case xs of
185 [qfqdn, qtype] -> f gen qfqdn qtype
186 _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\""
190 "-f":xs -> with mainFile xs
191 _ -> with mainOne args