wip split subdoms - cosmetic
[pdns-pipe-nmc.git] / JsonRpcClient.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module JsonRpcClient
4                 ( JsonRpcVersion(JsonRpcV1, JsonRpcV2)
5                 , JsonRpcRequest(..)
6                 , JsonRpcNotification
7                 , JsonRpcError(..)
8                 , parseJsonRpc
9                 ) where
10
11 import Data.ByteString.Lazy (ByteString)
12 import Control.Applicative ((<$>), (<*>), empty)
13 import Data.Either
14 import Data.Aeson
15
16 data JsonRpcVersion = JsonRpcV1 | JsonRpcV2
17         deriving (Show)
18
19 data JsonRpcRequest = JsonRpcRequest { jrpcVersion    :: JsonRpcVersion
20                                      , jrpcReqMethod  :: ByteString
21                                      , jrpcReqParams  :: [ByteString]
22                                      , jrpcReqId      :: Value
23                                      } deriving (Show)
24 instance ToJSON JsonRpcRequest where
25   toJSON (JsonRpcRequest version method params id) =
26     let l = [ "method" .= method, "params" .= params, "id" .= id ]
27     in case version of
28       JsonRpcV1 -> object l
29       JsonRpcV2 -> object $ ("jsonrpc" .= toJSON ("2.0" :: ByteString)):l
30
31 data JsonRpcNotification = JsonRpcNotification
32                                      { jrpcNtfVersion :: JsonRpcVersion
33                                      , jrpcNtfMethod  :: ByteString
34                                      , jrpcNtfParams  :: [ByteString]
35                                      } deriving (Show)
36 instance ToJSON JsonRpcNotification where
37   toJSON (JsonRpcNotification version method params) =
38     let l = [ "method" .= method, "params" .= params ]
39     in case version of
40       JsonRpcV1 -> object l
41       JsonRpcV2 -> object $ ("jsonrpc" .= toJSON ("2.0" :: ByteString)):l
42
43 data JsonRpcError = JsonRpcError { jrpcErrCode    :: Int
44                                  , jrpcErrMessage :: ByteString
45                                  , jrpcErrData    :: Maybe Value
46                                  } deriving (Show)
47 instance FromJSON JsonRpcError where
48   parseJSON (Object o) = JsonRpcError
49                                 <$> o .:  "code"
50                                 <*> o .:  "message"
51                                 <*> o .:? "data"
52   parseJSON x = return $ JsonRpcError
53                                 (-32600)
54                                 "Unparseable error object"
55                                 (Just (toJSON x))
56
57 data JsonRpcResponse = JsonRpcResponse { jrpcRspResult :: Maybe Value
58                                        , jrpcRspError  :: JsonRpcError
59                                        , jrpcRspId     :: Value
60                                        } deriving (Show)
61 instance FromJSON JsonRpcResponse where
62   parseJSON (Object o) = JsonRpcResponse
63                                 <$> o .:? "result"
64                                 <*> o .:  "error"
65                                 <*> o .:  "id"
66   parseJSON x = return $ JsonRpcResponse
67                                 Nothing
68                                 (JsonRpcError
69                                         (-32700)
70                                         "Unparseable response object"
71                                         (Just (toJSON x))
72                                 )
73                                 (String "n/a")
74
75 parseJsonRpc :: (FromJSON a) => ByteString -> Either JsonRpcError a
76 parseJsonRpc s = case (decode s :: Maybe JsonRpcResponse) of
77   Just (JsonRpcResponse result error id) ->
78     case result of
79       Just v -> case fromJSON v of
80         Success a -> Right a
81         Error s   -> Left $ JsonRpcError (-32900) "Unparseable result" (Just v)
82       Nothing -> Left error
83   Nothing -> Left $ JsonRpcError (-32800) "Unparseable response" (Just (toJSON s))