pdns-pipe-nmc.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Main where
   4
   5 import Control.Monad
   6 import qualified Data.ByteString.Char8 as C (pack, unpack)
   7 import qualified Data.ByteString.Lazy.Char8 as L (pack, unpack)
   8 import Data.ByteString.Lazy as BS hiding (reverse, putStrLn)
   9 import Data.List.Split
  10 import Data.Aeson (encode, decode, Value(..))
  11 import Network.HTTP.Types
  12 import Data.Conduit
  13 import Network.HTTP.Conduit
  14 import Data.JsonRpcClient
  15
  16 import Config
  17 import PowerDns
  18 import NmcJson
  19
  20 confFile = "/etc/namecoin.conf"
  21
  22 -- HTTP/JsonRpc interface
  23
  24 qReq :: Config -> ByteString -> ByteString -> Request m
  25 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
  26              $ def { host           = (C.pack (rpchost cf))
  27                    , port           = (rpcport cf)
  28                    , method         = "PUT"
  29                    , requestHeaders = [ (hAccept,      "application/json")
  30                                       , (hContentType, "application/json")
  31                                       , (hConnection,  "Keep-Alive")
  32                                       ]
  33                    , requestBody    = RequestBodyLBS $ encode $
  34                                       JsonRpcRequest JsonRpcV1
  35                                                      "name_show"
  36                                                      [q]
  37                                                      (String "pdns-nmc")
  38                    , checkStatus    = \_ _ _ -> Nothing
  39                    }
  40
  41 qRsp :: Response ByteString -> Either String NmcDom
  42 qRsp rsp =
  43     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
  44       Left  jerr -> Left $ "Unparseable response: " ++ (show (responseBody rsp))
  45       Right jrsp ->
  46         case decode (resValue jrsp) :: Maybe NmcDom of
  47           Nothing  -> Left $ "Unparseable value: " ++ (show (resValue jrsp))
  48           Just dom -> Right dom
  49
  50 -- NMC interface
  51
  52 queryNmc :: Manager -> Config -> String -> RRType -> String
  53          -> IO (Either String NmcDom)
  54 queryNmc mgr cfg fqdn qtype qid = do
  55   case reverse (splitOn "." fqdn) of
  56     "bit":dn:xs -> do
  57       rsp <- runResourceT $
  58              httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr
  59       return $ qRsp rsp
  60     _           ->
  61       return $ Left "Only \".bit\" domain is supported"
  62
  63 -- Main entry
  64
  65 main = do
  66
  67   cfg <- readConfig confFile
  68
  69   ver <- do
  70     let
  71       loopErr e = forever $ do
  72         putStrLn $ "FAIL\t" ++ e
  73         _ <- getLine
  74         return ()
  75     s <- getLine
  76     case words s of
  77       ["HELO", "1"] -> return 1
  78       ["HELO", "2"] -> return 2
  79       ["HELO", "3"] -> return 3
  80       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
  81       _             -> loopErr $ "bad HELO " ++ (show s)
  82
  83   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
  84
  85   mgr <- newManager def
  86
  87   print $ qReq cfg "d/nosuchdomain" "query-nmc"
  88   rsp <- runResourceT $ httpLbs (qReq cfg "d/nosuchdomain" "query-nmc") mgr
  89   print $ (statusCode . responseStatus) rsp
  90   putStrLn "===== complete response is:"
  91   print rsp
  92   let rbody = responseBody rsp
  93   putStrLn "===== response body is:"
  94   print rbody
  95   let result = parseJsonRpc rbody :: Either JsonRpcError NmcRes
  96   putStrLn "===== parsed response is:"
  97   print result
  98 --  print $ parseJsonRpc (responseBody rsp)
  99
 100   --forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)