wip merging imports
[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 -> String
55         -> IO (Either String ByteString)
56 queryOp mgr cfg qid key = do
57   rsp <- runResourceT $
58     httpLbs (qReq cfg (L.pack 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 <- mergeImport (queryOp mgr cfg qid) $
67                 emptyNmcDom { domImport = Just ("d/" ++ dn)}
68       return $ Right $ descendNmcDom 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)