pdns-pipe-nmc.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Main where
   4
   5 import Prelude hiding (readFile)
   6 import System.Environment
   7 import System.IO hiding (readFile)
   8 import System.IO.Error
   9 import Control.Exception
  10 import Text.Show.Pretty hiding (String)
  11 import Control.Monad
  12 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn, head)
  13 import qualified Data.ByteString.Char8 as C (pack)
  14 import qualified Data.ByteString.Lazy.Char8 as L (pack)
  15 import qualified Data.Text as T (pack)
  16 import Data.List.Split
  17 import Data.Aeson (encode, decode, Value(..))
  18 import Network.HTTP.Types
  19 import Data.Conduit
  20 import Network.HTTP.Conduit
  21
  22 import JsonRpcClient
  23 import Config
  24 import PowerDns
  25 import NmcRpc
  26 import NmcDom
  27 import NmcTransform
  28
  29 confFile = "/etc/namecoin.conf"
  30
  31 -- HTTP/JsonRpc interface
  32
  33 qReq :: Config -> String -> String -> Request m
  34 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
  35              $ def { host           = (C.pack (rpchost cf))
  36                    , port           = (rpcport cf)
  37                    , method         = "PUT"
  38                    , requestHeaders = [ (hAccept,      "application/json")
  39                                       , (hContentType, "application/json")
  40                                       , (hConnection,  "Keep-Alive")
  41                                       ]
  42                    , requestBody    = RequestBodyLBS $ encode $
  43                                       JsonRpcRequest JsonRpcV1
  44                                                      "name_show"
  45                                                      [L.pack q]
  46                                                      (String (T.pack id))
  47                    , checkStatus    = \_ _ _ -> Nothing
  48                    }
  49
  50 qRsp :: Response ByteString -> Either String ByteString
  51 qRsp rsp =
  52     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
  53       Left  jerr ->
  54         case (jrpcErrCode jerr) of
  55           -4 -> Right "{}"      -- this is how non-existent entry is returned
  56           _  -> Left $ "JsonRpc error response: " ++ (show jerr)
  57       Right jrsp -> Right $ resValue jrsp
  58
  59 -- NMC interface
  60
  61 queryNmc :: Manager -> Config -> String -> String
  62          -> IO (Either String NmcDom)
  63 queryNmc mgr cfg qid fqdn =
  64   case reverse (splitOn "." fqdn) of
  65     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
  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 mainNmc = 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 -- query by key from Namecoin
 111
 112 mainOne key = do
 113   cfg <- readConfig confFile
 114   mgr <- newManager def
 115   dom <- queryNmc mgr cfg "+" key
 116   putStrLn $ ppShow dom
 117   putStr $ pdnsOut 1 "+" key RRTypeANY dom
 118
 119 -- using file backend for testing json domain data
 120
 121 queryFile :: String -> IO (Either String ByteString)
 122 queryFile key = catch (readFile key >>= return . Right)
 123                       (\e -> return (Left (show (e :: IOException))))
 124
 125 mainFile key = do
 126   dom <- descendNmcDom queryFile [] (seedNmcDom key)
 127   putStrLn $ ppShow dom
 128   putStr $ pdnsOut 1 "+" key RRTypeANY dom
 129
 130 -- Entry point
 131
 132 main = do
 133   args <- getArgs
 134   case args of
 135     []         -> mainNmc
 136     [key]      -> mainOne key
 137     ["-f",key] -> mainFile key
 138     _ -> error $ "usage: empty args, or \"<key>\", or \"-f <key>\""