+{-# 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 Data.Aeson (encode, decode, Value(..))
import Network.HTTP.Types
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
-- Yet another - to use (const - expires_in) from the lookup.
nmcAge = fmap (\x -> floor ((x - 1303070400) / 600)) getPOSIXTime
--- Main entries
+-- run a PowerDNS coprocess. Negotiate ABI version and execute requests.
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)
PdnsRequestQ qname qtype id _ _ _ -> do
io $ queryDom (queryOpNmc cfg mgr id) qname
>>= putStr . (pdnsOutQ ver count gen qname qtype)
+ {-
-- debug
io $ putStrLn $ "LOG\tRequest number " ++ (show count)
++ " id: " ++ (show id)
++ " qtype: " ++ (show qtype)
++ " cache size: " ++ (show (size cache))
-- end debug
+ -}
put $ stow qname (count, cache)
- PdnsRequestAXFR xrq ->
- case fetch xrq cache of
- Nothing ->
- io $ putStr $
- pdnsReport ("AXFR for unknown id: " ++ (show xrq))
+ 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)
+ >>= 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 ()
"AXFR" -> pdnsOutXfr 1 (-1) gen key dom
_ -> pdnsOutQ 1 (-1) gen key (rrType qt) dom
--- query by key from Namecoin
+-- run one query by key from Namecoin, print domain object and answer
mainOne gen key qt = do
cfg <- readConfig confFile
putStrLn $ ppShow 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 gen key qt = do
dom <- queryDom queryOpFile key
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, qtype] -> mainOne gen key qtype
- ["-f" ,key, qtype] -> mainFile gen key qtype
- _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\" (type in caps)"
+ [] -> mainPdnsNmc
+ "-f":xs -> with mainFile xs
+ _ -> with mainOne args