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
  15 import JsonRpcClient
  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 ->
  45         case (jrpcErrCode jerr) of
  46           -4 -> Right emptyNmcDom
  47           _  -> Left $ "JsonRpc error response: " ++ (show jerr)
  48       Right jrsp ->
  49         case resValue jrsp of
  50           "" -> Right emptyNmcDom
  51           vstr ->
  52             case decode vstr :: Maybe NmcDom of
  53               Nothing  -> Left $ "Unparseable value: " ++ (show vstr)
  54               Just dom -> Right dom
  55
  56 -- NMC interface
  57
  58 queryNmc :: Manager -> Config -> String -> String
  59          -> IO (Either String NmcDom)
  60 queryNmc mgr cfg fqdn qid = do
  61   case reverse (splitOn "." fqdn) of
  62     "bit":dn:xs -> do
  63       rsp <- runResourceT $
  64              httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr
  65       return $ qRsp rsp
  66     _           ->
  67       return $ Left "Only \".bit\" domain is supported"
  68
  69 -- Main entry
  70
  71 main = do
  72
  73   cfg <- readConfig confFile
  74
  75   ver <- do
  76     let
  77       loopErr e = forever $ do
  78         putStrLn $ "FAIL\t" ++ e
  79         _ <- getLine
  80         return ()
  81     s <- getLine
  82     case words s of
  83       ["HELO", "1"] -> return 1
  84       ["HELO", "2"] -> return 2
  85       ["HELO", "3"] -> return 3
  86       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
  87       _             -> loopErr $ "bad HELO " ++ (show s)
  88
  89   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
  90
  91   mgr <- newManager def
  92   forever $ do
  93     l <- getLine
  94     case pdnsParse ver l of
  95       Left e -> putStrLn $ "ERROR\t" ++ e
  96       Right preq -> do
  97         case preq of
  98           PdnsRequestQ qname qtype id _ _ _ -> do
  99             ncres <- queryNmc mgr cfg qname id
 100             case ncres of
 101               Left  e   -> putStrLn $ "ERROR\t" ++ e
 102               Right dom -> putStrLn $ pdnsOut qtype dom
 103           PdnsRequestAXFR xfrreq ->
 104             putStrLn ("ERROR\tNo support for AXFR " ++ xfrreq)
 105           PdnsRequestPing -> putStrLn "OK"
 106
 107 -- for testing
 108
 109 ask str = do
 110   cfg <- readConfig confFile
 111   mgr <- newManager def
 112   ncres <- queryNmc mgr cfg str "test-req-id"
 113   case ncres of
 114     Left  e   -> putStrLn $ "ERROR\t" ++ e
 115     Right dom -> putStrLn $ pdnsOut RRTypeANY dom