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