module Network.Tendermint.Client.Internal.RPCClient where

import           Control.Applicative    ((<|>))
import           Control.Exception      (Exception)
import           Control.Monad          (forever)
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.ByteString        (ByteString)
import qualified Data.ByteString.Char8  as BS
import           Data.Text              (Text, unpack)
import qualified Network.HTTP.Simple    as HTTP
import qualified Network.WebSockets     as WS
import           System.Random          (randomIO)
import           Wuss                   (runSecureClient)

-- | JSON-RPC request.
data Request = Request
  { Request -> MethodName
requestMethod :: !MethodName
  , Request -> Int
requestId     :: !Int
  , Request -> Value
requestParams :: !Value
  }

instance ToJSON Request where
  toJSON :: Request -> Value
toJSON (Request (MethodName method :: Text
method) rid :: Int
rid params :: Value
params) = [Pair] -> Value
Aeson.object
    [ "jsonrpc" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text -> Value
String "2.0"
    , "method"  Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
method
    , "params"  Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
params
    , "id"      Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
rid
    ]

-- | JSON-RPC response.
data Response = Response
  { Response -> Int
responseId     :: !Int
  , Response -> Either RpcError Value
responseResult :: !(Either RpcError Value)
  } deriving (Response -> Response -> Bool
(Response -> Response -> Bool)
-> (Response -> Response -> Bool) -> Eq Response
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c== :: Response -> Response -> Bool
Eq, Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> String
$cshow :: Response -> String
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show)

instance FromJSON Response where
  parseJSON :: Value -> Parser Response
parseJSON = String -> (Object -> Parser Response) -> Value -> Parser Response
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject "JSON-RPC response object" ((Object -> Parser Response) -> Value -> Parser Response)
-> (Object -> Parser Response) -> Value -> Parser Response
forall a b. (a -> b) -> a -> b
$ \v :: Object
v ->
    Int -> Either RpcError Value -> Response
