return empty domain if data not found
[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 -> 
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 queryNmc :: Manager -> Config -> String -> String
59          -> IO (Either String NmcDom)
60 queryNmc mgr cfg fqdn qid = do
61   case reverse (splitOn "." fqdn) of
62     "bit":dn:xs -> do
63       rsp <- runResourceT $
64              httpLbs (qReq cfg (L.pack ("d/" ++ dn)) (L.pack qid)) mgr
65       return $ qRsp rsp
66     _           ->
67       return $ Left "Only \".bit\" domain is supported"
68
69 -- Main entry
70
71 main = do
72
73   cfg <- readConfig confFile
74
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 -> putStrLn $ "ERROR\t" ++ e
96       Right preq -> do
97         case preq of
98           PdnsRequestQ qname qtype id _ _ _ -> do
99             ncres <- queryNmc mgr cfg qname id
100             case ncres of
101               Left  e   -> putStrLn $ "ERROR\t" ++ e
102               Right dom -> putStrLn $ pdnsOut qtype dom
103           PdnsRequestAXFR xfrreq ->
104             putStrLn ("ERROR\tNo support for AXFR " ++ xfrreq)
105           PdnsRequestPing -> putStrLn "OK"
106
107 -- for testing
108
109 ask str = do
110   cfg <- readConfig confFile
111   mgr <- newManager def
112   ncres <- queryNmc mgr cfg str "test-req-id"
113   case ncres of
114     Left  e   -> putStrLn $ "ERROR\t" ++ e
115     Right dom -> putStrLn $ pdnsOut RRTypeANY dom