move Json to top dir
[pdns-pipe-nmc.git] / pdns-pipe-nmc.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Main where
4
5 import Control.Monad
6 import qualified Data.ByteString.Char8 as C (pack, unpack)
7 import qualified Data.ByteString.Lazy.Char8 as L (pack, unpack)
8 import Data.ByteString.Lazy as BS hiding (reverse, putStrLn)
9 import Data.List.Split
10 import Data.Aeson (encode, decode, Value(..))
11 import Network.HTTP.Types
12 import Data.Conduit
13 import Network.HTTP.Conduit
14
15 import JsonRpcClient
16 import Config
17 import PowerDns
18 import NmcJson
19
20 confFile = "/etc/namecoin.conf"
21
22 -- HTTP/JsonRpc interface
23
24 qReq :: Config -> ByteString -> ByteString -> Request m
25 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
26              $ def { host           = (C.pack (rpchost cf))
27                    , port           = (rpcport cf)
28                    , method         = "PUT"
29                    , requestHeaders = [ (hAccept,      "application/json")
30                                       , (hContentType, "application/json")
31                                       , (hConnection,  "Keep-Alive")
32                                       ]
33                    , requestBody    = RequestBodyLBS $ encode $
34                                       JsonRpcRequest JsonRpcV1
35                                                      "name_show"
36                                                      [q]
37                                                      (String "pdns-nmc")
38                    , checkStatus    = \_ _ _ -> Nothing
39                    }
40
41 qRsp :: Response ByteString -> Either String NmcDom
42 qRsp rsp =
43     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
44       Left  jerr -> Left $ "Unparseable response: " ++ (show (responseBody rsp))
45       Right jrsp ->
46         case decode (resValue jrsp) :: Maybe NmcDom of
47           Nothing  -> Left $ "Unparseable value: " ++ (show (resValue jrsp))
48           Just dom -> Right dom
49
50 -- NMC interface
51
52 queryNmc :: Manager -> Config -> String -> RRType -> String
53          -> IO (Either String NmcDom)
54 queryNmc mgr cfg fqdn qtype qid = do
55   case reverse (splitOn "." fqdn) of
56     "bit":dn:xs -> do
57       rsp <- runResourceT $
58              httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr
59       return $ qRsp rsp
60     _           ->
61       return $ Left "Only \".bit\" domain is supported"
62
63 -- Main entry
64
65 main = do
66
67   cfg <- readConfig confFile
68
69   ver <- do
70     let
71       loopErr e = forever $ do
72         putStrLn $ "FAIL\t" ++ e
73         _ <- getLine
74         return ()
75     s <- getLine
76     case words s of
77       ["HELO", "1"] -> return 1
78       ["HELO", "2"] -> return 2
79       ["HELO", "3"] -> return 3
80       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
81       _             -> loopErr $ "bad HELO " ++ (show s)
82
83   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
84
85   mgr <- newManager def
86
87   print $ qReq cfg "d/nosuchdomain" "query-nmc"
88   rsp <- runResourceT $ httpLbs (qReq cfg "d/nosuchdomain" "query-nmc") mgr
89   print $ (statusCode . responseStatus) rsp
90   putStrLn "===== complete response is:"
91   print rsp
92   let rbody = responseBody rsp
93   putStrLn "===== response body is:"
94   print rbody
95   let result = parseJsonRpc rbody :: Either JsonRpcError NmcRes
96   putStrLn "===== parsed response is:"
97   print result
98 --  print $ parseJsonRpc (responseBody rsp)
99
100   --forever $ getLine >>= (pdnsOut uri) . (pdnsParse ver)