cleanup main
[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 Data.ByteString.Lazy hiding (reverse, putStr, putStrLn)
8 import qualified Data.ByteString.Char8 as C (pack)
9 import qualified Data.ByteString.Lazy.Char8 as L (pack)
10 import qualified Data.Text as T (pack)
11 import Data.List.Split
12 import Data.Aeson (encode, decode, Value(..))
13 import Network.HTTP.Types
14 import Data.Conduit
15 import Network.HTTP.Conduit
16
17 import JsonRpcClient
18 import Config
19 import PowerDns
20 import NmcRpc
21 import NmcDom
22
23 confFile = "/etc/namecoin.conf"
24
25 -- HTTP/JsonRpc interface
26
27 qReq :: Config -> String -> String -> Request m
28 qReq cf q id = applyBasicAuth (C.pack (rpcuser cf)) (C.pack (rpcpassword cf))
29              $ def { host           = (C.pack (rpchost cf))
30                    , port           = (rpcport cf)
31                    , method         = "PUT"
32                    , requestHeaders = [ (hAccept,      "application/json")
33                                       , (hContentType, "application/json")
34                                       , (hConnection,  "Keep-Alive")
35                                       ]
36                    , requestBody    = RequestBodyLBS $ encode $
37                                       JsonRpcRequest JsonRpcV1
38                                                      "name_show"
39                                                      [L.pack q]
40                                                      (String (T.pack id))
41                    , checkStatus    = \_ _ _ -> Nothing
42                    }
43
44 qRsp :: Response ByteString -> Either String ByteString
45 qRsp rsp =
46     case parseJsonRpc (responseBody rsp) :: Either JsonRpcError NmcRes of
47       Left  jerr -> 
48         case (jrpcErrCode jerr) of
49           -4 -> Right "{}"      -- this is how non-existent entry is returned
50           _  -> Left $ "JsonRpc error response: " ++ (show jerr)
51       Right jrsp -> Right $ resValue jrsp
52
53 -- NMC interface
54
55 queryNmc :: Manager -> Config -> String -> String
56          -> IO (Either String NmcDom)
57 queryNmc mgr cfg qid fqdn =
58   case reverse (splitOn "." fqdn) of
59     "bit":dn:xs -> do
60       dom <- mergeImport queryOp $
61                 emptyNmcDom { domImport = Just ("d/" ++ dn)}
62       case dom of
63         Left  err  -> return $ Left err
64         Right dom' -> return $ Right $ descendNmcDom xs dom'
65     _           ->
66       return $ Left "Only \".bit\" domain is supported"
67   where
68     queryOp key = do
69       rsp <- runResourceT $ httpLbs (qReq cfg key qid) mgr
70       -- print $ qRsp rsp
71       return $ qRsp rsp
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 id qname >>= 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 "askid" str >>= putStr . (pdnsOut 1 "askid" str RRTypeANY)