propagate forced TLSA onto subdomains

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

diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs
index a0d5fa23d417dbf4203d6812382e350a9b959163..1f5a8918675d40f34ce66b49d59ae88c2e2df90c 100644 (file)
--- a/pdns-pipe-nmc.hs
+++ b/pdns-pipe-nmc.hs
@@ -1,11 +1,14 @@
+{-# LANGUAGE CPP #-}

 {-# LANGUAGE OverloadedStrings #-}
 
 module Main where
 
 import Prelude hiding (lookup, readFile)
 import System.Environment
 {-# LANGUAGE OverloadedStrings #-}
 
 module Main where
 
 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 +21,12 @@ 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
+#if MIN_VERSION_http_client(0,3,0)
+import Data.Default.Class (def)
+#else
+import Data.Default (def)
+#endif

 
 import JsonRpcClient
 import Config
 
 import JsonRpcClient
 import Config


@@ -32,7 +39,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 +61,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 +78,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 +92,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


@@ -90,18 +104,28 @@ mainPdnsNmc = do
       ["HELO", "1"] -> return 1
       ["HELO", "2"] -> return 2
       ["HELO", "3"] -> return 3
       ["HELO", "1"] -> return 1
       ["HELO", "2"] -> return 2
       ["HELO", "3"] -> return 3

+      ["HELO", "4"] -> return 4

       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
       _             -> loopErr $ "bad HELO " ++ (show s)
 
   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 
       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
       _             -> loopErr $ "bad HELO " ++ (show s)
 
   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,47 +133,75 @@ 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)
                            ++ " qname: " ++ qname
                            ++ " qtype: " ++ (show qtype)
                            ++ " cache size: " ++ (show (size cache))
               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
                            ++ " id: " ++ (show id)
                            ++ " qname: " ++ qname
                            ++ " qtype: " ++ (show qtype)
                            ++ " cache size: " ++ (show (size cache))

-              put (if count >= 99 then 0 else count + 1,
-                   newcache count qname cache)
-            PdnsRequestAXFR xrq ->
-              case lookup xrq cache of
-                Nothing ->
-                  io $ putStr $
-                    pdnsReport ("AXFR for unknown id: " ++ (show xrq))
+  -- end debug
+  -}
+              put $ stow qname (count, cache)
+            PdnsRequestAXFR xrq zid -> do
+  {-
+  -- debug
+              io $ putStrLn $ "LOG\tAXFR request id=" ++ (show xrq)
+                                ++ ", zone name: " ++ (show zid)
+  -- end debug
+  -}
+              let
+                czone = fetch xrq cache
+                zone = case zid of
+                  Nothing    -> czone
+                  Just qname -> Just qname
+                    -- if zid == czone then zid else Nothing -- paranoid
+              case zone of

                 Just qname ->
                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
                 Just qname ->
                   io $ queryDom (queryOpNmc cfg mgr xrq) qname

-                    >>= putStr . (pdnsOutXfr ver count qname)
+                     >>= putStr . (pdnsOutXfr ver count gen qname)
+                Nothing ->
+                  io $ putStr $ pdnsReport $ "AXFR cannot determine zone: "
+                                          ++ (show xrq) ++ ", " ++ (show zid)

             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