1d2563788d0f4fa938ac685322f7d785966ee3f2
[pdns-pipe-nmc.git] / pdns-pipe-nmc.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Main where
4
5 import System.IO
6 import Control.Monad
7 import Data.ByteString.Lazy hiding (reverse, putStr, putStrLn)
8 import qualified Data.ByteString.Char8 as C (pack)
9 import qualified Data.ByteString.Lazy.Char8 as L (pack)
10 import qualified Data.Text as T (pack)
11 import Data.List.Split
12 import Data.Aeson (encode, decode, Value(..))
13 import Network.HTTP.Types
14 import Data.Conduit
15 import Network.HTTP.Conduit
16
17 import JsonRpcClient
18 import Config
19 import PowerDns
20 import NmcRpc
21 import NmcDom
22
23 confFile = "/etc/namecoin.conf"
24
25 -- HTTP/JsonRpc interface
26
27 qReq :: Config -> String -> String -> Request m
28 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
29              $ def { host           = (C.pack (rpchost cf))
30                    , port           = (rpcport cf)
31                    , method         = "PUT"
32                    , requestHeaders = [ (hAccept,      "application/json")
33                                       , (hContentType, "application/json")
34                                       , (hConnection,  "Keep-Alive")
35                                       ]
36                    , requestBody    = RequestBodyLBS $ encode $
37                                       JsonRpcRequest JsonRpcV1
38                                                      "name_show"
39                                                      [L.pack q]
40                                                      (String (T.pack id))
41                    , checkStatus    = \_ _ _ -> Nothing
42                    }
43
44 qRsp :: Response ByteString -> Either String ByteString
45 qRsp rsp =
46     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
47       Left  jerr -> 
48         case (jrpcErrCode jerr) of
49           -4 -> Right "{}"      -- this is how non-existent entry is returned
50           _  -> Left $ "JsonRpc error response: " ++ (show jerr)
51       Right jrsp -> Right $ resValue jrsp
52
53 -- NMC interface
54
55 queryNmc :: Manager -> Config -> String -> String
56          -> IO (Either String NmcDom)
57 queryNmc mgr cfg qid fqdn =
58   case reverse (splitOn "." fqdn) of
59     "bit":dn:xs -> descendNmcDom queryOp xs $ seedNmcDom dn
60     _           -> return $ Left "Only \".bit\" domain is supported"
61   where
62     queryOp key = do
63       rsp <- runResourceT $ httpLbs (qReq cfg key qid) mgr
64       -- print $ qRsp rsp
65       return $ qRsp rsp
66
67 -- Main entry
68
69 main = do
70
71   cfg <- readConfig confFile
72
73   hSetBuffering stdin  LineBuffering
74   hSetBuffering stdout LineBuffering
75   ver <- do
76     let
77       loopErr e = forever $ do
78         putStrLn $ "FAIL\t" ++ e
79         _ <- getLine
80         return ()
81     s <- getLine
82     case words s of
83       ["HELO", "1"] -> return 1
84       ["HELO", "2"] -> return 2
85       ["HELO", "3"] -> return 3
86       ["HELO",  x ] -> loopErr $ "unsupported ABI version " ++ (show x)
87       _             -> loopErr $ "bad HELO " ++ (show s)
88
89   putStrLn $ "OK\tDnsNmc ready to serve, protocol v." ++ (show ver)
90
91   mgr <- newManager def
92   forever $ do
93     l <- getLine
94     case pdnsParse ver l of
95       Left e -> putStr $ pdnsReport e
96       Right preq -> do
97         case preq of
98           PdnsRequestQ qname qtype id _ _ _ ->
99             queryNmc mgr cfg id qname >>= putStr . (pdnsOut ver id qname qtype)
100           PdnsRequestAXFR xfrreq ->
101             putStr $ pdnsReport ("No support for AXFR " ++ xfrreq)
102           PdnsRequestPing -> putStrLn "END"
103
104 -- for testing
105
106 ask str = do
107   cfg <- readConfig confFile
108   mgr <- newManager def
109   queryNmc mgr cfg "askid" str >>= putStr . (pdnsOut 1 "askid" str RRTypeANY)