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