{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.JSONRPC.Interface
(
JSONRPCT
, runJSONRPCT
, decodeConduit
, encodeConduit
, receiveRequest
, receiveBatchRequest
, sendResponse
, sendBatchResponse
, sendRequest
, sendBatchRequest
, jsonrpcTCPClient
, jsonrpcTCPServer
, SentRequests
, Session(..)
, initSession
, processIncoming
, sendMessage
) where
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.State
import Data.Aeson
import Data.Aeson.Parser
import Data.Aeson.Types (parseMaybe)
import Data.Attoparsec.ByteString
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Conduit.Network
import Data.Conduit.TMChan
import Data.Either
import qualified Data.Foldable as F
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Data.Maybe
import qualified Data.Vector as V
import Network.JSONRPC.Data
import UnliftIO
type SentRequests = HashMap Id (TMVar (Maybe Response))
data Session = Session { Session -> TBMChan (Either Response Value)
inCh :: TBMChan (Either Response Value)
, Session -> TBMChan Message
outCh :: TBMChan Message
, Session -> Maybe (TBMChan BatchRequest)
reqCh :: Maybe (TBMChan BatchRequest)
, Session -> TVar Id
lastId :: TVar Id
, Session -> TVar SentRequests
sentReqs :: TVar SentRequests
, Session -> Ver
rpcVer :: Ver
, Session -> TVar Bool
dead :: TVar Bool
}
type JSONRPCT = ReaderT Session
initSession :: Ver -> Bool -> STM Session
initSession :: Ver -> Bool -> STM Session
initSession Ver
v Bool
ignore =
TBMChan (Either Response Value)
-> TBMChan Message
-> Maybe (TBMChan BatchRequest)
-> TVar Id
-> TVar SentRequests
-> Ver
-> TVar Bool
-> Session
Session (TBMChan (Either Response Value)
-> TBMChan Message
-> Maybe (TBMChan BatchRequest)
-> TVar Id
-> TVar SentRequests
-> Ver
-> TVar Bool
-> Session)
-> STM (TBMChan (Either Response Value))
-> STM
(TBMChan Message
-> Maybe (TBMChan BatchRequest)
-> TVar Id
-> TVar SentRequests
-> Ver
-> TVar Bool
-> Session)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> STM (TBMChan (Either Response Value))
forall a. Int -> STM (TBMChan a)
newTBMChan Int
128
STM
(TBMChan Message
-> Maybe (TBMChan BatchRequest)
-> TVar Id
-> TVar SentRequests
-> Ver
-> TVar Bool
-> Session)
-> STM (TBMChan Message)
-> STM
(Maybe (TBMChan BatchRequest)
-> TVar Id -> TVar SentRequests -> Ver -> TVar Bool -> Session)
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> STM (TBMChan Message)
forall a. Int -> STM (TBMChan a)
newTBMChan Int
128
STM
(Maybe (TBMChan BatchRequest)
-> TVar Id -> TVar SentRequests -> Ver -> TVar Bool -> Session)
-> STM (Maybe (TBMChan BatchRequest))
-> STM
(TVar Id -> TVar SentRequests -> Ver -> TVar Bool -> Session)
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (if Bool
ignore then Maybe (TBMChan BatchRequest) -> STM (Maybe (TBMChan BatchRequest))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TBMChan BatchRequest)
forall a. Maybe a
Nothing else TBMChan BatchRequest -> Maybe (TBMChan BatchRequest)
forall a. a -> Maybe a
Just (TBMChan BatchRequest -> Maybe (TBMChan BatchRequest))
-> STM (TBMChan BatchRequest) -> STM (Maybe (TBMChan BatchRequest))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> STM (TBMChan BatchRequest)
forall a. Int -> STM (TBMChan a)
newTBMChan Int
128)
STM (TVar Id -> TVar SentRequests -> Ver -> TVar Bool -> Session)
-> STM (TVar Id)
-> STM (TVar SentRequests -> Ver -> TVar Bool -> Session)
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Id -> STM (TVar Id)
forall a. a -> STM (TVar a)
newTVar (Int -> Id
IdInt Int
0)
STM (TVar SentRequests -> Ver -> TVar Bool -> Session)
-> STM (TVar SentRequests) -> STM (Ver -> TVar Bool -> Session)
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SentRequests -> STM (TVar SentRequests)
forall a. a -> STM (TVar a)
newTVar SentRequests
forall k v. HashMap k v
M.empty
STM (Ver -> TVar Bool -> Session)
-> STM Ver -> STM (TVar Bool -> Session)
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ver -> STM Ver
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Ver
v
STM (TVar Bool -> Session) -> STM (TVar Bool) -> STM Session
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
False
encodeConduit :: (ToJSON j, MonadLogger m) => ConduitT j ByteString m ()
encodeConduit :: forall j (m :: * -> *).
(ToJSON j, MonadLogger m) =>
ConduitT j ByteString m ()
encodeConduit = (j -> m ByteString) -> ConduitT j ByteString m ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
CL.mapM ((j -> m ByteString) -> ConduitT j ByteString m ())
-> (j -> m ByteString) -> ConduitT j ByteString m ()
forall a b. (a -> b) -> a -> b
$ \j
m -> ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString)
-> (ByteString -> ByteString) -> ByteString -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L8.toStrict (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ j -> ByteString
forall a. ToJSON a => a -> ByteString
encode j
m
decodeConduit :: MonadLogger m
=> Ver -> ConduitT ByteString (Either Response Value) m ()
decodeConduit :: forall (m :: * -> *).
MonadLogger m =>
Ver -> ConduitT ByteString (Either Response Value) m ()
decodeConduit Ver
ver = StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
-> Maybe (ByteString -> IResult ByteString Value)
-> ConduitT ByteString (Either Response Value) m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
loop Maybe (ByteString -> IResult ByteString Value)
forall a. Maybe a
Nothing where
loop :: StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
loop = ConduitT ByteString (Either Response Value) m (Maybe ByteString)
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
(Maybe ByteString)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Maybe (ByteString -> IResult ByteString Value)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ConduitT ByteString (Either Response Value) m (Maybe ByteString)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
(Maybe ByteString)
-> (Maybe ByteString
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
())
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall a b.
StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
a
-> (a
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
b)
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
-> (ByteString
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
())
-> Maybe ByteString
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
flush (Bool
-> ByteString
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
process Bool
False)
flush :: StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
flush = StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
(Maybe (ByteString -> IResult ByteString Value))
forall s (m :: * -> *). MonadState s m => m s
get StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
(Maybe (ByteString -> IResult ByteString Value))
-> (Maybe (ByteString -> IResult ByteString Value)
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
())
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall a b.
StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
a
-> (a
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
b)
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
-> ((ByteString -> IResult ByteString Value)
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
())
-> Maybe (ByteString -> IResult ByteString Value)
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (()
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall a.
a
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Bool
-> IResult ByteString Value
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
handl Bool
True (IResult ByteString Value
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
())
-> ((ByteString -> IResult ByteString Value)
-> IResult ByteString Value)
-> (ByteString -> IResult ByteString Value)
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString -> IResult ByteString Value)
-> ByteString -> IResult ByteString Value
forall a b. (a -> b) -> a -> b
$ ByteString
B8.empty))
process :: Bool
-> ByteString
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
process Bool
b = ByteString
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
(IResult ByteString Value)
forall {f :: * -> *}.
MonadState (Maybe (ByteString -> IResult ByteString Value)) f =>
ByteString -> f (IResult ByteString Value)
runParser (ByteString
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
(IResult ByteString Value))
-> (IResult ByteString Value
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
())
-> ByteString
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Bool
-> IResult ByteString Value
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
handl Bool
b
runParser :: ByteString -> f (IResult ByteString Value)
runParser ByteString
ck = IResult ByteString Value
-> ((ByteString -> IResult ByteString Value)
-> IResult ByteString Value)
-> Maybe (ByteString -> IResult ByteString Value)
-> IResult ByteString Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Parser Value -> ByteString -> IResult ByteString Value
forall a. Parser a -> ByteString -> Result a
parse Parser Value
json ByteString
ck) ((ByteString -> IResult ByteString Value)
-> ByteString -> IResult ByteString Value
forall a b. (a -> b) -> a -> b
$ ByteString
ck) (Maybe (ByteString -> IResult ByteString Value)
-> IResult ByteString Value)
-> f (Maybe (ByteString -> IResult ByteString Value))
-> f (IResult ByteString Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Maybe (ByteString -> IResult ByteString Value))
forall s (m :: * -> *). MonadState s m => m s
get f (IResult ByteString Value)
-> f () -> f (IResult ByteString Value)
forall a b. f a -> f b -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Maybe (ByteString -> IResult ByteString Value) -> f ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Maybe (ByteString -> IResult ByteString Value)
forall a. Maybe a
Nothing
handl :: Bool
-> IResult ByteString Value
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
handl Bool
True (Fail ByteString
"" [String]
_ String
_) =
$Text
-> Text
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
logDebugS Text
"json-rpc" Text
"ignoring null string at end of incoming data"
handl Bool
b (Fail ByteString
i [String]
_ String
_) = do
$Text
-> Text
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
logErrorS Text
"json-rpc" Text
"error parsing incoming message"
ConduitT ByteString (Either Response Value) m ()
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Maybe (ByteString -> IResult ByteString Value)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ConduitT ByteString (Either Response Value) m ()
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
())
-> (Response -> ConduitT ByteString (Either Response Value) m ())
-> Response
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Response Value
-> ConduitT ByteString (Either Response Value) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Either Response Value
-> ConduitT ByteString (Either Response Value) m ())
-> (Response -> Either Response Value)
-> Response
-> ConduitT ByteString (Either Response Value) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Either Response Value
forall a b. a -> Either a b
Left (Response
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
())
-> Response
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall a b. (a -> b) -> a -> b
$ Ver -> ErrorObj -> Response
OrphanError Ver
ver (ByteString -> ErrorObj
errorParse ByteString
i)
Bool
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
loop
handl Bool
_ (Partial ByteString -> IResult ByteString Value
k) = Maybe (ByteString -> IResult ByteString Value)
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ((ByteString -> IResult ByteString Value)
-> Maybe (ByteString -> IResult ByteString Value)
forall a. a -> Maybe a
Just ByteString -> IResult ByteString Value
k) StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall a b.
StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
a
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
b
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
loop
handl Bool
b (Done ByteString
rest Value
v) = do
ConduitT ByteString (Either Response Value) m ()
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Maybe (ByteString -> IResult ByteString Value)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ConduitT ByteString (Either Response Value) m ()
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
())
-> ConduitT ByteString (Either Response Value) m ()
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall a b. (a -> b) -> a -> b
$ Either Response Value
-> ConduitT ByteString (Either Response Value) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Either Response Value
-> ConduitT ByteString (Either Response Value) m ())
-> Either Response Value
-> ConduitT ByteString (Either Response Value) m ()
forall a b. (a -> b) -> a -> b
$ Value -> Either Response Value
forall a b. b -> Either a b
Right Value
v
if ByteString -> Bool
B8.null ByteString
rest
then Bool
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
loop
else Bool
-> ByteString
-> StateT
(Maybe (ByteString -> IResult ByteString Value))
(ConduitT ByteString (Either Response Value) m)
()
process Bool
b ByteString
rest
processIncoming :: (Functor m, MonadLoggerIO m) => JSONRPCT m ()
processIncoming :: forall (m :: * -> *). (Functor m, MonadLoggerIO m) => JSONRPCT m ()
processIncoming =
ReaderT Session m Session
forall r (m :: * -> *). MonadReader r m => m r
ask ReaderT Session m Session
-> (Session -> ReaderT Session m ()) -> ReaderT Session m ()
forall a b.
ReaderT Session m a
-> (a -> ReaderT Session m b) -> ReaderT Session m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Session
qs ->
ReaderT Session m (ReaderT Session m ()) -> ReaderT Session m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ReaderT Session m (ReaderT Session m ()) -> ReaderT Session m ())
-> (STM (ReaderT Session m ())
-> ReaderT Session m (ReaderT Session m ()))
-> STM (ReaderT Session m ())
-> ReaderT Session m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (ReaderT Session m ())
-> ReaderT Session m (ReaderT Session m ())
forall a. IO a -> ReaderT Session m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ReaderT Session m ())
-> ReaderT Session m (ReaderT Session m ()))
-> (STM (ReaderT Session m ()) -> IO (ReaderT Session m ()))
-> STM (ReaderT Session m ())
-> ReaderT Session m (ReaderT Session m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (ReaderT Session m ()) -> IO (ReaderT Session m ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (ReaderT Session m ()) -> ReaderT Session m ())
-> STM (ReaderT Session m ()) -> ReaderT Session m ()
forall a b. (a -> b) -> a -> b
$
TBMChan (Either Response Value)
-> STM (Maybe (Either Response Value))
forall a. TBMChan a -> STM (Maybe a)
readTBMChan (Session -> TBMChan (Either Response Value)
inCh Session
qs) STM (Maybe (Either Response Value))
-> (Maybe (Either Response Value) -> STM (ReaderT Session m ()))
-> STM (ReaderT Session m ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Either Response Value)
Nothing -> Session -> STM (ReaderT Session m ())
forall {m :: * -> *}. MonadLogger m => Session -> STM (m ())
flush Session
qs
Just Either Response Value
vE ->
case Either Response Value
vE of
Right v :: Value
v@Object {} -> do
Session -> Value -> STM ()
single Session
qs Value
v
ReaderT Session m () -> STM (ReaderT Session m ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ReaderT Session m () -> STM (ReaderT Session m ()))
-> ReaderT Session m () -> STM (ReaderT Session m ())
forall a b. (a -> b) -> a -> b
$ do
$Text -> Text -> ReaderT Session m ()
logDebugS Text
"json-rpc" Text
"received message"
ReaderT Session m ()
forall (m :: * -> *). (Functor m, MonadLoggerIO m) => JSONRPCT m ()
processIncoming
Right v :: Value
v@(Array Array
a) -> do
if Array -> Bool
forall a. Vector a -> Bool
V.null Array
a
then do
let e :: Response
e = Ver -> ErrorObj -> Response
OrphanError (Session -> Ver
rpcVer Session
qs) (Value -> ErrorObj
errorInvalid Value
v)
TBMChan Message -> Message -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan (Session -> TBMChan Message
outCh Session
qs) (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Response -> Message
MsgResponse Response
e
else Session -> [Value] -> STM ()
batch Session
qs (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
a)
ReaderT Session m () -> STM (ReaderT Session m ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ReaderT Session m () -> STM (ReaderT Session m ()))
-> ReaderT Session m () -> STM (ReaderT Session m ())
forall a b. (a -> b) -> a -> b
$ do
$Text -> Text -> ReaderT Session m ()
logDebugS Text
"json-rpc" Text
"received batch"
ReaderT Session m ()
forall (m :: * -> *). (Functor m, MonadLoggerIO m) => JSONRPCT m ()
processIncoming
Right Value
v -> do
let e :: Response
e = Ver -> ErrorObj -> Response
OrphanError (Session -> Ver
rpcVer Session
qs) (Value -> ErrorObj
errorInvalid Value
v)
TBMChan Message -> Message -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan (Session -> TBMChan Message
outCh Session
qs) (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Response -> Message
MsgResponse Response
e
ReaderT Session m () -> STM (ReaderT Session m ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ReaderT Session m () -> STM (ReaderT Session m ()))
-> ReaderT Session m () -> STM (ReaderT Session m ())
forall a b. (a -> b) -> a -> b
$ do
$Text -> Text -> ReaderT Session m ()
logWarnS Text
"json-rpc" Text
"got invalid message"
ReaderT Session m ()
forall (m :: * -> *). (Functor m, MonadLoggerIO m) => JSONRPCT m ()
processIncoming
Left Response
e -> do
TBMChan Message -> Message -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan (Session -> TBMChan Message
outCh Session
qs) (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Response -> Message
MsgResponse Response
e
ReaderT Session m () -> STM (ReaderT Session m ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ReaderT Session m () -> STM (ReaderT Session m ()))
-> ReaderT Session m () -> STM (ReaderT Session m ())
forall a b. (a -> b) -> a -> b
$ do
$Text -> Text -> ReaderT Session m ()
logWarnS Text
"json-rpc" Text
"error parsing JSON"
ReaderT Session m ()
forall (m :: * -> *). (Functor m, MonadLoggerIO m) => JSONRPCT m ()
processIncoming
where
flush :: Session -> STM (m ())
flush Session
qs = do
SentRequests
m <- TVar SentRequests -> STM SentRequests
forall a. TVar a -> STM a
readTVar (TVar SentRequests -> STM SentRequests)
-> TVar SentRequests -> STM SentRequests
forall a b. (a -> b) -> a -> b
$ Session -> TVar SentRequests
sentReqs Session
qs
Maybe (TBMChan BatchRequest)
-> (TBMChan BatchRequest -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ (Session -> Maybe (TBMChan BatchRequest)
reqCh Session
qs) TBMChan BatchRequest -> STM ()
forall a. TBMChan a -> STM ()
closeTBMChan
TBMChan Message -> STM ()
forall a. TBMChan a -> STM ()
closeTBMChan (TBMChan Message -> STM ()) -> TBMChan Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Session -> TBMChan Message
outCh Session
qs
TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Session -> TVar Bool
dead Session
qs) Bool
True
((Id, TMVar (Maybe Response)) -> STM ())
-> [(Id, TMVar (Maybe Response))] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((TMVar (Maybe Response) -> Maybe Response -> STM ()
forall a. TMVar a -> a -> STM ()
`putTMVar` Maybe Response
forall a. Maybe a
Nothing) (TMVar (Maybe Response) -> STM ())
-> ((Id, TMVar (Maybe Response)) -> TMVar (Maybe Response))
-> (Id, TMVar (Maybe Response))
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, TMVar (Maybe Response)) -> TMVar (Maybe Response)
forall a b. (a, b) -> b
snd) ([(Id, TMVar (Maybe Response))] -> STM ())
-> [(Id, TMVar (Maybe Response))] -> STM ()
forall a b. (a -> b) -> a -> b
$ SentRequests -> [(Id, TMVar (Maybe Response))]
forall k v. HashMap k v -> [(k, v)]
M.toList SentRequests
m
m () -> STM (m ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$ do
$Text -> Text -> m ()
logDebugS Text
"json-rpc" Text
"session is now dead"
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SentRequests -> Bool
forall k v. HashMap k v -> Bool
M.null SentRequests
m) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ $Text -> Text -> m ()
logErrorS Text
"json-rpc" Text
"requests remained unfulfilled"
batch :: Session -> [Value] -> STM ()
batch Session
qs [Value]
vs = do
[Either Message Request]
ts <- [Maybe (Either Message Request)] -> [Either Message Request]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Either Message Request)] -> [Either Message Request])
-> STM [Maybe (Either Message Request)]
-> STM [Either Message Request]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
-> (Value -> STM (Maybe (Either Message Request)))
-> STM [Maybe (Either Message Request)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Value]
vs (Session -> Value -> STM (Maybe (Either Message Request))
process Session
qs)
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Either Message Request] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Either Message Request]
ts) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
if (Either Message Request -> Bool)
-> [Either Message Request] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either Message Request -> Bool
forall a b. Either a b -> Bool
isRight [Either Message Request]
ts
then do
let ch :: TBMChan BatchRequest
ch = Maybe (TBMChan BatchRequest) -> TBMChan BatchRequest
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (TBMChan BatchRequest) -> TBMChan BatchRequest)
-> Maybe (TBMChan BatchRequest) -> TBMChan BatchRequest
forall a b. (a -> b) -> a -> b
$ Session -> Maybe (TBMChan BatchRequest)
reqCh Session
qs
TBMChan BatchRequest -> BatchRequest -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan TBMChan BatchRequest
ch (BatchRequest -> STM ()) -> BatchRequest -> STM ()
forall a b. (a -> b) -> a -> b
$ [Request] -> BatchRequest
BatchRequest ([Request] -> BatchRequest) -> [Request] -> BatchRequest
forall a b. (a -> b) -> a -> b
$ [Either Message Request] -> [Request]
forall a b. [Either a b] -> [b]
rights [Either Message Request]
ts
else TBMChan Message -> Message -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan (Session -> TBMChan Message
outCh Session
qs) (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ [Message] -> Message
MsgBatch ([Message] -> Message) -> [Message] -> Message
forall a b. (a -> b) -> a -> b
$ [Either Message Request] -> [Message]
forall a b. [Either a b] -> [a]
lefts [Either Message Request]
ts
single :: Session -> Value -> STM ()
single Session
qs Value
v = do
Maybe (Either Message Request)
tM <- Session -> Value -> STM (Maybe (Either Message Request))
process Session
qs Value
v
case Maybe (Either Message Request)
tM of
Maybe (Either Message Request)
Nothing -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (Right Request
t) -> do
let ch :: TBMChan BatchRequest
ch = Maybe (TBMChan BatchRequest) -> TBMChan BatchRequest
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (TBMChan BatchRequest) -> TBMChan BatchRequest)
-> Maybe (TBMChan BatchRequest) -> TBMChan BatchRequest
forall a b. (a -> b) -> a -> b
$ Session -> Maybe (TBMChan BatchRequest)
reqCh Session
qs
TBMChan BatchRequest -> BatchRequest -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan TBMChan BatchRequest
ch (BatchRequest -> STM ()) -> BatchRequest -> STM ()
forall a b. (a -> b) -> a -> b
$ Request -> BatchRequest
SingleRequest Request
t
Just (Left Message
e) -> TBMChan Message -> Message -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan (Session -> TBMChan Message
outCh Session
qs) Message
e
process :: Session -> Value -> STM (Maybe (Either Message Request))
process Session
qs Value
v = do
let qM :: Maybe Request
qM = (Value -> Parser Request) -> Value -> Maybe Request
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser Request
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
case Maybe Request
qM of
Just Request
q -> Session -> Request -> STM (Maybe (Either Message Request))
forall {m :: * -> *}.
Monad m =>
Session -> Request -> m (Maybe (Either Message Request))
request Session
qs Request
q
Maybe Request
Nothing -> do
let rM :: Maybe Response
rM = (Value -> Parser Response) -> Value -> Maybe Response
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser Response
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
case Maybe Response
rM of
Just Response
r -> Session -> Response -> STM ()
response Session
qs Response
r STM ()
-> STM (Maybe (Either Message Request))
-> STM (Maybe (Either Message Request))
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Either Message Request)
-> STM (Maybe (Either Message Request))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either Message Request)
forall a. Maybe a
Nothing
Maybe Response
Nothing -> do
let e :: Response
e = Ver -> ErrorObj -> Response
OrphanError (Session -> Ver
rpcVer Session
qs) (Value -> ErrorObj
errorInvalid Value
v)
m :: Message
m = Response -> Message
MsgResponse Response
e
Maybe (Either Message Request)
-> STM (Maybe (Either Message Request))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either Message Request)
-> STM (Maybe (Either Message Request)))
-> Maybe (Either Message Request)
-> STM (Maybe (Either Message Request))
forall a b. (a -> b) -> a -> b
$ Either Message Request -> Maybe (Either Message Request)
forall a. a -> Maybe a
Just (Either Message Request -> Maybe (Either Message Request))
-> Either Message Request -> Maybe (Either Message Request)
forall a b. (a -> b) -> a -> b
$ Message -> Either Message Request
forall a b. a -> Either a b
Left Message
m
request :: Session -> Request -> m (Maybe (Either Message Request))
request Session
qs Request
t =
case Session -> Maybe (TBMChan BatchRequest)
reqCh Session
qs of
Just TBMChan BatchRequest
_ -> Maybe (Either Message Request)
-> m (Maybe (Either Message Request))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either Message Request)
-> m (Maybe (Either Message Request)))
-> Maybe (Either Message Request)
-> m (Maybe (Either Message Request))
forall a b. (a -> b) -> a -> b
$ Either Message Request -> Maybe (Either Message Request)
forall a. a -> Maybe a
Just (Either Message Request -> Maybe (Either Message Request))
-> Either Message Request -> Maybe (Either Message Request)
forall a b. (a -> b) -> a -> b
$ Request -> Either Message Request
forall a b. b -> Either a b
Right Request
t
Maybe (TBMChan BatchRequest)
Nothing ->
case Request
t of
Notif {} -> Maybe (Either Message Request)
-> m (Maybe (Either Message Request))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either Message Request)
forall a. Maybe a
Nothing
Request {} -> do
let e :: ErrorObj
e = Text -> ErrorObj
errorMethod (Request -> Text
getReqMethod Request
t)
v :: Ver
v = Request -> Ver
getReqVer Request
t
i :: Id
i = Request -> Id
getReqId Request
t
m :: Message
m = Response -> Message
MsgResponse (Response -> Message) -> Response -> Message
forall a b. (a -> b) -> a -> b
$ Ver -> ErrorObj -> Id -> Response
ResponseError Ver
v ErrorObj
e Id
i
Maybe (Either Message Request)
-> m (Maybe (Either Message Request))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either Message Request)
-> m (Maybe (Either Message Request)))
-> Maybe (Either Message Request)
-> m (Maybe (Either Message Request))
forall a b. (a -> b) -> a -> b
$ Either Message Request -> Maybe (Either Message Request)
forall a. a -> Maybe a
Just (Either Message Request -> Maybe (Either Message Request))
-> Either Message Request -> Maybe (Either Message Request)
forall a b. (a -> b) -> a -> b
$ Message -> Either Message Request
forall a b. a -> Either a b
Left Message
m
response :: Session -> Response -> STM ()
response Session
qs Response
r = do
let hasid :: Bool
hasid =
case Response
r of
Response {} -> Bool
True
ResponseError {} -> Bool
True
OrphanError {} -> Bool
False
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasid (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
let x :: Id
x = Response -> Id
getResId Response
r
SentRequests
m <- TVar SentRequests -> STM SentRequests
forall a. TVar a -> STM a
readTVar (Session -> TVar SentRequests
sentReqs Session
qs)
case Id
x Id -> SentRequests -> Maybe (TMVar (Maybe Response))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`M.lookup` SentRequests
m of
Maybe (TMVar (Maybe Response))
Nothing -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TMVar (Maybe Response)
p -> do
TVar SentRequests -> SentRequests -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Session -> TVar SentRequests
sentReqs Session
qs) (SentRequests -> STM ()) -> SentRequests -> STM ()
forall a b. (a -> b) -> a -> b
$ Id -> SentRequests -> SentRequests
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete Id
x SentRequests
m
TMVar (Maybe Response) -> Maybe Response -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Maybe Response)
p (Maybe Response -> STM ()) -> Maybe Response -> STM ()
forall a b. (a -> b) -> a -> b
$ Response -> Maybe Response
forall a. a -> Maybe a
Just Response
r
sendRequest :: (MonadLoggerIO m , ToJSON q, ToRequest q, FromResponse r)
=> q -> JSONRPCT m (Maybe (Either ErrorObj r))
sendRequest :: forall (m :: * -> *) q r.
(MonadLoggerIO m, ToJSON q, ToRequest q, FromResponse r) =>
q -> JSONRPCT m (Maybe (Either ErrorObj r))
sendRequest q
q = [Maybe (Either ErrorObj r)] -> Maybe (Either ErrorObj r)
forall a. HasCallStack => [a] -> a
head ([Maybe (Either ErrorObj r)] -> Maybe (Either ErrorObj r))
-> ReaderT Session m [Maybe (Either ErrorObj r)]
-> ReaderT Session m (Maybe (Either ErrorObj r))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` [q] -> ReaderT Session m [Maybe (Either ErrorObj r)]
forall (m :: * -> *) q r.
(MonadLoggerIO m, ToJSON q, ToRequest q, FromResponse r) =>
[q] -> JSONRPCT m [Maybe (Either ErrorObj r)]
sendBatchRequest [q
q]
sendBatchRequest :: (MonadLoggerIO m, ToJSON q, ToRequest q, FromResponse r)
=> [q] -> JSONRPCT m [Maybe (Either ErrorObj r)]
sendBatchRequest :: forall (m :: * -> *) q r.
(MonadLoggerIO m, ToJSON q, ToRequest q, FromResponse r) =>
[q] -> JSONRPCT m [Maybe (Either ErrorObj r)]
sendBatchRequest [q]
qs = do
Ver
v <- (Session -> Ver) -> ReaderT Session m Ver
forall a. (Session -> a) -> ReaderT Session m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> Ver
rpcVer
TVar Id
l <- (Session -> TVar Id) -> ReaderT Session m (TVar Id)
forall a. (Session -> a) -> ReaderT Session m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TVar Id
lastId
TVar SentRequests
s <- (Session -> TVar SentRequests)
-> ReaderT Session m (TVar SentRequests)
forall a. (Session -> a) -> ReaderT Session m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TVar SentRequests
sentReqs
TBMChan Message
o <- (Session -> TBMChan Message) -> ReaderT Session m (TBMChan Message)
forall a. (Session -> a) -> ReaderT Session m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TBMChan Message
outCh
TVar Bool
k <- (Session -> TVar Bool) -> ReaderT Session m (TVar Bool)
forall a. (Session -> a) -> ReaderT Session m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TVar Bool
dead
[(Request, Maybe (TMVar (Maybe Response)))]
aps <- IO [(Request, Maybe (TMVar (Maybe Response)))]
-> ReaderT Session m [(Request, Maybe (TMVar (Maybe Response)))]
forall a. IO a -> ReaderT Session m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Request, Maybe (TMVar (Maybe Response)))]
-> ReaderT Session m [(Request, Maybe (TMVar (Maybe Response)))])
-> (STM [(Request, Maybe (TMVar (Maybe Response)))]
-> IO [(Request, Maybe (TMVar (Maybe Response)))])
-> STM [(Request, Maybe (TMVar (Maybe Response)))]
-> ReaderT Session m [(Request, Maybe (TMVar (Maybe Response)))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM [(Request, Maybe (TMVar (Maybe Response)))]
-> IO [(Request, Maybe (TMVar (Maybe Response)))]
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM [(Request, Maybe (TMVar (Maybe Response)))]
-> ReaderT Session m [(Request, Maybe (TMVar (Maybe Response)))])
-> STM [(Request, Maybe (TMVar (Maybe Response)))]
-> ReaderT Session m [(Request, Maybe (TMVar (Maybe Response)))]
forall a b. (a -> b) -> a -> b
$ do
Bool
d <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
k
[(Request, Maybe (TMVar (Maybe Response)))]
aps <- [q]
-> (q -> STM (Request, Maybe (TMVar (Maybe Response))))
-> STM [(Request, Maybe (TMVar (Maybe Response)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [q]
qs ((q -> STM (Request, Maybe (TMVar (Maybe Response))))
-> STM [(Request, Maybe (TMVar (Maybe Response)))])
-> (q -> STM (Request, Maybe (TMVar (Maybe Response))))
-> STM [(Request, Maybe (TMVar (Maybe Response)))]
forall a b. (a -> b) -> a -> b
$ \q
q ->
if q -> Bool
forall q. ToRequest q => q -> Bool
requestIsNotif q
q
then (Request, Maybe (TMVar (Maybe Response)))
-> STM (Request, Maybe (TMVar (Maybe Response)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ver -> q -> Id -> Request
forall q. (ToJSON q, ToRequest q) => Ver -> q -> Id -> Request
buildRequest Ver
v q
q Id
forall a. HasCallStack => a
undefined, Maybe (TMVar (Maybe Response))
forall a. Maybe a
Nothing)
else do
TMVar (Maybe Response)
p <- STM (TMVar (Maybe Response))
forall a. STM (TMVar a)
newEmptyTMVar
Id
i <- Id -> Id
forall a. Enum a => a -> a
succ (Id -> Id) -> STM Id -> STM Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Id -> STM Id
forall a. TVar a -> STM a
readTVar TVar Id
l
SentRequests
m <- TVar SentRequests -> STM SentRequests
forall a. TVar a -> STM a
readTVar TVar SentRequests
s
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
d (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TVar SentRequests -> SentRequests -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar SentRequests
s (SentRequests -> STM ()) -> SentRequests -> STM ()
forall a b. (a -> b) -> a -> b
$ Id -> TMVar (Maybe Response) -> SentRequests -> SentRequests
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Id
i TMVar (Maybe Response)
p SentRequests
m
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
d (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TVar Id -> Id -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Id
l Id
i
if Bool
d
then (Request, Maybe (TMVar (Maybe Response)))
-> STM (Request, Maybe (TMVar (Maybe Response)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ver -> q -> Id -> Request
forall q. (ToJSON q, ToRequest q) => Ver -> q -> Id -> Request
buildRequest Ver
v q
q Id
i, Maybe (TMVar (Maybe Response))
forall a. Maybe a
Nothing)
else (Request, Maybe (TMVar (Maybe Response)))
-> STM (Request, Maybe (TMVar (Maybe Response)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ver -> q -> Id -> Request
forall q. (ToJSON q, ToRequest q) => Ver -> q -> Id -> Request
buildRequest Ver
v q
q Id
i, TMVar (Maybe Response) -> Maybe (TMVar (Maybe Response))
forall a. a -> Maybe a
Just TMVar (Maybe Response)
p)
case ((Request, Maybe (TMVar (Maybe Response))) -> Request)
-> [(Request, Maybe (TMVar (Maybe Response)))] -> [Request]
forall a b. (a -> b) -> [a] -> [b]
map (Request, Maybe (TMVar (Maybe Response))) -> Request
forall a b. (a, b) -> a
fst [(Request, Maybe (TMVar (Maybe Response)))]
aps of
[] -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Request
a] -> Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
d (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TBMChan Message -> Message -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan TBMChan Message
o (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ Request -> Message
MsgRequest Request
a
[Request]
as -> Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
d (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TBMChan Message -> Message -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan TBMChan Message
o (Message -> STM ()) -> Message -> STM ()
forall a b. (a -> b) -> a -> b
$ [Message] -> Message
MsgBatch ([Message] -> Message) -> [Message] -> Message
forall a b. (a -> b) -> a -> b
$ (Request -> Message) -> [Request] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map Request -> Message
MsgRequest [Request]
as
[(Request, Maybe (TMVar (Maybe Response)))]
-> STM [(Request, Maybe (TMVar (Maybe Response)))]
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Request, Maybe (TMVar (Maybe Response)))]
aps
if [(Request, Maybe (TMVar (Maybe Response)))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Request, Maybe (TMVar (Maybe Response)))]
aps
then $Text -> Text -> ReaderT Session m ()
logDebugS Text
"json-rpc" Text
"no responses pending"
else $Text -> Text -> ReaderT Session m ()
logDebugS Text
"json-rpc" Text
"listening for responses if pending"
IO [Maybe (Either ErrorObj r)]
-> JSONRPCT m [Maybe (Either ErrorObj r)]
forall a. IO a -> ReaderT Session m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Maybe (Either ErrorObj r)]
-> JSONRPCT m [Maybe (Either ErrorObj r)])
-> (STM [Maybe (Either ErrorObj r)]
-> IO [Maybe (Either ErrorObj r)])
-> STM [Maybe (Either ErrorObj r)]
-> JSONRPCT m [Maybe (Either ErrorObj r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM [Maybe (Either ErrorObj r)] -> IO [Maybe (Either ErrorObj r)]
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM [Maybe (Either ErrorObj r)]
-> JSONRPCT m [Maybe (Either ErrorObj r)])
-> STM [Maybe (Either ErrorObj r)]
-> JSONRPCT m [Maybe (Either ErrorObj r)]
forall a b. (a -> b) -> a -> b
$ [(Request, Maybe (TMVar (Maybe Response)))]
-> ((Request, Maybe (TMVar (Maybe Response)))
-> STM (Maybe (Either ErrorObj r)))
-> STM [Maybe (Either ErrorObj r)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Request, Maybe (TMVar (Maybe Response)))]
aps (((Request, Maybe (TMVar (Maybe Response)))
-> STM (Maybe (Either ErrorObj r)))
-> STM [Maybe (Either ErrorObj r)])
-> ((Request, Maybe (TMVar (Maybe Response)))
-> STM (Maybe (Either ErrorObj r)))
-> STM [Maybe (Either ErrorObj r)]
forall a b. (a -> b) -> a -> b
$ \(Request
a, Maybe (TMVar (Maybe Response))
pM) ->
case Maybe (TMVar (Maybe Response))
pM of
Maybe (TMVar (Maybe Response))
Nothing -> Maybe (Either ErrorObj r) -> STM (Maybe (Either ErrorObj r))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either ErrorObj r)
forall a. Maybe a
Nothing
Just TMVar (Maybe Response)
p -> do
Maybe Response
rM <- TMVar (Maybe Response) -> STM (Maybe Response)
forall a. TMVar a -> STM a
takeTMVar TMVar (Maybe Response)
p
case Maybe Response
rM of
Maybe Response
Nothing -> Maybe (Either ErrorObj r) -> STM (Maybe (Either ErrorObj r))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either ErrorObj r)
forall a. Maybe a
Nothing
Just r :: Response
r@Response{} ->
case Text -> Response -> Maybe r
forall r. FromResponse r => Text -> Response -> Maybe r
fromResponse (Request -> Text
getReqMethod Request
a) Response
r of
Maybe r
Nothing -> Maybe (Either ErrorObj r) -> STM (Maybe (Either ErrorObj r))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either ErrorObj r)
forall a. Maybe a
Nothing
Just r
x -> Maybe (Either ErrorObj r) -> STM (Maybe (Either ErrorObj r))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either ErrorObj r) -> STM (Maybe (Either ErrorObj r)))
-> Maybe (Either ErrorObj r) -> STM (Maybe (Either ErrorObj r))
forall a b. (a -> b) -> a -> b
$ Either ErrorObj r -> Maybe (Either ErrorObj r)
forall a. a -> Maybe a
Just (Either ErrorObj r -> Maybe (Either ErrorObj r))
-> Either ErrorObj r -> Maybe (Either ErrorObj r)
forall a b. (a -> b) -> a -> b
$ r -> Either ErrorObj r
forall a b. b -> Either a b
Right r
x
Just Response
e -> Maybe (Either ErrorObj r) -> STM (Maybe (Either ErrorObj r))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either ErrorObj r) -> STM (Maybe (Either ErrorObj r)))
-> Maybe (Either ErrorObj r) -> STM (Maybe (Either ErrorObj r))
forall a b. (a -> b) -> a -> b
$ Either ErrorObj r -> Maybe (Either ErrorObj r)
forall a. a -> Maybe a
Just (Either ErrorObj r -> Maybe (Either ErrorObj r))
-> Either ErrorObj r -> Maybe (Either ErrorObj r)
forall a b. (a -> b) -> a -> b
$ ErrorObj -> Either ErrorObj r
forall a b. a -> Either a b
Left (ErrorObj -> Either ErrorObj r) -> ErrorObj -> Either ErrorObj r
forall a b. (a -> b) -> a -> b
$ Response -> ErrorObj
getError Response
e
receiveRequest :: MonadLoggerIO m => JSONRPCT m (Maybe Request)
receiveRequest :: forall (m :: * -> *). MonadLoggerIO m => JSONRPCT m (Maybe Request)
receiveRequest = do
Maybe BatchRequest
bt <- JSONRPCT m (Maybe BatchRequest)
forall (m :: * -> *).
MonadLoggerIO m =>
JSONRPCT m (Maybe BatchRequest)
receiveBatchRequest
case Maybe BatchRequest
bt of
Maybe BatchRequest
Nothing -> Maybe Request -> JSONRPCT m (Maybe Request)
forall a. a -> ReaderT Session m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Request
forall a. Maybe a
Nothing
Just (SingleRequest Request
q) -> Maybe Request -> JSONRPCT m (Maybe Request)
forall a. a -> ReaderT Session m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Request -> JSONRPCT m (Maybe Request))
-> Maybe Request -> JSONRPCT m (Maybe Request)
forall a b. (a -> b) -> a -> b
$ Request -> Maybe Request
forall a. a -> Maybe a
Just Request
q
Just BatchRequest{} -> do
Ver
v <- (Session -> Ver) -> ReaderT Session m Ver
forall a. (Session -> a) -> ReaderT Session m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> Ver
rpcVer
let e :: ErrorObj
e = Value -> ErrorObj
errorInvalid (Value -> ErrorObj) -> Value -> ErrorObj
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
"not accepting batches"
m :: Response
m = Ver -> ErrorObj -> Response
OrphanError Ver
v ErrorObj
e
Response -> JSONRPCT m ()
forall (m :: * -> *). MonadLoggerIO m => Response -> JSONRPCT m ()
sendResponse Response
m
Maybe Request -> JSONRPCT m (Maybe Request)
forall a. a -> ReaderT Session m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Request
forall a. Maybe a
Nothing
receiveBatchRequest :: MonadLoggerIO m => JSONRPCT m (Maybe BatchRequest)
receiveBatchRequest :: forall (m :: * -> *).
MonadLoggerIO m =>
JSONRPCT m (Maybe BatchRequest)
receiveBatchRequest = do
Maybe (TBMChan BatchRequest)
chM <- (Session -> Maybe (TBMChan BatchRequest))
-> ReaderT Session m (Maybe (TBMChan BatchRequest))
forall a. (Session -> a) -> ReaderT Session m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> Maybe (TBMChan BatchRequest)
reqCh
case Maybe (TBMChan BatchRequest)
chM of
Just TBMChan BatchRequest
ch -> do
$Text -> Text -> ReaderT Session m ()
logDebugS Text
"json-rpc" Text
"listening for a new request"
IO (Maybe BatchRequest) -> JSONRPCT m (Maybe BatchRequest)
forall a. IO a -> ReaderT Session m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe BatchRequest) -> JSONRPCT m (Maybe BatchRequest))
-> (STM (Maybe BatchRequest) -> IO (Maybe BatchRequest))
-> STM (Maybe BatchRequest)
-> JSONRPCT m (Maybe BatchRequest)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe BatchRequest) -> IO (Maybe BatchRequest)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe BatchRequest) -> JSONRPCT m (Maybe BatchRequest))
-> STM (Maybe BatchRequest) -> JSONRPCT m (Maybe BatchRequest)
forall a b. (a -> b) -> a -> b
$ TBMChan BatchRequest -> STM (Maybe BatchRequest)
forall a. TBMChan a -> STM (Maybe a)
readTBMChan TBMChan BatchRequest
ch
Maybe (TBMChan BatchRequest)
Nothing -> do
$Text -> Text -> ReaderT Session m ()
logErrorS Text
"json-rpc" Text
"ignoring requests from remote endpoint"
Maybe BatchRequest -> JSONRPCT m (Maybe BatchRequest)
forall a. a -> ReaderT Session m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BatchRequest
forall a. Maybe a
Nothing
sendResponse :: MonadLoggerIO m => Response -> JSONRPCT m ()
sendResponse :: forall (m :: * -> *). MonadLoggerIO m => Response -> JSONRPCT m ()
sendResponse Response
r = do
TBMChan Message
o <- (Session -> TBMChan Message) -> ReaderT Session m (TBMChan Message)
forall a. (Session -> a) -> ReaderT Session m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TBMChan Message
outCh
IO () -> JSONRPCT m ()
forall a. IO a -> ReaderT Session m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSONRPCT m ())
-> (Message -> IO ()) -> Message -> JSONRPCT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> (Message -> STM ()) -> Message -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBMChan Message -> Message -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan TBMChan Message
o (Message -> JSONRPCT m ()) -> Message -> JSONRPCT m ()
forall a b. (a -> b) -> a -> b
$ Response -> Message
MsgResponse Response
r
sendBatchResponse :: MonadLoggerIO m => BatchResponse -> JSONRPCT m ()
sendBatchResponse :: forall (m :: * -> *).
MonadLoggerIO m =>
BatchResponse -> JSONRPCT m ()
sendBatchResponse (BatchResponse [Response]
rs) = do
TBMChan Message
o <- (Session -> TBMChan Message) -> ReaderT Session m (TBMChan Message)
forall a. (Session -> a) -> ReaderT Session m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TBMChan Message
outCh
IO () -> JSONRPCT m ()
forall a. IO a -> ReaderT Session m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSONRPCT m ())
-> (Message -> IO ()) -> Message -> JSONRPCT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> (Message -> STM ()) -> Message -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBMChan Message -> Message -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan TBMChan Message
o (Message -> JSONRPCT m ()) -> Message -> JSONRPCT m ()
forall a b. (a -> b) -> a -> b
$ [Message] -> Message
MsgBatch ([Message] -> Message) -> [Message] -> Message
forall a b. (a -> b) -> a -> b
$ (Response -> Message) -> [Response] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map Response -> Message
MsgResponse [Response]
rs
sendBatchResponse (SingleResponse Response
r) = do
TBMChan Message
o <- (Session -> TBMChan Message) -> ReaderT Session m (TBMChan Message)
forall a. (Session -> a) -> ReaderT Session m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TBMChan Message
outCh
IO () -> JSONRPCT m ()
forall a. IO a -> ReaderT Session m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSONRPCT m ())
-> (Message -> IO ()) -> Message -> JSONRPCT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> (Message -> STM ()) -> Message -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBMChan Message -> Message -> STM ()
forall a. TBMChan a -> a -> STM ()
writeTBMChan TBMChan Message
o (Message -> JSONRPCT m ()) -> Message -> JSONRPCT m ()
forall a b. (a -> b) -> a -> b
$ Response -> Message
MsgResponse Response
r
sendMessage :: MonadLoggerIO m => Message -> JSONRPCT m ()
sendMessage :: forall (m :: * -> *). MonadLoggerIO m => Message -> JSONRPCT m ()
sendMessage Message
msg = (Session -> TBMChan Message) -> ReaderT Session m (TBMChan Message)
forall a. (Session -> a) -> ReaderT Session m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TBMChan Message
outCh ReaderT Session m (TBMChan Message)
-> (TBMChan Message -> ReaderT Session m ())
-> ReaderT Session m ()
forall a b.
ReaderT Session m a
-> (a -> ReaderT Session m b) -> ReaderT Session m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ReaderT Session m ()
forall a. IO a -> ReaderT Session m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Session m ())
-> (TBMChan Message -> IO ())
-> TBMChan Message
-> ReaderT Session m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ())
-> (TBMChan Message -> STM ()) -> TBMChan Message -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TBMChan Message -> Message -> STM ()
forall a. TBMChan a -> a -> STM ()
`writeTBMChan` Message
msg)
runJSONRPCT ::
(MonadLoggerIO m, MonadUnliftIO m)
=> Ver
-> Bool
-> ConduitT ByteString Void m ()
-> ConduitT () ByteString m ()
-> JSONRPCT m a
-> m a
runJSONRPCT :: forall (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m) =>
Ver
-> Bool
-> ConduitT ByteString Void m ()
-> ConduitT () ByteString m ()
-> JSONRPCT m a
-> m a
runJSONRPCT Ver
ver Bool
ignore ConduitT ByteString Void m ()
snk ConduitT () ByteString m ()
src JSONRPCT m a
f = do
Session
qs <- IO Session -> m Session
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Session -> m Session)
-> (STM Session -> IO Session) -> STM Session -> m Session
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Session -> IO Session
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Session -> m Session) -> STM Session -> m Session
forall a b. (a -> b) -> a -> b
$ Ver -> Bool -> STM Session
initSession Ver
ver Bool
ignore
let inSnk :: ConduitT (Either Response Value) z m ()
inSnk = TBMChan (Either Response Value)
-> ConduitT (Either Response Value) z m ()
forall (m :: * -> *) a z.
MonadIO m =>
TBMChan a -> ConduitT a z m ()
sinkTBMChan (Session -> TBMChan (Either Response Value)
inCh Session
qs)
outSrc :: ConduitT () Message m ()
outSrc = TBMChan Message -> ConduitT () Message m ()
forall (m :: * -> *) a.
MonadIO m =>
TBMChan a -> ConduitT () a m ()
sourceTBMChan (Session -> TBMChan Message
outCh Session
qs)
m () -> (Async () -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m () -> m ()) -> ConduitT () Void m () -> m ()
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString m ()
src ConduitT () ByteString m ()
-> ConduitT ByteString Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Ver -> ConduitT ByteString (Either Response Value) m ()
forall (m :: * -> *).
MonadLogger m =>
Ver -> ConduitT ByteString (Either Response Value) m ()
decodeConduit Ver
ver ConduitT ByteString (Either Response Value) m ()
-> ConduitT (Either Response Value) Void m ()
-> ConduitT ByteString Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT (Either Response Value) Void m ()
forall {z}. ConduitT (Either Response Value) z m ()
inSnk) ((Async () -> m a) -> m a) -> (Async () -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ m a -> Async () -> m a
forall a b. a -> b -> a
const (m a -> Async () -> m a) -> m a -> Async () -> m a
forall a b. (a -> b) -> a -> b
$
m () -> (Async () -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m () -> m ()) -> ConduitT () Void m () -> m ()
forall a b. (a -> b) -> a -> b
$ ConduitT () Message m ()
outSrc ConduitT () Message m ()
-> ConduitT Message Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Message ByteString m ()
forall j (m :: * -> *).
(ToJSON j, MonadLogger m) =>
ConduitT j ByteString m ()
encodeConduit ConduitT Message ByteString m ()
-> ConduitT ByteString Void m () -> ConduitT Message Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Void m ()
snk) ((Async () -> m a) -> m a) -> (Async () -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Async ()
o ->
m () -> (Async () -> m a) -> m a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (ReaderT Session m () -> Session -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Session m ()
forall (m :: * -> *). (Functor m, MonadLoggerIO m) => JSONRPCT m ()
processIncoming Session
qs) ((Async () -> m a) -> m a) -> (Async () -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ m a -> Async () -> m a
forall a b. a -> b -> a
const (m a -> Async () -> m a) -> m a -> Async () -> m a
forall a b. (a -> b) -> a -> b
$ do
a
a <- JSONRPCT m a -> Session -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT JSONRPCT m a
f Session
qs
IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ())
-> (TBMChan Message -> STM ()) -> TBMChan Message -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBMChan Message -> STM ()
forall a. TBMChan a -> STM ()
closeTBMChan (TBMChan Message -> IO ()) -> TBMChan Message -> IO ()
forall a b. (a -> b) -> a -> b
$ Session -> TBMChan Message
outCh Session
qs
()
_ <- Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async ()
o
a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
cr :: Monad m => ConduitT ByteString ByteString m ()
cr :: forall (m :: * -> *).
Monad m =>
ConduitT ByteString ByteString m ()
cr = (ByteString -> ByteString) -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map (ByteString -> Char -> ByteString
`B8.snoc` Char
'\n')
jsonrpcTCPClient
:: (MonadLoggerIO m, MonadUnliftIO m)
=> Ver
-> Bool
-> ClientSettings
-> JSONRPCT m a
-> m a
jsonrpcTCPClient :: forall (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m) =>
Ver -> Bool -> ClientSettings -> JSONRPCT m a -> m a
jsonrpcTCPClient Ver
ver Bool
ignore ClientSettings
cs JSONRPCT m a
f = ClientSettings -> (AppData -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
ClientSettings -> (AppData -> m a) -> m a
runGeneralTCPClient ClientSettings
cs ((AppData -> m a) -> m a) -> (AppData -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \AppData
ad ->
Ver
-> Bool
-> ConduitT ByteString Void m ()
-> ConduitT () ByteString m ()
-> JSONRPCT m a
-> m a
forall (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m) =>
Ver
-> Bool
-> ConduitT ByteString Void m ()
-> ConduitT () ByteString m ()
-> JSONRPCT m a
-> m a
runJSONRPCT Ver
ver Bool
ignore (ConduitT ByteString ByteString m ()
forall (m :: * -> *).
Monad m =>
ConduitT ByteString ByteString m ()
cr ConduitT ByteString ByteString m ()
-> ConduitT ByteString Void m () -> ConduitT ByteString Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| AppData -> ConduitT ByteString Void m ()
forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
appSink AppData
ad) (AppData -> ConduitT () ByteString m ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
appSource AppData
ad) JSONRPCT m a
f
jsonrpcTCPServer
:: (MonadLoggerIO m, MonadUnliftIO m)
=> Ver
-> Bool
-> ServerSettings
-> JSONRPCT m ()
-> m a
jsonrpcTCPServer :: forall (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m) =>
Ver -> Bool -> ServerSettings -> JSONRPCT m () -> m a
jsonrpcTCPServer Ver
ver Bool
ignore ServerSettings
ss JSONRPCT m ()
f = ServerSettings -> (AppData -> m ()) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
ServerSettings -> (AppData -> m ()) -> m a
runGeneralTCPServer ServerSettings
ss ((AppData -> m ()) -> m a) -> (AppData -> m ()) -> m a
forall a b. (a -> b) -> a -> b
$ \AppData
cl ->
Ver
-> Bool
-> ConduitT ByteString Void m ()
-> ConduitT () ByteString m ()
-> JSONRPCT m ()
-> m ()
forall (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m) =>
Ver
-> Bool
-> ConduitT ByteString Void m ()
-> ConduitT () ByteString m ()
-> JSONRPCT m a
-> m a
runJSONRPCT Ver
ver Bool
ignore (ConduitT ByteString ByteString m ()
forall (m :: * -> *).
Monad m =>
ConduitT ByteString ByteString m ()
cr ConduitT ByteString ByteString m ()
-> ConduitT ByteString Void m () -> ConduitT ByteString Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| AppData -> ConduitT ByteString Void m ()
forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
appSink AppData
cl) (AppData -> ConduitT () ByteString m ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
appSource AppData
cl) JSONRPCT m ()
f