make the binary suitable as interactive query tool
[pdns-pipe-nmc.git] / 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>\""