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