test function to interactively ask about a domain
[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 resValue jrsp of
47           "" -> Right emptyNmcDom
48           vstr ->
49             case decode vstr :: Maybe NmcDom of
50               Nothing  -> Left $ "Unparseable value: " ++ (show vstr)
51               Just dom -> Right dom
52
53 -- NMC interface
54
55 queryNmc :: Manager -> Config -> String -> String
56          -> IO (Either String NmcDom)
57 queryNmc mgr cfg fqdn qid = do
58   case reverse (splitOn "." fqdn) of
59     "bit":dn:xs -> do
60       rsp <- runResourceT $
61              httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr
62       return $ qRsp rsp
63     _           ->
64       return $ Left "Only \".bit\" domain is supported"
65
66 -- Main entry
67
68 main = do
69
70   cfg <- readConfig confFile
71
72   ver <- do
73     let
74       loopErr e = forever $ do
75         putStrLn $ "FAIL\t" ++ e
76         _ <- getLine
77         return ()
78     s <- getLine
79     case words s of
80       ["HELO", "1"] -> return 1
81       ["HELO", "2"] -> return 2
82       ["HELO", "3"] -> return 3
83       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
84       _             -> loopErr $ "bad HELO " ++ (show s)
85
86   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
87
88   mgr <- newManager def
89   forever $ do
90     l <- getLine
91     case pdnsParse ver l of
92       Left e -> putStrLn $ "ERROR\t" ++ e
93       Right preq -> do
94         case preq of
95           PdnsRequestQ qname qtype id _ _ _ -> do
96             ncres <- queryNmc mgr cfg qname id
97             case ncres of
98               Left  e   -> putStrLn $ "ERROR\t" ++ e
99               Right dom -> putStrLn $ pdnsOut qtype dom
100           PdnsRequestAXFR xfrreq ->
101             putStrLn ("ERROR\tNo support for AXFR " ++ xfrreq)
102           PdnsRequestPing -> putStrLn "OK"
103
104 -- for testing
105
106 ask str = do
107   cfg <- readConfig confFile
108   mgr <- newManager def
109   ncres <- queryNmc mgr cfg str "test-req-id"
110   case ncres of
111     Left  e   -> putStrLn $ "ERROR\t" ++ e
112     Right dom -> putStrLn $ pdnsOut RRTypeANY dom