Response (Int -> Either RpcError Value -> Response)
-> Parser Int -> Parser (Either RpcError Value -> Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: "id"
             Parser (Either RpcError Value -> Response)
-> Parser (Either RpcError Value) -> Parser Response
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> Either RpcError Value
forall a b. b -> Either a b
Right (Value -> Either RpcError Value)
-> Parser Value -> Parser (Either RpcError Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: "result" Parser (Either RpcError Value)
-> Parser (Either RpcError Value) -> Parser (Either RpcError Value)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RpcError -> Either RpcError Value
forall a b. a -> Either a b
Left (RpcError -> Either RpcError Value)
-> Parser RpcError -> Parser (Either RpcError Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser RpcError
forall a. FromJSON a => Object -> Text -> Parser a
.: "error")

-- this instance is usefule for logging
instance ToJSON Response where
  toJSON :: Response -> Value
toJSON (Response rid :: Int
rid res :: Either RpcError Value
res) = [Pair] -> Value
Aeson.object
    [ "jsonrpc" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text -> Value
String "2.0"
    , "id"      Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
rid
    , case Either RpcError Value
res of
        Left e :: RpcError
e  -> "error" Text -> RpcError -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= RpcError
e
        Right r :: Value
r -> "result" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
r
    ]

-- | JSON-RPC error message
data RpcError = RpcError
  { RpcError -> Int
errCode    :: !Int
  , RpcError -> Text
errMessage :: !Text
  , RpcError -> Maybe Value
errData    :: !(Maybe Value)
  } deriving RpcError -> RpcError -> Bool
(RpcError -> RpcError -> Bool)
-> (RpcError -> RpcError -> Bool) -> Eq RpcError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RpcError -> RpcError -> Bool
$c/= :: RpcError -> RpcError -> Bool
== :: RpcError -> RpcError -> Bool
$c== :: RpcError -> RpcError -> Bool
Eq

instance Show RpcError where
  show :: RpcError -> String
show (RpcError code :: Int
code msg :: Text
msg dat :: Maybe Value
dat) =
      "JSON-RPC error " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
code String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
msg
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ ". Data: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Value -> String
forall a. Show a => a -> String
show Maybe Value
dat

instance FromJSON RpcError where
  parseJSON :: Value -> Parser RpcError
parseJSON = String -> (Object -> Parser RpcError) -> Value -> Parser RpcError
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject "JSON-RPC error object" ((Object -> Parser RpcError) -> Value -> Parser RpcError)
-> (Object -> Parser RpcError) -> Value -> Parser RpcError
forall a b. (a -> b) -> a -> b
$ \v :: Object
v -> Int -> Text -> Maybe Value -> RpcError
RpcError
    (Int -> Text -> Maybe Value -> RpcError)
-> Parser Int -> Parser (Text -> Maybe Value -> RpcError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: "code"
    Parser (Text -> Maybe Value -> RpcError)
-> Parser Text -> Parser (Maybe Value -> RpcError)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: "message"
    Parser (Maybe Value -> RpcError)
-> Parser (Maybe Value) -> Parser RpcError
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "data"

instance ToJSON RpcError where
  toJSON :: RpcError -> Value
toJSON (RpcError code :: Int
code msg :: Text
msg _data :: Maybe Value
_data)= [Pair] -> Value
Aeson.object
   [ "code" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
code
   , "message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
msg
   , "data" Text -> Maybe Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Value
_data
   ]


data JsonRpcException
  = ParsingException String
  | CallException RpcError
  deriving (JsonRpcException -> JsonRpcException -> Bool
(JsonRpcException -> JsonRpcException -> Bool)
-> (JsonRpcException -> JsonRpcException -> Bool)
-> Eq JsonRpcException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JsonRpcException -> JsonRpcException -> Bool
$c/= :: JsonRpcException -> JsonRpcException -> Bool
== :: JsonRpcException -> JsonRpcException -> Bool
$c== :: JsonRpcException -> JsonRpcException -> Bool
Eq, Int -> JsonRpcException -> ShowS
[JsonRpcException] -> ShowS
JsonRpcException -> String
(Int -> JsonRpcException -> ShowS)
-> (JsonRpcException -> String)
-> ([JsonRpcException] -> ShowS)
-> Show JsonRpcException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JsonRpcException] -> ShowS
$cshowList :: [JsonRpcException] -> ShowS
show :: JsonRpcException -> String
$cshow :: JsonRpcException -> String
showsPrec :: Int -> JsonRpcException -> ShowS
$cshowsPrec :: Int -> JsonRpcException -> ShowS
Show)

instance Exception JsonRpcException


-- | Name of called method.
newtype MethodName = MethodName Text deriving (MethodName -> MethodName -> Bool
(MethodName -> MethodName -> Bool)
-> (MethodName -> MethodName -> Bool) -> Eq MethodName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MethodName -> MethodName -> Bool
$c/= :: MethodName -> MethodName -> Bool
== :: MethodName -> MethodName -> Bool
$c== :: MethodName -> MethodName -> Bool
Eq, Int -> MethodName -> ShowS
[MethodName] -> ShowS
MethodName -> String
(Int -> MethodName -> ShowS)
-> (MethodName -> String)
-> ([MethodName] -> ShowS)
-> Show MethodName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MethodName] -> ShowS
$cshowList :: [MethodName] -> ShowS
show :: MethodName -> String
$cshow :: MethodName -> String
showsPrec :: Int -> MethodName -> ShowS
$cshowsPrec :: Int -> MethodName -> ShowS
Show, [MethodName] -> Encoding
[MethodName] -> Value
MethodName -> Encoding
MethodName -> Value
(MethodName -> Value)
-> (MethodName -> Encoding)
-> ([MethodName] -> Value)
-> ([MethodName] -> Encoding)
-> ToJSON MethodName
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MethodName] -> Encoding
$ctoEncodingList :: [MethodName] -> Encoding
toJSONList :: [MethodName] -> Value
$ctoJSONList :: [MethodName] -> Value
toEncoding :: MethodName -> Encoding
$ctoEncoding :: MethodName -> Encoding
toJSON :: MethodName -> Value
$ctoJSON :: MethodName -> Value
ToJSON)


-- | JSON-RPC client config
data Config = Config
  { Config -> Request
cBaseHTTPRequest :: HTTP.Request
  -- ^ A base request used for all JSON RPC requests
  , Config -> Request -> IO ()
withRequest      :: Request -> IO ()
  -- ^ An acion to perform before sending the 'HTTP.Request'
  , Config -> Response -> IO ()
withResponse     :: Response -> IO ()
  -- ^ An acion to perform before handling the 'HTTP.Response'
  , Config -> ByteString
cHost            :: ByteString
  -- ^ The host for client to connect
  , Config -> Int
cPort            :: Int
  -- ^ Port for client to use
  , Config -> Bool
tlsEnabled       :: Bool
  -- ^ Whether to use TLS or not
  }

remoteWS ::
  ( FromJSON output
  , ToJSON input
  )
  => Config
  -> MethodName
  -> input
  -> (output -> IO ())
  -> IO ()
remoteWS :: Config -> MethodName -> input -> (output -> IO ()) -> IO ()
remoteWS Config{..} method :: MethodName
method input :: input
input handler :: output -> IO ()
handler = do
  let host :: String
host = ByteString -> String
BS.unpack ByteString
cHost
      port :: Int
port = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
cPort
      tlsPort :: PortNumber
