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 NmcJson
  20
  21 confFile = "/etc/namecoin.conf"
  22
  23 -- HTTP/JsonRpc interface
  24
  25 qReq :: Config -> ByteString -> ByteString -> Request m
  26 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
  27              $ def { host           = (C.pack (rpchost cf))
  28                    , port           = (rpcport cf)
  29                    , method         = "PUT"
  30                    , requestHeaders = [ (hAccept,      "application/json")
  31                                       , (hContentType, "application/json")
  32                                       , (hConnection,  "Keep-Alive")
  33                                       ]
  34                    , requestBody    = RequestBodyLBS $ encode $
  35                                       JsonRpcRequest JsonRpcV1
  36                                                      "name_show"
  37                                                      [q]
  38                                                      (String "pdns-nmc")
  39                    , checkStatus    = \_ _ _ -> Nothing
  40                    }
  41
  42 qRsp :: Response ByteString -> Either String NmcDom
  43 qRsp rsp =
  44     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
  45       Left  jerr ->
  46         case (jrpcErrCode jerr) of
  47           -4 -> Right emptyNmcDom
  48           _  -> Left $ "JsonRpc error response: " ++ (show jerr)
  49       Right jrsp ->
  50         case resValue jrsp of
  51           "" -> Right emptyNmcDom
  52           vstr ->
  53             case decode vstr :: Maybe NmcDom of
  54               Nothing  -> Left $ "Unparseable value: " ++ (show vstr)
  55               Just dom -> Right dom
  56
  57 -- NMC interface
  58
  59 queryNmc :: Manager -> Config -> String -> String
  60          -> IO (Either String NmcDom)
  61 queryNmc mgr cfg fqdn qid = do
  62   case reverse (splitOn "." fqdn) of
  63     "bit":dn:xs -> do
  64       rsp <- runResourceT $
  65              httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr
  66       return $ case qRsp rsp of
  67         Left  err -> Left err
  68         Right dom -> Right $ descendNmc 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)