pdns-pipe-nmc.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Main where
   4
   5 import System.IO
   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, putStr, putStrLn)
  10 import Data.List.Split
  11 import Data.Aeson (encode, decode, Value(..))
  12 import Network.HTTP.Types
  13 import Data.Conduit
  14 import Network.HTTP.Conduit
  15
  16 import JsonRpcClient
  17 import Config
  18 import PowerDns
  19 import NmcRpc
  20 import NmcDom
  21
  22 confFile = "/etc/namecoin.conf"
  23
  24 -- HTTP/JsonRpc interface
  25
  26 qReq :: Config -> ByteString -> ByteString -> Request m
  27 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
  28              $ def { host           = (C.pack (rpchost cf))
  29                    , port           = (rpcport cf)
  30                    , method         = "PUT"
  31                    , requestHeaders = [ (hAccept,      "application/json")
  32                                       , (hContentType, "application/json")
  33                                       , (hConnection,  "Keep-Alive")
  34                                       ]
  35                    , requestBody    = RequestBodyLBS $ encode $
  36                                       JsonRpcRequest JsonRpcV1
  37                                                      "name_show"
  38                                                      [q]
  39                                                      (String "pdns-nmc")
  40                    , checkStatus    = \_ _ _ -> Nothing
  41                    }
  42
  43 qRsp :: Response ByteString -> Either String ByteString
  44 qRsp rsp =
  45     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
  46       Left  jerr ->
  47         case (jrpcErrCode jerr) of
  48           -4 -> Right "{}"      -- this is how non-existent entry is returned
  49           _  -> Left $ "JsonRpc error response: " ++ (show jerr)
  50       Right jrsp -> Right $ resValue jrsp
  51
  52 -- NMC interface
  53
  54 queryOp :: Manager -> Config -> String -> ByteString
  55         -> IO (Either String ByteString)
  56 queryOp mgr cfg qid key = do
  57   rsp <- runResourceT $
  58     httpLbs (qReq cfg key (L.pack qid)) mgr
  59   return $ qRsp rsp
  60
  61 queryNmc :: Manager -> Config -> String -> String
  62          -> IO (Either String NmcDom)
  63 queryNmc mgr cfg fqdn qid = do
  64   case reverse (splitOn "." fqdn) of
  65     "bit":dn:xs -> do
  66       dom <- queryDom (queryOp mgr cfg qid) (L.pack ("d/" ++ dn))
  67       return $ case dom of
  68         Left  err -> Left err
  69         Right dom -> Right $ descendNmc xs dom
  70     _           ->
  71       return $ Left "Only \".bit\" domain is supported"
  72
  73 -- Main entry
  74
  75 main = do
  76
  77   cfg <- readConfig confFile
  78
  79   hSetBuffering stdin  LineBuffering
  80   hSetBuffering stdout LineBuffering
  81   ver <- do
  82     let
  83       loopErr e = forever $ do
  84         putStrLn $ "FAIL\t" ++ e
  85         _ <- getLine
  86         return ()
  87     s <- getLine
  88     case words s of
  89       ["HELO", "1"] -> return 1
  90       ["HELO", "2"] -> return 2
  91       ["HELO", "3"] -> return 3
  92       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
  93       _             -> loopErr $ "bad HELO " ++ (show s)
  94
  95   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
  96
  97   mgr <- newManager def
  98   forever $ do
  99     l <- getLine
 100     case pdnsParse ver l of
 101       Left e -> putStr $ pdnsReport e
 102       Right preq -> do
 103         case preq of
 104           PdnsRequestQ qname qtype id _ _ _ ->
 105             queryNmc mgr cfg qname id >>= putStr . (pdnsOut ver id qname qtype)
 106           PdnsRequestAXFR xfrreq ->
 107             putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
 108           PdnsRequestPing -> putStrLn "END"
 109
 110 -- for testing
 111
 112 ask str = do
 113   cfg <- readConfig confFile
 114   mgr <- newManager def
 115   queryNmc mgr cfg str "askid" >>= putStr . (pdnsOut 1 "askid" str RRTypeANY)