pdnsReport err = "LOG\tError: " ++ err ++ "\nFAIL\n"
-- | Produce answer to the Q request
-pdnsOutQ :: Int -> Int -> String -> RRType -> Either String NmcDom -> String
-pdnsOutQ ver id name rrt edom =
+pdnsOutQ :: Int -> Int -> Int -> String -> RRType -> Either String NmcDom -> String
+pdnsOutQ ver id gen name rrt edom =
let
rrl = case rrt of
RRTypeANY -> [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME
Left err ->
pdnsReport $ err ++ " in the " ++ (show rrt) ++ " query for " ++ name
Right dom ->
- formatDom ver id rrl name dom "END\n"
+ formatDom ver id gen rrl name dom "END\n"
-- | Produce answer to the AXFR request
-pdnsOutXfr :: Int -> Int -> String -> Either String NmcDom -> String
-pdnsOutXfr ver id name edom =
+pdnsOutXfr :: Int -> Int -> Int -> String -> Either String NmcDom -> String
+pdnsOutXfr ver id gen name edom =
let
allrrs = [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME
, RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS
Left err ->
pdnsReport $ err ++ " in the AXFR request for " ++ name
Right dom ->
- walkDom (formatDom ver id allrrs) "END\n" name dom
+ walkDom (formatDom ver id gen allrrs) "END\n" name dom
-formatDom ver id rrl name dom acc =
- foldr (\x a -> (formatRR ver id name dom x) ++ a) acc rrl
+formatDom ver id gen rrl name dom acc =
+ foldr (\x a -> (formatRR ver id gen name dom x) ++ a) acc rrl
-formatRR ver id name dom rrtype =
+formatRR ver id gen name dom rrtype =
foldr (\x a -> "DATA\t" ++ v3ext ++ name ++ "\tIN\t" ++ (show rrtype)
++ "\t" ++ ttl ++ "\t" ++ (show id) ++ "\t" ++ x ++ "\n" ++ a)
- "" $ dataRR rrtype name dom
+ "" $ dataRR rrtype gen name dom
where
v3ext = case ver of
3 -> "0\t1\t"
_ -> ""
ttl = show 3600
-justl accessor _ dom = case accessor dom of
+justl accessor _ _ dom = case accessor dom of
Nothing -> []
Just xs -> xs
-justv accessor _ dom = case accessor dom of
+justv accessor _ _ dom = case accessor dom of
Nothing -> []
Just x -> [x]
dataRR RRTypeAAAA = justl domIp6
dataRR RRTypeCNAME = justv domAlias
dataRR RRTypeDNAME = justv domTranslate
-dataRR RRTypeSOA = \ name dom -> -- FIXME make realistic version field
+dataRR RRTypeSOA = \ gen name dom ->
let
ns = case domNs dom of
- Just (x:_) -> x -- FIXME Terminate with a dot?
+ Just (x:_) -> x
_ -> "."
email = case domEmail dom of
Nothing -> "hostmaster." ++ name ++ "."
-- Alternative would be to carry "top-ness" as a parameter through
-- all the calls from the very top where we split the fqdn.
case splitOn (pack ".") (pack name) of
- [_,_] -> [ns ++ " " ++ email ++ " 0 10800 3600 604800 86400"]
+ [_,_] -> [ns ++ " " ++ email ++ " " ++ (show gen)
+ ++ " 10800 3600 604800 86400"]
_ -> []
-dataRR RRTypeRP = \ _ dom ->
+dataRR RRTypeRP = \ _ _ dom ->
case domEmail dom of
Nothing -> []
Just addr -> [(dotmail addr) ++ " ."]
dataRR RRTypeLOC = justv domLoc
-dataRR RRTypeNS = justl domNs -- FIXME Terminate with a dot?
-dataRR RRTypeDS = \ _ dom ->
+dataRR RRTypeNS = justl domNs
+dataRR RRTypeDS = \ _ _ dom ->
case domDs dom of
Nothing -> []
Just dss -> map dsStr dss
++ (show (dsHashType x)) ++ " "
++ (dsHashValue x)
-- This only comes into play when data arrived _not_ from a PDNS request:
-dataRR (RRTypeError e) = \ _ _ ->
+dataRR (RRTypeError e) = \ _ _ _ ->
["; No data for bad request type " ++ e]
SOA record is requested. That would invalidate the reason to have
caching in the first place.
-One possible workaround would be to use some derivative of absolute
-time, such as the number of hours elapsed since the epoch, for the
-SOA generation count.
-
-At the time of this writing, `pdns-pipe-nmc` simply reports zero as
-the SOA generation count. This leads to stale results until `pdnsd`
-is restarted.
+One possible workaround, currently implemented in `pdns-pipe-nmc`, is to
+use a derivative of absolute time, in our case the number of 10-munute
+intervals elapsed since Namecoin was concieved, as the SOA generation
+count.
## Getting the Software
import System.Environment
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
"bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
_ -> return $ Left "Only \".bit\" domain is supported"
+-- 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
+
-- Main entries
mainPdnsNmc = do
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 . (pdnsOutQ ver count qname qtype)
+ >>= putStr . (pdnsOutQ ver count gen qname qtype)
-- debug
io $ putStrLn $ "LOG\tRequest number " ++ (show count)
++ " id: " ++ (show id)
pdnsReport ("AXFR for unknown id: " ++ (show xrq))
Just qname ->
io $ queryDom (queryOpNmc cfg mgr xrq) qname
- >>= putStr . (pdnsOutXfr ver count qname)
+ >>= putStr . (pdnsOutXfr ver count gen qname)
PdnsRequestPing -> io $ putStrLn "END"
runStateT mainloop (0, empty) >> return ()
-- helper for command-line tools
-pdnsOut key qt dom =
+pdnsOut gen key qt dom =
case qt of
- "AXFR" -> pdnsOutXfr 1 (-1) key dom
- _ -> pdnsOutQ 1 (-1) key (rrType qt) dom
+ "AXFR" -> pdnsOutXfr 1 (-1) gen key dom
+ _ -> pdnsOutQ 1 (-1) gen key (rrType qt) dom
-- query by key from Namecoin
-mainOne key qt = do
+mainOne gen key qt = do
cfg <- readConfig confFile
mgr <- newManager defaultManagerSettings
dom <- queryDom (queryOpNmc cfg mgr (-1)) key
putStrLn $ ppShow dom
- putStr $ pdnsOut key qt dom
+ putStr $ pdnsOut gen key qt dom
-- using file backend for testing json domain data
-mainFile key qt = do
+mainFile gen key qt = do
dom <- queryDom queryOpFile key
putStrLn $ ppShow dom
- putStr $ pdnsOut key qt dom
+ putStr $ pdnsOut gen key qt dom
-- Entry point
main = do
args <- getArgs
+ gen <- nmcAge
case args of
[] -> mainPdnsNmc
- [key, qtype] -> mainOne key qtype
- ["-f" ,key, qtype] -> mainFile key qtype
+ [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)"
projects / pdns-pipe-nmc.git / commitdiff