{-# LANGUAGE CPP                    #-}
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}

-- |
-- Module      :  Network.JsonRpc.TinyClient
-- Copyright   :  Aleksandr Krupenkin 2016-2018
-- License     :  Apache-2.0
--
-- Maintainer  :  mail@akru.me
-- Stability   :  experimental
-- Portability :  portable
--
-- Tiny JSON-RPC 2.0 client.
-- Functions for implementing the client side of JSON-RPC 2.0.
-- See <http://www.jsonrpc.org/specification>.
--
-- If you have monad with 'MonadIO', 'MonadThrow' and 'MonadReader' instances,
-- it can be used as base for JSON-RPC calls.
--
-- Example:
--
-- @
--   newtype MyMonad a = ...
--
--   instance JsonRpc MyMonad
--
--   foo :: Mymonad Text
--   foo = remote "foo"
-- @
--
-- Arguments of function are stored into @params@ request array.
--
-- Example:
--
-- @
--   myMethod :: JsonRpc m => Int -> Bool -> m String
--   myMethod = remote "myMethod"
-- @
--

module Network.JsonRpc.TinyClient
    (
    -- * The JSON-RPC remote call monad
      JsonRpc(..)
    , MethodName

    -- * JSON-RPC client settings
    , JsonRpcClient(..)
    , defaultSettings

    -- * Error handling
    , JsonRpcException(..)
    , RpcError(..)
    ) where

import           Control.Applicative     ((<|>))
import           Control.Exception       (Exception)
import           Control.Monad           ((<=<))
import           Control.Monad.Catch     (MonadThrow (..))
import           Control.Monad.IO.Class  (MonadIO (..))
import           Control.Monad.State     (MonadState, get)
import           Data.Aeson              (FromJSON (..), ToJSON (..),
                                          Value (String), eitherDecode, encode,
                                          object, withObject, (.:), (.:?), (.=))
import           Data.ByteString.Lazy    (ByteString)
import           Data.Text               (Text, unpack)
import           Network.HTTP.Client     (Manager, RequestBody (RequestBodyLBS),
                                          httpLbs, method, newManager,
                                          parseRequest, requestBody,
                                          requestHeaders, responseBody)
import           Network.HTTP.Client.TLS (tlsManagerSettings)
import qualified Network.WebSockets      as WS (Connection, receiveData,
                                                sendTextData)
import           System.Random           (randomRIO)

-- | JSON-RPC monad constrait.
type JsonRpcM m = (MonadIO m, MonadThrow m, MonadState JsonRpcClient m)

-- | JSON-RPC client state vars.
data JsonRpcClient = JsonRpcHttpClient
    { JsonRpcClient -> Manager
jsonRpcManager :: Manager
    -- ^ HTTP connection manager.
    , JsonRpcClient -> String
jsonRpcServer  :: String
    -- ^ Remote server URI.
    }
    | JsonRpcWsClient
    { JsonRpcClient -> Connection
jsonRpcWsConnection :: WS.Connection
    -- ^ WebSocket connection.
    }

-- | Create default 'JsonRpcClient' settings.
defaultSettings :: MonadIO m
                => String           -- ^ JSON-RPC server URI
                -> m JsonRpcClient
defaultSettings :: String -> m JsonRpcClient
defaultSettings String
srv = IO JsonRpcClient -> m JsonRpcClient
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JsonRpcClient -> m JsonRpcClient)
-> IO JsonRpcClient -> m JsonRpcClient
forall a b. (a -> b) -> a -> b
$ Manager -> String -> JsonRpcClient
JsonRpcHttpClient
  (Manager -> String -> JsonRpcClient)
