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 -> String
  55         -> IO (Either String ByteString)
  56 queryOp mgr cfg qid key = do
  57   rsp <- runResourceT $
  58     httpLbs (qReq cfg (L.pack 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 <- mergeImport (queryOp mgr cfg qid) $
  67                 emptyNmcDom { domImport = Just ("d/" ++ dn)}
  68       return $ Right $ descendNmcDom xs dom
  69     _           ->
  70       return $ Left "Only \".bit\" domain is supported"
  71
  72 -- Main entry
  73
  74 main = do
  75
  76   cfg <- readConfig confFile
  77
  78   hSetBuffering stdin  LineBuffering
  79   hSetBuffering stdout LineBuffering
  80   ver <- do
  81     let
  82       loopErr e = forever $ do
  83         putStrLn $ "FAIL\t" ++ e
  84         _ <- getLine
  85         return ()
  86     s <- getLine
  87     case words s of
  88       ["HELO", "1"] -> return 1
  89       ["HELO", "2"] -> return 2
  90       ["HELO", "3"] -> return 3
  91       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
  92       _             -> loopErr $ "bad HELO " ++ (show s)
  93
  94   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
  95
  96   mgr <- newManager def
  97   forever $ do
  98     l <- getLine
  99     case pdnsParse ver l of
 100       Left e -> putStr $ pdnsReport e
 101       Right preq -> do
 102         case preq of
 103           PdnsRequestQ qname qtype id _ _ _ ->
 104             queryNmc mgr cfg qname id >>= putStr . (pdnsOut ver id qname qtype)
 105           PdnsRequestAXFR xfrreq ->
 106             putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
 107           PdnsRequestPing -> putStrLn "END"
 108
 109 -- for testing
 110
 111 ask str = do
 112   cfg <- readConfig confFile
 113   mgr <- newManager def
 114   queryNmc mgr cfg str "askid" >>= putStr . (pdnsOut 1 "askid" str RRTypeANY)