tlsPort = Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger (Integer -> PortNumber) -> Integer -> PortNumber
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
port
      path :: String
path = "/websocket"
  if Bool
tlsEnabled
    then String -> PortNumber -> String -> ClientApp () -> IO ()
forall a. String -> PortNumber -> String -> ClientApp a -> IO a
runSecureClient String
host PortNumber
tlsPort String
path ClientApp ()
ws
    else String -> Int -> String -> ClientApp () -> IO ()
forall a. String -> Int -> String -> ClientApp a -> IO a
WS.runClient String
host Int
port String
path ClientApp ()
ws
 where
  ws :: ClientApp ()
ws c :: Connection
c = do
    Int
rid <- Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
forall a. Random a => IO a
randomIO
    let rpcParams :: Value
rpcParams = input -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON input
input
        rpcRequest :: Request
rpcRequest = MethodName -> Int -> Value -> Request
Request MethodName
method Int
rid Value
rpcParams
        msg :: DataMessage
msg = ByteString -> DataMessage
WS.Binary (ByteString -> DataMessage) -> ByteString -> DataMessage
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Request
rpcRequest
    Connection -> DataMessage -> IO ()
WS.sendDataMessage Connection
c DataMessage
msg
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever  (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        ByteString
bs <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
c
        output
message <- ByteString -> IO output
forall a (m :: * -> *).
(FromJSON a, MonadThrow m) =>
ByteString -> m a
decodeRPCResponse ByteString
bs
        output -> IO ()
handler output
message
  decodeRPCResponse :: ByteString -> m a
decodeRPCResponse bs :: ByteString
bs = case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict ByteString
bs of
    Left err :: String
err       -> JsonRpcException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JsonRpcException -> m a) -> JsonRpcException -> m a
forall a b. (a -> b) -> a -> b
$ String -> JsonRpcException
ParsingException String
err
    Right response :: a
response -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
response



remote ::
  ( MonadIO m
  , MonadReader Config m
  , FromJSON output
  , ToJSON input
  )
  => MethodName
  -> input
  -> m output
{-# INLINE remote #-}
remote :: MethodName -> input -> m output
remote method :: MethodName
method input :: input
input = do
  Int
rid <- Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> m Int -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
forall a. Random a => IO a
randomIO
  Config baseHTTPRequest :: Request
baseHTTPRequest withReq :: Request -> IO ()
withReq withResp :: Response -> IO ()
withResp _ _ _ <- m Config
forall r (m :: * -> *). MonadReader r m => m r
ask
  let req :: Request
req = MethodName -> Int -> Value -> Request
Request MethodName
method Int
rid (input -> Value
forall a. ToJSON a => a -> Value
toJSON input
input)
      httpReq :: Request
httpReq = Request -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
HTTP.setRequestBodyJSON Request
req
              (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> Request -> Request
HTTP.setRequestHeaders [("Content-Type", "application/json")]
              (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestMethod "POST"
              (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
baseHTTPRequest
  IO output -> m output
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO output -> m output) -> IO output -> m output
forall a b. (a -> b) -> a -> b
$ do
    Request -> IO ()
withReq Request
req
    Response ByteString
resp <- Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
HTTP.httpBS Request
httpReq
    Response
rpcResponse <- ByteString -> IO Response
forall a (m :: * -> *).
(FromJSON a, MonadThrow m) =>
ByteString -> m a
decodeRPCResponse (ByteString -> IO Response) -> ByteString -> IO Response
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall a. Response a -> a
HTTP.getResponseBody Response ByteString
resp
    Response -> IO ()
withResp Response
rpcResponse
    Response -> IO output
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
Response -> m a
extractResult Response
rpcResponse
  where
    decodeRPCResponse :: ByteString -> m a
decodeRPCResponse bs :: ByteString
bs = case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict ByteString
bs of
      Left err :: String
err       -> JsonRpcException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JsonRpcException -> m a) -> JsonRpcException -> m a
forall a b. (a -> b) -> a -> b
$ String -> JsonRpcException
ParsingException String
err
      Right response :: a
response -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
response
    extractResult :: Response -> m a
extractResult (Response _ resp :: Either RpcError Value
resp) = case Either RpcError Value
resp of
      Left rpcError :: RpcError
rpcError -> JsonRpcException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JsonRpcException -> m a) -> JsonRpcException -> m a
forall a b. (a -> b) -> a -> b
$ RpcError -> JsonRpcException
CallException RpcError
rpcError
      Right resultValue :: Value
resultValue ->
        case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
resultValue of
          Error err :: String
err      -> JsonRpcException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JsonRpcException -> m a) -> JsonRpcException -> m a
forall a b. (a -> b) -> a -> b
$ String -> JsonRpcException
ParsingException String
err
          Success result :: a
result -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result