document dots in the keys in the map, drop empty elems

[pdns-pipe-nmc.git] / pdns-pipe-nmc.hs

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index ab3e410de5951ed572dd20fdda70a0956a0b9f0e..e62a1e7d438f3d145da076b748856aa4fc2d527b 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


@@ -18,8 +19,8 @@ import Data.List.Split
 import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
 import Data.Aeson (encode, decode, Value(..))
 import Network.HTTP.Types
 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
+import Data.Default (def)

 
 import JsonRpcClient
 import Config
 
 import JsonRpcClient
 import Config


@@ -32,7 +33,7 @@ confFile = "/etc/namecoin.conf"
 
 -- HTTP/JsonRpc interface
 
 
 -- HTTP/JsonRpc interface
 

-qReq :: Config -> String -> Int -> 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)
 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
              $ def { host           = (C.pack (rpchost cf))
                    , port           = (rpcport cf)


@@ -61,7 +62,7 @@ qRsp rsp =
 -- NMC interface
 
 queryOpNmc cfg mgr qid key =
 -- 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))))
 
 queryOpFile key = catch (readFile key >>= return . Right)
                         (\e -> return (Left (show (e :: IOException))))


@@ -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


@@ -96,7 +103,7 @@ mainPdnsNmc = do
 
   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 
 
   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 

-  mgr <- newManager def
+  mgr <- newManager defaultManagerSettings

 
   let
     fetch = lookup
 
   let
     fetch = lookup


@@ -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,8 @@ 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)


@@ -126,6 +135,7 @@ mainPdnsNmc = do
                            ++ " qtype: " ++ (show qtype)
                            ++ " cache size: " ++ (show (size cache))
   -- end debug
                            ++ " qtype: " ++ (show qtype)
                            ++ " cache size: " ++ (show (size cache))
   -- end debug

+  -}

               put $ stow qname (count, cache)
             PdnsRequestAXFR xrq ->
               case fetch xrq cache of
               put $ stow qname (count, cache)
             PdnsRequestAXFR xrq ->
               case fetch xrq cache of


@@ -134,40 +144,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
   cfg <- readConfig confFile

-  mgr <- newManager def
+  mgr <- newManager defaultManagerSettings

   dom <- queryDom (queryOpNmc cfg mgr (-1)) key
   putStrLn $ ppShow dom
   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)"