+{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Prelude hiding (lookup, readFile)
import System.Environment
+import System.Console.GetOpt
import System.IO hiding (readFile)
import System.IO.Error
+import Data.Time.Clock.POSIX
import Control.Exception
import Text.Show.Pretty hiding (String)
import Control.Monad
import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
import Data.Aeson (encode, decode, Value(..))
import Network.HTTP.Types
-import Data.Conduit
-import Network.HTTP.Conduit
+import Network.HTTP.Client
+#if MIN_VERSION_http_client(0,3,0)
+import Data.Default.Class (def)
+#else
+import Data.Default (def)
+#endif
import JsonRpcClient
import Config
-- HTTP/JsonRpc interface
-qReq :: Config -> String -> Int -> Request m
+qReq :: Config -> String -> Int -> Request
qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
$ def { host = (C.pack (rpchost cf))
, port = (rpcport cf)
case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
Left jerr ->
case (jrpcErrCode jerr) of
- -4 -> Right "{}" -- this is how non-existent entry is returned
- _ -> Left $ "JsonRpc error response: " ++ (show jerr)
+ (-4) -> Right "{}" -- this is how non-existent entry is returned
+ _ -> Left $ "JsonRpc error response: " ++ (show jerr)
Right jrsp -> Right $ resValue jrsp
-- NMC interface
queryOpNmc cfg mgr qid key =
- runResourceT (httpLbs (qReq cfg key qid) mgr) >>= return . qRsp
+ httpLbs (qReq cfg key qid) mgr >>= return . qRsp
queryOpFile key = catch (readFile key >>= return . Right)
(\e -> return (Left (show (e :: IOException))))
"bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
_ -> return $ Left "Only \".bit\" domain is supported"
--- Main entries
+-- Number of ten minute intervals elapsed since creation of Namecoin
+-- on April 18, 2011. Another option would be to use blockcount
+-- but that would require another lookup, and we are cheap.
+-- Yet another - to use (const - expires_in) from the lookup.
+nmcAge = fmap (\x -> floor ((x - 1303070400) / 600)) getPOSIXTime
+
+-- run a PowerDNS coprocess. Negotiate ABI version and execute requests.
mainPdnsNmc = do
hSetBuffering stdin LineBuffering
hSetBuffering stdout LineBuffering
+
ver <- do
let
loopErr e = forever $ do
["HELO", "1"] -> return 1
["HELO", "2"] -> return 2
["HELO", "3"] -> return 3
+ ["HELO", "4"] -> return 4
["HELO", x ] -> loopErr $ "unsupported ABI version " ++ (show x)
_ -> loopErr $ "bad HELO " ++ (show s)
putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
- mgr <- newManager def
+ mgr <- newManager defaultManagerSettings
+
let
- newcache count name = (insert count name)
- . (delete (if count >= 10 then count - 10 else count + 90))
+ fetch = lookup
+ -- Save the name under current count, increment count for the next run
+ -- so the name is saved under the count that was put into the response.
+ stow name (count, cache) =
+ (if count >= 99 then 0 else count + 1
+ , insert count name
+ $ delete (if count >= 10 then count - 10 else count + 90) cache
+ )
io = liftIO
+
mainloop = forever $ do
l <- io getLine
+ gen <- io $ nmcAge
(count, cache) <- get
case pdnsParse ver l of
Left e -> io $ putStr $ pdnsReport e
case preq of
PdnsRequestQ qname qtype id _ _ _ -> do
io $ queryDom (queryOpNmc cfg mgr id) qname
- >>= putStr . (pdnsOut ver count qname qtype)
+ >>= putStr . (pdnsOutQ ver count gen qname qtype)
+ {-
+ -- debug
io $ putStrLn $ "LOG\tRequest number " ++ (show count)
++ " id: " ++ (show id)
++ " qname: " ++ qname
++ " qtype: " ++ (show qtype)
++ " cache size: " ++ (show (size cache))
- put (if count >= 99 then 0 else count + 1,
- newcache count qname cache)
- PdnsRequestAXFR xrq ->
- case lookup xrq cache of
- Nothing ->
- io $ putStr $
- pdnsReport ("AXFR for unknown id: " ++ (show xrq))
+ -- end debug
+ -}
+ put $ stow qname (count, cache)
+ PdnsRequestAXFR xrq zid -> do
+ {-
+ -- debug
+ io $ putStrLn $ "LOG\tAXFR request id=" ++ (show xrq)
+ ++ ", zone name: " ++ (show zid)
+ -- end debug
+ -}
+ let
+ czone = fetch xrq cache
+ zone = case zid of
+ Nothing -> czone
+ Just qname -> Just qname
+ -- if zid == czone then zid else Nothing -- paranoid
+ case zone of
Just qname ->
io $ queryDom (queryOpNmc cfg mgr xrq) qname
- >>= putStr . (pdnsOutXfr ver count qname)
+ >>= putStr . (pdnsOutXfr ver count gen qname)
+ Nothing ->
+ io $ putStr $ pdnsReport $ "AXFR cannot determine zone: "
+ ++ (show xrq) ++ ", " ++ (show zid)
PdnsRequestPing -> io $ putStrLn "END"
+
runStateT mainloop (0, empty) >> return ()
--- query by key from Namecoin
+-- helper for command-line tools
+
+pdnsOut gen key qt dom =
+ case qt of
+ "AXFR" -> pdnsOutXfr 1 (-1) gen key dom
+ _ -> pdnsOutQ 1 (-1) gen key (rrType qt) dom
-mainOne key = do
+-- run one query by key from Namecoin, print domain object and answer
+
+mainOne gen key qt = do
cfg <- readConfig confFile
- mgr <- newManager def
+ mgr <- newManager defaultManagerSettings
dom <- queryDom (queryOpNmc cfg mgr (-1)) key
putStrLn $ ppShow dom
- putStr $ pdnsOut 1 (-1) key RRTypeANY dom
+ putStr $ pdnsOut gen key qt dom
--- using file backend for testing json domain data
+-- get data from the file, print domain object and answer
-mainFile key = do
+mainFile gen key qt = do
dom <- queryDom queryOpFile key
putStrLn $ ppShow dom
- putStr $ pdnsOut 1 (-1) key RRTypeANY dom
+ putStr $ pdnsOut gen key qt dom
-- Entry point
main = do
args <- getArgs
+ gen <- nmcAge
+ let
+ with f xs = case xs of
+ [qfqdn, qtype] -> f gen qfqdn qtype
+ _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\""
+ ++ " (type in caps)"
case args of
- [] -> mainPdnsNmc
- [key] -> mainOne key
- ["-f",key] -> mainFile key
- _ -> error $ "usage: empty args, or \"[-f] <fqdn>\""
+ [] -> mainPdnsNmc
+ "-f":xs -> with mainFile xs
+ _ -> with mainOne args
projects / pdns-pipe-nmc.git / blobdiff