X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=pdns-pipe-nmc.hs;h=1f5a8918675d40f34ce66b49d59ae88c2e2df90c;hp=4bd87582d8a31d1467b4b96cfbd816445a242eea;hb=ea1648a0a1a63ef82c0159864e5efa4fc6297a1d;hpb=f05929457a786046899b21db566ae0428411d690 diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs index 4bd8758..1f5a891 100644 --- a/pdns-pipe-nmc.hs +++ b/pdns-pipe-nmc.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main where -import Prelude hiding (readFile) +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 @@ -15,11 +18,15 @@ import qualified Data.ByteString.Char8 as C (pack) 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 -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 @@ -32,7 +39,7 @@ confFile = "/etc/namecoin.conf" -- HTTP/JsonRpc interface -qReq :: Config -> String -> String -> 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) @@ -45,7 +52,7 @@ qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf)) JsonRpcRequest JsonRpcV1 "name_show" [L.pack q] - (String (T.pack id)) + (String (T.pack (show id))) , checkStatus = \_ _ _ -> Nothing } @@ -54,14 +61,14 @@ qRsp rsp = 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)))) @@ -71,7 +78,13 @@ queryDom queryOp fqdn = "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 @@ -79,6 +92,7 @@ mainPdnsNmc = do hSetBuffering stdin LineBuffering hSetBuffering stdout LineBuffering + ver <- do let loopErr e = forever $ do @@ -90,17 +104,28 @@ mainPdnsNmc = 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 (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 + gen <- io $ nmcAge (count, cache) <- get case pdnsParse ver l of Left e -> io $ putStr $ pdnsReport e @@ -108,40 +133,75 @@ mainPdnsNmc = do case preq of PdnsRequestQ qname qtype id _ _ _ -> do io $ queryDom (queryOpNmc cfg mgr id) qname - >>= putStr . (pdnsOut ver (show count) qname qtype) + >>= putStr . (pdnsOutQ ver count gen 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 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 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 - dom <- queryDom (queryOpNmc cfg mgr "_") key + mgr <- newManager defaultManagerSettings + dom <- queryDom (queryOpNmc cfg mgr (-1)) key putStrLn $ ppShow dom - putStr $ pdnsOut 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 "+" 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] {|ANY|AXFR}\"" + ++ " (type in caps)" case args of - [] -> mainPdnsNmc - [key] -> mainOne key - ["-f",key] -> mainFile key - _ -> error $ "usage: empty args, or \"[-f] \"" + [] -> mainPdnsNmc + "-f":xs -> with mainFile xs + _ -> with mainOne args