pdns-pipe-nmc.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Main where
   4
   5 import System.IO
   6 import Control.Monad
   7 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn)
   8 import qualified Data.ByteString.Char8 as C (pack)
   9 import qualified Data.ByteString.Lazy.Char8 as L (pack)
  10 import qualified Data.Text as T (pack)
  11 import Data.List.Split
  12 import Data.Aeson (encode, decode, Value(..))
  13 import Network.HTTP.Types
  14 import Data.Conduit
  15 import Network.HTTP.Conduit
  16
  17 import JsonRpcClient
  18 import Config
  19 import PowerDns
  20 import NmcRpc
  21 import NmcDom
  22
  23 confFile = "/etc/namecoin.conf"
  24
  25 -- HTTP/JsonRpc interface
  26
  27 qReq :: Config -> String -> String -> Request m
  28 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
  29              $ def { host           = (C.pack (rpchost cf))
  30                    , port           = (rpcport cf)
  31                    , method         = "PUT"
  32                    , requestHeaders = [ (hAccept,      "application/json")
  33                                       , (hContentType, "application/json")
  34                                       , (hConnection,  "Keep-Alive")
  35                                       ]
  36                    , requestBody    = RequestBodyLBS $ encode $
  37                                       JsonRpcRequest JsonRpcV1
  38                                                      "name_show"
  39                                                      [L.pack q]
  40                                                      (String (T.pack id))
  41                    , checkStatus    = \_ _ _ -> Nothing
  42                    }
  43
  44 qRsp :: Response ByteString -> Either String ByteString
  45 qRsp rsp =
  46     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
  47       Left  jerr ->
  48         case (jrpcErrCode jerr) of
  49           -4 -> Right "{}"      -- this is how non-existent entry is returned
  50           _  -> Left $ "JsonRpc error response: " ++ (show jerr)
  51       Right jrsp -> Right $ resValue jrsp
  52
  53 -- NMC interface
  54
  55 queryNmc :: Manager -> Config -> String -> String
  56          -> IO (Either String NmcDom)
  57 queryNmc mgr cfg qid fqdn =
  58   case reverse (splitOn "." fqdn) of
  59     "bit":dn:xs -> do
  60       dom <- mergeImport queryOp $
  61                 emptyNmcDom { domImport = Just ("d/" ++ dn)}
  62       case dom of
  63         Left  err  -> return $ Left err
  64         Right dom' -> return $ Right $ descendNmcDom xs dom'
  65     _           ->
  66       return $ Left "Only \".bit\" domain is supported"
  67   where
  68     queryOp key = do
  69       rsp <- runResourceT $ httpLbs (qReq cfg key qid) mgr
  70       -- print $ qRsp rsp
  71       return $ qRsp rsp
  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 id qname >>= 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 "askid" str >>= putStr . (pdnsOut 1 "askid" str RRTypeANY)