Revert "wip TLSA"

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

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index 2ef82c239e837a484c28b4b180b106a265055dd4..5fc64fa1c940c96bff85b47f80ec7bc65943b307 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,10 @@ 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)
+-- if you have data-default-0.5.1 import this instead of Data.Default.Class:
+-- import Data.Default (def)

 
 import JsonRpcClient
 import Config
 
 import JsonRpcClient
 import Config


@@ -32,7 +36,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 +58,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 +75,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
 


@@ -79,6 +89,7 @@ mainPdnsNmc = do
 
   hSetBuffering stdin  LineBuffering
   hSetBuffering stdout LineBuffering
 
   hSetBuffering stdin  LineBuffering
   hSetBuffering stdout LineBuffering

+

   ver <- do
     let
       loopErr e = forever $ do
   ver <- do
     let
       loopErr e = forever $ do


@@ -95,13 +106,22 @@ 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
   let

-    newcache count name = (insert count name)
-      . (delete (if count >= 10 then count - 10 else count + 90))
+    fetch = lookup
+    -- Save the name under current count, increment count for the next run
+    -- so the name is saved under the count that was put into the response.
+    stow name (count, cache) =
+      (if count >= 99 then 0 else count + 1
+      , insert count name
+          $ delete (if count >= 10 then count - 10 else count + 90) cache
+      )

     io = liftIO
     io = liftIO

+

     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


@@ -109,7 +129,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)


@@ -117,41 +138,54 @@ mainPdnsNmc = do
                            ++ " qtype: " ++ (show qtype)
                            ++ " cache size: " ++ (show (size cache))
   -- end debug
                            ++ " qtype: " ++ (show qtype)
                            ++ " cache size: " ++ (show (size cache))
   -- end debug

-              put (if count >= 99 then 0 else count + 1,
-                   newcache count qname cache)
+  -}
+              put $ stow qname (count, cache)

             PdnsRequestAXFR xrq ->
             PdnsRequestAXFR xrq ->

-              case lookup xrq cache of
+              case fetch xrq cache of

                 Nothing ->
                   io $ putStr $
                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))
                 Just qname ->
                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
                 Nothing ->
                   io $ putStr $
                     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"
             PdnsRequestPing -> io $ putStrLn "END"

+

   runStateT mainloop (0, empty) >> return ()
 
   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