use current time to synthesize zone version in the SOA record

diff --git a/PowerDns.hs b/PowerDns.hs
index 0b05386f13058a992a827553566f0e99665a379e..457cdcae5b3be03b3160b0dc1f87e38b6b015bc6 100644 (file)
--- a/PowerDns.hs
+++ b/PowerDns.hs
@@ -99,8 +99,8 @@ pdnsReport :: String -> String
 pdnsReport err = "LOG\tError: " ++ err ++ "\nFAIL\n"
 
 -- | Produce answer to the Q request
 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
   let
     rrl = case rrt of
       RRTypeANY -> [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME


@@ -113,11 +113,11 @@ pdnsOutQ ver id name rrt edom =
       Left  err ->
         pdnsReport $ err ++ " in the " ++ (show rrt) ++ " query for " ++ name
       Right dom ->
       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
 
 -- | 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
   let
     allrrs = [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME
              , RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS


@@ -133,26 +133,26 @@ pdnsOutXfr ver id name edom =
       Left  err ->
         pdnsReport $ err ++ " in the AXFR request for " ++ name
       Right dom ->
       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)
   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
 
     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
 
   Nothing -> []
   Just xs -> xs
 

-justv accessor _ dom = case accessor dom of
+justv accessor _ _ dom = case accessor dom of

   Nothing -> []
   Just x  -> [x]
 
   Nothing -> []
   Just x  -> [x]
 


@@ -168,10 +168,10 @@ dataRR RRTypeA     = justl domIp
 dataRR RRTypeAAAA  = justl domIp6
 dataRR RRTypeCNAME = justv domAlias
 dataRR RRTypeDNAME = justv domTranslate
 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
   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 ++ "."
       _          -> "."
     email = case domEmail dom of
       Nothing   -> "hostmaster." ++ name ++ "."


@@ -185,15 +185,16 @@ dataRR RRTypeSOA   = \ name dom -> -- FIXME make realistic version field
     -- 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
     -- 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
   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
   case domDs dom of
     Nothing  -> []
     Just dss -> map dsStr dss


@@ -203,5 +204,5 @@ dataRR RRTypeDS    = \ _ dom ->
                ++ (show (dsHashType x)) ++ " "
                ++ (dsHashValue x)
 -- This only comes into play when data arrived _not_ from a PDNS request:
                ++ (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]
   ["; No data for bad request type " ++ e]

diff --git a/README.md b/README.md
index bac7d26f51eb6a86d4e33f7b1cd7a40d9e52e03d..6a6addc468f0b18f0f189796b9c60dd682ed2d34 100644 (file)
--- a/README.md
+++ b/README.md
@@ -120,13 +120,10 @@ recursive resolution of the subdomain tree is enforced for when
 SOA record is requested. That would invalidate the reason to have
 caching in the first place.
 
 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
 
 
 ## Getting the Software
 

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index f638851f3192dc751b5fbccad581cdf911e45767..8f26fa72864557e48b0bf04c16af4dd54068bfaf 100644 (file)
--- a/pdns-pipe-nmc.hs
+++ b/pdns-pipe-nmc.hs
@@ -6,6 +6,7 @@ import Prelude hiding (lookup, readFile)
 import System.Environment
 import System.IO hiding (readFile)
 import System.IO.Error
 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
 import Control.Exception
 import Text.Show.Pretty hiding (String)
 import Control.Monad


@@ -71,6 +72,12 @@ queryDom queryOp fqdn =
     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
     _           -> return $ Left "Only \".bit\" domain is supported"
 
     "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
 -- Main entries
 
 mainPdnsNmc = do


@@ -111,6 +118,7 @@ mainPdnsNmc = do
 
     mainloop = forever $ do
       l <- io getLine
 
     mainloop = forever $ do
       l <- io getLine

+      gen <- io $ nmcAge

       (count, cache) <- get
       case pdnsParse ver l of
         Left e -> io $ putStr $ pdnsReport e
       (count, cache) <- get
       case pdnsParse ver l of
         Left e -> io $ putStr $ pdnsReport e


@@ -118,7 +126,7 @@ mainPdnsNmc = do
           case preq of
             PdnsRequestQ qname qtype id _ _ _ -> do
               io $ queryDom (queryOpNmc cfg mgr id) qname
           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)
   -- debug
               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
                            ++ " id: " ++ (show id)


@@ -134,40 +142,41 @@ mainPdnsNmc = do
                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))
                 Just qname ->
                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
                     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
 
             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
   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
 
 
 -- 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
   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
 
 
 -- using file backend for testing json domain data
 

-mainFile key qt = do
+mainFile gen key qt = do

   dom <- queryDom queryOpFile key
   putStrLn $ ppShow dom
   dom <- queryDom queryOpFile key
   putStrLn $ ppShow dom

-  putStr $ pdnsOut key qt dom
+  putStr $ pdnsOut gen key qt dom

 
 -- Entry point
 
 main = do
   args <- getArgs
 
 -- Entry point
 
 main = do
   args <- getArgs

+  gen <- nmcAge

   case args of
     []                 -> mainPdnsNmc
   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)"
     _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\" (type in caps)"