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 -> descendNmcDom queryOp xs $ seedNmcDom dn
  60     _           -> return $ Left "Only \".bit\" domain is supported"
  61   where
  62     queryOp key = do
  63       rsp <- runResourceT $ httpLbs (qReq cfg key qid) mgr
  64       -- print $ qRsp rsp
  65       return $ qRsp rsp
  66
  67 -- Main entry
  68
  69 main = do
  70
  71   cfg <- readConfig confFile
  72
  73   hSetBuffering stdin  LineBuffering
  74   hSetBuffering stdout LineBuffering
  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 -> putStr $ pdnsReport e
  96       Right preq -> do
  97         case preq of
  98           PdnsRequestQ qname qtype id _ _ _ ->
  99             queryNmc mgr cfg id qname >>= putStr . (pdnsOut ver id qname qtype)
 100           PdnsRequestAXFR xfrreq ->
 101             putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
 102           PdnsRequestPing -> putStrLn "END"
 103
 104 -- for testing
 105
 106 ask str = do
 107   cfg <- readConfig confFile
 108   mgr <- newManager def
 109   queryNmc mgr cfg "askid" str >>= putStr . (pdnsOut 1 "askid" str RRTypeANY)