pdns-pipe-nmc.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3
   4 module Main where
   5
   6 import Prelude hiding (lookup, readFile)
   7 import System.Environment
   8 import System.Console.GetOpt
   9 import System.IO hiding (readFile)
  10 import System.IO.Error
  11 import Data.Time.Clock.POSIX
  12 import Control.Exception
  13 import Text.Show.Pretty hiding (String)
  14 import Control.Monad
  15 import Control.Monad.State
  16 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head, empty)
  17 import qualified Data.ByteString.Char8 as C (pack)
  18 import qualified Data.ByteString.Lazy.Char8 as L (pack)
  19 import qualified Data.Text as T (pack)
  20 import Data.List.Split
  21 import Data.Map.Lazy (Map, empty, lookup, insert, delete, size)
  22 import Data.Aeson (encode, decode, Value(..))
  23 import Network.HTTP.Types
  24 import Network.HTTP.Client
  25 #if MIN_VERSION_http_client(0,3,0)
  26 import Data.Default.Class (def)
  27 #else
  28 import Data.Default (def)
  29 #endif
  30
  31 import JsonRpcClient
  32 import Config
  33 import PowerDns
  34 import NmcRpc
  35 import NmcDom
  36 import NmcTransform
  37
  38 confFile = "/etc/namecoin.conf"
  39
  40 -- HTTP/JsonRpc interface
  41
  42 qReq :: Config -> String -> Int -> Request
  43 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
  44              $ def { host           = (C.pack (rpchost cf))
  45                    , port           = (rpcport cf)
  46                    , method         = "PUT"
  47                    , requestHeaders = [ (hAccept,      "application/json")
  48                                       , (hContentType, "application/json")
  49                                       , (hConnection,  "Keep-Alive")
  50                                       ]
  51                    , requestBody    = RequestBodyLBS $ encode $
  52                                       JsonRpcRequest JsonRpcV1
  53                                                      "name_show"
  54                                                      [L.pack q]
  55                                                      (String (T.pack (show id)))
  56                    , checkStatus    = \_ _ _ -> Nothing
  57                    }
  58
  59 qRsp :: Response ByteString -> Either String ByteString
  60 qRsp rsp =
  61     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
  62       Left  jerr ->
  63         case (jrpcErrCode jerr) of
  64           (-4) -> Right "{}"    -- this is how non-existent entry is returned
  65           _    -> Left $ "JsonRpc error response: " ++ (show jerr)
  66       Right jrsp -> Right $ resValue jrsp
  67
  68 -- NMC interface
  69
  70 queryOpNmc cfg mgr qid key =
  71   httpLbs (qReq cfg key qid) mgr >>= return . qRsp
  72
  73 queryOpFile key = catch (readFile key >>= return . Right)
  74                         (\e -> return (Left (show (e :: IOException))))
  75
  76 queryDom queryOp fqdn =
  77   case reverse (splitOn "." fqdn) of
  78     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
  79     _           -> return $ Left "Only \".bit\" domain is supported"
  80
  81 -- Number of ten minute intervals elapsed since creation of Namecoin
  82 -- on April 18, 2011. Another option would be to use blockcount
  83 -- but that would require another lookup, and we are cheap.
  84 -- Yet another - to use (const - expires_in) from the lookup.
  85 nmcAge = fmap (\x -> floor ((x - 1303070400) / 600)) getPOSIXTime
  86
  87 -- run a PowerDNS coprocess. Negotiate ABI version and execute requests.
  88
  89 mainPdnsNmc = do
  90
  91   cfg <- readConfig confFile
  92
  93   hSetBuffering stdin  LineBuffering
  94   hSetBuffering stdout LineBuffering
  95
  96   ver <- do
  97     let
  98       loopErr e = forever $ do
  99         putStrLn $ "FAIL\t" ++ e
 100         _ <- getLine
 101         return ()
 102     s <- getLine
 103     case words s of
 104       ["HELO", "1"] -> return 1
 105       ["HELO", "2"] -> return 2
 106       ["HELO", "3"] -> return 3
 107       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
 108       _             -> loopErr $ "bad HELO " ++ (show s)
 109
 110   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
 111
 112   mgr <- newManager defaultManagerSettings
 113
 114   let
 115     fetch = lookup
 116     -- Save the name under current count, increment count for the next run
 117     -- so the name is saved under the count that was put into the response.
 118     stow name (count, cache) =
 119       (if count >= 99 then 0 else count + 1
 120       , insert count name
 121           $ delete (if count >= 10 then count - 10 else count + 90) cache
 122       )
 123     io = liftIO
 124
 125     mainloop = forever $ do
 126       l <- io getLine
 127       gen <- io $ nmcAge
 128       (count, cache) <- get
 129       case pdnsParse ver l of
 130         Left e -> io $ putStr $ pdnsReport e
 131         Right preq -> do
 132           case preq of
 133             PdnsRequestQ qname qtype id _ _ _ -> do
 134               io $ queryDom (queryOpNmc cfg mgr id) qname
 135                      >>= putStr . (pdnsOutQ ver count gen qname qtype)
 136   {-
 137   -- debug
 138               io $ putStrLn $ "LOG\tRequest number " ++ (show count)
 139                            ++ " id: " ++ (show id)
 140                            ++ " qname: " ++ qname
 141                            ++ " qtype: " ++ (show qtype)
 142                            ++ " cache size: " ++ (show (size cache))
 143   -- end debug
 144   -}
 145               put $ stow qname (count, cache)
 146             PdnsRequestAXFR xrq ->
 147               case fetch xrq cache of
 148                 Nothing ->
 149                   io $ putStr $
 150                     pdnsReport ("AXFR for unknown id: " ++ (show xrq))
 151                 Just qname ->
 152                   io $ queryDom (queryOpNmc cfg mgr xrq) qname
 153                     >>= putStr . (pdnsOutXfr ver count gen qname)
 154             PdnsRequestPing -> io $ putStrLn "END"
 155
 156   runStateT mainloop (0, empty) >> return ()
 157
 158 -- helper for command-line tools
 159
 160 pdnsOut gen key qt dom =
 161   case qt of
 162     "AXFR" -> pdnsOutXfr 1 (-1) gen key dom
 163     _      -> pdnsOutQ 1 (-1) gen key (rrType qt) dom
 164
 165 -- run one query by key from Namecoin, print domain object and answer
 166
 167 mainOne gen key qt = do
 168   cfg <- readConfig confFile
 169   mgr <- newManager defaultManagerSettings
 170   dom <- queryDom (queryOpNmc cfg mgr (-1)) key
 171   putStrLn $ ppShow dom
 172   putStr $ pdnsOut gen key qt dom
 173
 174 -- get data from the file, print domain object and answer
 175
 176 mainFile gen key qt = do
 177   dom <- queryDom queryOpFile key
 178   putStrLn $ ppShow dom
 179   putStr $ pdnsOut gen key qt dom
 180
 181 -- Entry point
 182
 183 main = do
 184   args <- getArgs
 185   gen <- nmcAge
 186   let
 187     with f xs = case xs of
 188       [qfqdn, qtype]       -> f gen qfqdn qtype
 189       _ -> error $ "usage: empty args, or \"[-f] <fqdn> {<TYPE>|ANY|AXFR}\""
 190                 ++ " (type in caps)"
 191   case args of
 192     []      -> mainPdnsNmc
 193     "-f":xs -> with mainFile xs
 194     _       -> with mainOne args