Spellbind it under Cabal

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

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index 1786376112854000b368be6a410432a9875db356..49cce861d6140d489c6541cb02d02cfe62f6f4e9 100644 (file)
--- a/pdns-pipe-nmc.hs
+++ b/pdns-pipe-nmc.hs
@@ -4,8 +4,10 @@ module Main where
 
 import Prelude hiding (lookup, readFile)
 import System.Environment
 
 import Prelude hiding (lookup, readFile)
 import System.Environment

+import System.Console.GetOpt

 import System.IO hiding (readFile)
 import System.IO.Error
 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 +20,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.Class (def)

 
 import JsonRpcClient
 import Config
 
 import JsonRpcClient
 import Config


@@ -32,7 +34,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)


@@ -54,14 +56,14 @@ qRsp rsp =
     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
       Left  jerr -> 
         case (jrpcErrCode jerr) of
     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 =
       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))))
 
 queryOpFile key = catch (readFile key >>= return . Right)
                         (\e -> return (Left (show (e :: IOException))))


@@ -71,7 +73,13 @@ 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"
 

--- 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
 
 
 mainPdnsNmc = do
 


@@ -96,7 +104,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 +119,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 +127,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 . (pdnsOut 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 +136,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,33 +145,45 @@ 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 ()
 
             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
   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 1 (-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
   dom <- queryDom queryOpFile key
   putStrLn $ ppShow dom

-  putStr $ pdnsOut 1 (-1) key RRTypeANY dom
+  putStr $ pdnsOut gen key qt dom

 
 -- Entry point
 
 main = do
   args <- getArgs
 
 -- 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] <fqdn> {<TYPE>|ANY|AXFR}\""
+                ++ " (type in caps)"

   case args of
   case args of

-    []         -> mainPdnsNmc
-    [key]      -> mainOne key
-    ["-f",key] -> mainFile key
-    _ -> error $ "usage: empty args, or \"[-f] <fqdn>\""
+    []      -> mainPdnsNmc
+    "-f":xs -> with mainFile xs
+    _       -> with mainOne args