pdns-pipe-nmc.hs

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