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