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 queryOpNmc cfg mgr qid key =
  62   runResourceT (httpLbs (qReq cfg key qid) mgr) >>= return . qRsp
  63
  64 queryOpFile key = catch (readFile key >>= return . Right)
  65                         (\e -> return (Left (show (e :: IOException))))
  66
  67 queryDom queryOp fqdn =
  68   case reverse (splitOn "." fqdn) of
  69     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
  70     _           -> return $ Left "Only \".bit\" domain is supported"
  71
  72 -- Main entries
  73
  74 mainPdnsNmc = do
  75
  76   cfg <- readConfig confFile
  77
  78   hSetBuffering stdin  LineBuffering
  79   hSetBuffering stdout LineBuffering
  80   ver <- do
  81     let
  82       loopErr e = forever $ do
  83         putStrLn $ "FAIL\t" ++ e
  84         _ <- getLine
  85         return ()
  86     s <- getLine
  87     case words s of
  88       ["HELO", "1"] -> return 1
  89       ["HELO", "2"] -> return 2
  90       ["HELO", "3"] -> return 3
  91       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
  92       _             -> loopErr $ "bad HELO " ++ (show s)
  93
  94   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
  95
  96   mgr <- newManager def
  97   forever $ do
  98     l <- getLine
  99     case pdnsParse ver l of
 100       Left e -> putStr $ pdnsReport e
 101       Right preq -> do
 102         case preq of
 103           PdnsRequestQ qname qtype id _ _ _ ->
 104             queryDom (queryOpNmc cfg mgr id) qname >>= putStr . (pdnsOut ver id qname qtype)
 105           PdnsRequestAXFR xfrreq ->
 106             putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
 107           PdnsRequestPing -> putStrLn "END"
 108
 109 -- query by key from Namecoin
 110
 111 mainOne key = do
 112   cfg <- readConfig confFile
 113   mgr <- newManager def
 114   dom <- queryDom (queryOpNmc cfg mgr "_") key
 115   putStrLn $ ppShow dom
 116   putStr $ pdnsOut 1 "_" key RRTypeANY dom
 117
 118 -- using file backend for testing json domain data
 119
 120 mainFile key = do
 121   dom <- queryDom queryOpFile key
 122   putStrLn $ ppShow dom
 123   putStr $ pdnsOut 1 "+" key RRTypeANY dom
 124
 125 -- Entry point
 126
 127 main = do
 128   args <- getArgs
 129   case args of
 130     []         -> mainPdnsNmc
 131     [key]      -> mainOne key
 132     ["-f",key] -> mainFile key
 133     _ -> error $ "usage: empty args, or \"[-f] <fqdn>\""