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
 105               >>= 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 <- queryDom (queryOpNmc cfg mgr "_") key
 116   putStrLn $ ppShow dom
 117   putStr $ pdnsOut 1 "_" key RRTypeANY dom
 118
 119 -- using file backend for testing json domain data
 120
 121 mainFile key = do
 122   dom <- queryDom queryOpFile key
 123   putStrLn $ ppShow dom
 124   putStr $ pdnsOut 1 "+" key RRTypeANY dom
 125
 126 -- Entry point
 127
 128 main = do
 129   args <- getArgs
 130   case args of
 131     []         -> mainPdnsNmc
 132     [key]      -> mainOne key
 133     ["-f",key] -> mainFile key
 134     _ -> error $ "usage: empty args, or \"[-f] <fqdn>\""