-> IO Manager -> IO (String -> JsonRpcClient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  IO (String -> JsonRpcClient) -> IO String -> IO JsonRpcClient
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
srv

instance Show JsonRpcClient where
    show :: JsonRpcClient -> String
show JsonRpcHttpClient{String
Manager
jsonRpcServer :: String
jsonRpcManager :: Manager
jsonRpcServer :: JsonRpcClient -> String
jsonRpcManager :: JsonRpcClient -> Manager
..} = String
"<JSON-RPC HTTP Client>"
    show JsonRpcWsClient{Connection
jsonRpcWsConnection :: Connection
jsonRpcWsConnection :: JsonRpcClient -> Connection
..} = String
"<JSON-RPC WebSocket Client>"

-- | JSON-RPC request.
data Request = Request
    { Request -> Text
rqMethod :: !Text
    , Request -> Int
rqId     :: !Int
    , Request -> Value
rqParams :: !Value
    }
    deriving (Request -> Request -> Bool
(Request -> Request -> Bool)
-> (Request -> Request -> Bool) -> Eq Request
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Request -> Request -> Bool
$c/= :: Request -> Request -> Bool
== :: Request -> Request -> Bool
$c== :: Request -> Request -> Bool
Eq, Int -> Request -> ShowS
[Request] -> ShowS
Request -> String
(Int -> Request -> ShowS)
-> (Request -> String) -> ([Request] -> ShowS) -> Show Request
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Request] -> ShowS
$cshowList :: [Request] -> ShowS
show :: Request -> String
$cshow :: Request -> String
showsPrec :: Int -> Request -> ShowS
$cshowsPrec :: Int -> Request -> ShowS
Show)

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

-- | JSON-RPC response.
data Response = Response
    { Response -> Either RpcError Value
rsResult :: !(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
withObject String
"JSON-RPC response object" ((Object -> Parser Response) -> Value -> Parser Response)
-> (Object -> Parser Response) -> Value -> Parser Response
forall a b. (a -> b) -> a -> b
$
            \Object
v -> Either RpcError Value -> Response
Response (Either RpcError Value -> Response)
-> Parser (Either RpcError Value) -> Parser Response
forall (f :: * -> *) a b. Functor 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
.: Text
"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
.: Text
"error")

-- | 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 Int
code Text
msg Maybe Value
dat) =
        String
"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
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
msg
         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". 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
withObject String
"JSON-RPC error object" ((Object -> Parser RpcError) -> Value -> Parser RpcError)
-> (Object -> Parser RpcError) -> Value -> Parser RpcError
forall a b. (a -> b) -> a -> b
$
        \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
.: Text
"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
.: Text
"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)
.:? Text
"data"

data JsonRpcException = ParsingException String
    | CallException RpcError
    deriving (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, 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)

instance Exception JsonRpcException

class JsonRpcM m => Remote m a | a -> m where
    remote' :: ([Value] -> m ByteString) -> a

instance (ToJSON a, Remote m b) => Remote m (a -> b) where
    remote' :: ([Value] -> m ByteString) -> a -> b
remote' [Value] -> m ByteString
f a
x = ([Value] -> m ByteString) -> b
forall (m :: * -> *) a.
Remote m a =>
([Value] -> m ByteString) -> a
remote' (\[Value]
xs -> [Value] -> m ByteString
f (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
xs))

instance {-# INCOHERENT #-} (JsonRpcM m, FromJSON b) => Remote m (m b) where
    remote' :: ([Value] -> m ByteString) -> m b
remote' [Value] -> m ByteString
f = ByteString -> m b
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
decodeResponse (ByteString -> m b) -> m ByteString -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Value] -> m ByteString
f []

-- | Name of called method.
type MethodName = Text

-- | JSON-RPC call monad.
class JsonRpcM m => JsonRpc m where
    -- | Remote call of JSON-RPC method.
    remote :: Remote m a => MethodName -> a
    {-# INLINE remote #-}
    remote = ([Value] -> m ByteString) -> a
forall (m :: * -> *) a.
Remote m a =>
([Value] -> m ByteString) -> a
remote' (([Value] -> m ByteString) -> a)
-> (Text -> [Value] -> m ByteString) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Value] -> m ByteString
forall (m :: * -> *). JsonRpcM m => Text -> [Value] -> m ByteString
call

