module Main where
-import Prelude hiding (readFile)
+import Prelude hiding (lookup, readFile)
import System.Environment
import System.IO hiding (readFile)
import System.IO.Error
import qualified Data.ByteString.Lazy.Char8 as L (pack)
import qualified Data.Text as T (pack)
import Data.List.Split
-import Data.Map.Lazy (Map, empty, insert, delete, size)
+import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
import Data.Aeson (encode, decode, Value(..))
import Network.HTTP.Types
import Data.Conduit
-- HTTP/JsonRpc interface
-qReq :: Config -> String -> String -> Request m
+qReq :: Config -> String -> Int -> Request m
qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
$ def { host = (C.pack (rpchost cf))
, port = (rpcport cf)
JsonRpcRequest JsonRpcV1
"name_show"
[L.pack q]
- (String (T.pack id))
+ (String (T.pack (show id)))
, checkStatus = \_ _ _ -> Nothing
}
hSetBuffering stdin LineBuffering
hSetBuffering stdout LineBuffering
+
ver <- do
let
loopErr e = forever $ do
putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
mgr <- newManager def
+
let
- newcache count name = (insert count name) . (delete (count - 10))
+ 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
(count, cache) <- get
case preq of
PdnsRequestQ qname qtype id _ _ _ -> do
io $ queryDom (queryOpNmc cfg mgr id) qname
- >>= putStr . (pdnsOut ver (show count) qname qtype)
+ >>= putStr . (pdnsOut ver count qname qtype)
+ -- debug
io $ putStrLn $ "LOG\tRequest number " ++ (show count)
- ++ " id: " ++ id
+ ++ " id: " ++ (show id)
++ " qname: " ++ qname
++ " qtype: " ++ (show qtype)
++ " cache size: " ++ (show (size cache))
- put (count + 1, newcache count qname cache)
- PdnsRequestAXFR xfrreq ->
- io $ putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
+ -- end debug
+ put $ stow qname (count, cache)
+ PdnsRequestAXFR xrq ->
+ case fetch xrq cache of
+ Nothing ->
+ io $ putStr $
+ pdnsReport ("AXFR for unknown id: " ++ (show xrq))
+ Just qname ->
+ io $ queryDom (queryOpNmc cfg mgr xrq) qname
+ >>= putStr . (pdnsOutXfr ver count qname)
PdnsRequestPing -> io $ putStrLn "END"
+
runStateT mainloop (0, empty) >> return ()
-- query by key from Namecoin
-mainOne key = do
+mainOne key qt = do
cfg <- readConfig confFile
mgr <- newManager def
- dom <- queryDom (queryOpNmc cfg mgr "_") key
+ dom <- queryDom (queryOpNmc cfg mgr (-1)) key
putStrLn $ ppShow dom
- putStr $ pdnsOut 1 "_" key RRTypeANY dom
+ putStr $ pdnsOut 1 (-1) key qt dom
-- using file backend for testing json domain data
-mainFile key = do
+mainFile key qt = do
dom <- queryDom queryOpFile key
putStrLn $ ppShow dom
- putStr $ pdnsOut 1 "+" key RRTypeANY dom
+ putStr $ pdnsOut 1 (-1) key qt dom
-- Entry point
main = do
args <- getArgs
case args of
- [] -> mainPdnsNmc
- [key] -> mainOne key
- ["-f",key] -> mainFile key
- _ -> error $ "usage: empty args, or \"[-f] <fqdn>\""
+ [] -> mainPdnsNmc
+ [key, qtype] -> mainOne key (rrType qtype)
+ ["-f" ,key, qtype] -> mainFile key (rrType qtype)
+ _ -> error $ "usage: empty args, or \"[-f] <fqdn> <QTYPE>\" (type in caps)"