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