call :: JsonRpcM m
     => MethodName
     -> [Value]
     -> m ByteString
call :: Text -> [Value] -> m ByteString
call Text
m [Value]
r = do
  Integer
rid <- IO Integer -> m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> m Integer) -> IO Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ (Integer, Integer) -> IO Integer
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Integer
0, Integer
maxInt)
  ByteString -> m ByteString
forall (m :: * -> *).
(MonadState JsonRpcClient m, MonadThrow m, MonadIO m) =>
ByteString -> m ByteString
connection (ByteString -> m ByteString)
-> (Request -> ByteString) -> Request -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Request -> m ByteString) -> Request -> m ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Value -> Request
Request Text
m (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
rid) ([Value] -> Value
forall a. ToJSON a => a -> Value
toJSON [Value]
r)
  where
    maxInt :: Integer
maxInt = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int)
    connection :: ByteString -> m ByteString
connection ByteString
body = do
        JsonRpcClient
jsonRpcInstance <- m JsonRpcClient
forall s (m :: * -> *). MonadState s m => m s
get
        case JsonRpcClient
jsonRpcInstance of
            JsonRpcHttpClient{String
Manager
jsonRpcServer :: String
jsonRpcManager :: Manager
jsonRpcServer :: JsonRpcClient -> String
jsonRpcManager :: JsonRpcClient -> Manager
..} -> do
                Request
request <- String -> m Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
jsonRpcServer
                let request' :: Request
request' = Request
request {
                      requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
body
                    , requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
"Content-Type", ByteString
"application/json")]
                    , method :: ByteString
method = ByteString
"POST"
                    }
                Response ByteString -> ByteString
forall body. Response body -> body
responseBody (Response ByteString -> ByteString)
-> m (Response ByteString) -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Response ByteString) -> m (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Request -> Manager -> IO (Response ByteString)
httpLbs Request
request' Manager
jsonRpcManager)

            JsonRpcWsClient{Connection
jsonRpcWsConnection :: Connection
jsonRpcWsConnection :: JsonRpcClient -> Connection
..} -> IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
                Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
jsonRpcWsConnection ByteString
body
                Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
jsonRpcWsConnection



decodeResponse :: (MonadThrow m, FromJSON a)
               => ByteString
               -> m a
decodeResponse :: ByteString -> m a
decodeResponse = (Either String a -> m a
forall a. Either String a -> m a
tryParse (Either String a -> m a)
-> (Value -> Either String a) -> Value -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String a)
-> (Value -> ByteString) -> Value -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode)
               (Value -> m a) -> (ByteString -> m Value) -> ByteString -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Either RpcError Value -> m Value
forall a. Either RpcError a -> m a
tryResult (Either RpcError Value -> m Value)
-> (Response -> Either RpcError Value) -> Response -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Either RpcError Value
rsResult
               (Response -> m Value)
-> (ByteString -> m Response) -> ByteString -> m Value
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Either String Response -> m Response
forall a. Either String a -> m a
tryParse (Either String Response -> m Response)
-> (ByteString -> Either String Response)
-> ByteString
-> m Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Response
forall a. FromJSON a => ByteString -> Either String a
eitherDecode
  where
    tryParse :: Either String a -> m a
tryParse = (String -> m a) -> (a -> m a) -> Either String a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (JsonRpcException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JsonRpcException -> m a)
-> (String -> JsonRpcException) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JsonRpcException
ParsingException) a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    tryResult :: Either RpcError a -> m a
tryResult = (RpcError -> m a) -> (a -> m a) -> Either RpcError a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (JsonRpcException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JsonRpcException -> m a)
-> (RpcError -> JsonRpcException) -> RpcError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RpcError -> JsonRpcException
CallException) a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return