module Network.Tendermint.Client.Internal.RPCClient where
import Control.Applicative ((<|>))
import Control.Exception (Exception)
import Control.Monad.Catch (throwM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader, ask)
import Data.Aeson (FromJSON (..), Result (..),
ToJSON (..), Value (..), fromJSON,
(.:), (.:?), (.=))
import qualified Data.Aeson as Aeson
import Data.Text (Text, unpack)
import qualified Network.HTTP.Simple as HTTP
import System.Random (randomIO)
data Request = Request
{ requestMethod :: !MethodName
, requestId :: !Int
, requestParams :: !Value
}
instance ToJSON Request where
toJSON (Request (MethodName method) rid params) = Aeson.object
[ "jsonrpc" .= String "2.0"
, "method" .= method
, "params" .= params
, "id" .= rid
]
data Response = Response
{ responseId :: !Int
, responseResult :: !(Either RpcError Value)
} deriving (Eq, Show)
instance FromJSON Response where
parseJSON = Aeson.withObject "JSON-RPC response object" $ \v ->
Response <$> v .: "id"
<*> (Right <$> v .: "result" <|> Left <$> v .: "error")
instance ToJSON Response where
toJSON (Response rid res) = Aeson.object
[ "jsonrpc" .= String "2.0"
, "id" .= rid
, case res of
Left e -> "error" .= e
Right r -> "result" .= r
]
data RpcError = RpcError
{ errCode :: !Int
, errMessage :: !Text
, errData :: !(Maybe Value)
} deriving Eq
instance Show RpcError where
show (RpcError code msg dat) =
"JSON-RPC error " ++ show code ++ ": " ++ unpack msg
++ ". Data: " ++ show dat
instance FromJSON RpcError where
parseJSON = Aeson.withObject "JSON-RPC error object" $ \v -> RpcError
<$> v .: "code"
<*> v .: "message"
<*> v .:? "data"
instance ToJSON RpcError where
toJSON (RpcError code msg _data)= Aeson.object
[ "code" .= code
, "message" .= msg
, "data" .= _data
]
data JsonRpcException
= ParsingException String
| CallException RpcError
deriving (Eq, Show)
instance Exception JsonRpcException
newtype MethodName = MethodName Text deriving (Eq, Show, ToJSON)
data Config = Config
{ cBaseHTTPRequest :: HTTP.Request
, withRequest :: Request -> IO ()
, withResponse :: Response -> IO ()
}
remote ::
( MonadIO m
, MonadReader Config m
, FromJSON output
, ToJSON input
)
=> MethodName
-> input
-> m output
{-# INLINE remote #-}
remote method input = do
rid <- abs <$> liftIO randomIO
Config baseHTTPRequest withReq withResp <- ask
let req = Request method rid (toJSON input)
httpReq = HTTP.setRequestBodyJSON req
$ HTTP.setRequestHeaders [("Content-Type", "application/json")]
$ HTTP.setRequestMethod "POST"
$ baseHTTPRequest
liftIO $ do
withReq req
resp <- HTTP.httpBS httpReq
rpcResponse <- decodeRPCResponse $ HTTP.getResponseBody resp
withResp rpcResponse
extractResult rpcResponse
where
decodeRPCResponse bs = case Aeson.eitherDecodeStrict bs of
Left err -> throwM $ ParsingException err
Right response -> pure response
extractResult (Response _ resp) = case resp of
Left rpcError -> throwM $ CallException rpcError
Right resultValue ->
case fromJSON resultValue of
Error err -> throwM $ ParsingException err
Success result -> pure result