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 import NmcTransform
  23
  24 confFile = "/etc/namecoin.conf"
  25
  26 -- HTTP/JsonRpc interface
  27
  28 qReq :: Config -> String -> String -> Request m
  29 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
  30              $ def { host           = (C.pack (rpchost cf))
  31                    , port           = (rpcport cf)
  32                    , method         = "PUT"
  33                    , requestHeaders = [ (hAccept,      "application/json")
  34                                       , (hContentType, "application/json")
  35                                       , (hConnection,  "Keep-Alive")
  36                                       ]
  37                    , requestBody    = RequestBodyLBS $ encode $
  38                                       JsonRpcRequest JsonRpcV1
  39                                                      "name_show"
  40                                                      [L.pack q]
  41                                                      (String (T.pack id))
  42                    , checkStatus    = \_ _ _ -> Nothing
  43                    }
  44
  45 qRsp :: Response ByteString -> Either String ByteString
  46 qRsp rsp =
  47     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
  48       Left  jerr ->
  49         case (jrpcErrCode jerr) of
  50           -4 -> Right "{}"      -- this is how non-existent entry is returned
  51           _  -> Left $ "JsonRpc error response: " ++ (show jerr)
  52       Right jrsp -> Right $ resValue jrsp
  53
  54 -- NMC interface
  55
  56 queryNmc :: Manager -> Config -> String -> String
  57          -> IO (Either String NmcDom)
  58 queryNmc mgr cfg qid fqdn =
  59   case reverse (splitOn "." fqdn) of
  60     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
  61     _           -> return $ Left "Only \".bit\" domain is supported"
  62   where
  63     queryOp key = do
  64       rsp <- runResourceT $ httpLbs (qReq cfg key qid) mgr
  65       -- print $ qRsp rsp
  66       return $ qRsp rsp
  67
  68 -- Main entry
  69
  70 main = do
  71
  72   cfg <- readConfig confFile
  73
  74   hSetBuffering stdin  LineBuffering
  75   hSetBuffering stdout LineBuffering
  76   ver <- do
  77     let
  78       loopErr e = forever $ do
  79         putStrLn $ "FAIL\t" ++ e
  80         _ <- getLine
  81         return ()
  82     s <- getLine
  83     case words s of
  84       ["HELO", "1"] -> return 1
  85       ["HELO", "2"] -> return 2
  86       ["HELO", "3"] -> return 3
  87       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
  88       _             -> loopErr $ "bad HELO " ++ (show s)
  89
  90   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
  91
  92   mgr <- newManager def
  93   forever $ do
  94     l <- getLine
  95     case pdnsParse ver l of
  96       Left e -> putStr $ pdnsReport e
  97       Right preq -> do
  98         case preq of
  99           PdnsRequestQ qname qtype id _ _ _ ->
 100             queryNmc mgr cfg id qname >>= putStr . (pdnsOut ver id qname qtype)
 101           PdnsRequestAXFR xfrreq ->
 102             putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
 103           PdnsRequestPing -> putStrLn "END"
 104
 105 -- for testing
 106
 107 ask str = do
 108   cfg <- readConfig confFile
 109   mgr <- newManager def
 110   queryNmc mgr cfg "askid" str >>= putStr . (pdnsOut 1 "askid" str RRTypeANY)