{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}
-- | Interface for JSON-RPC.
module Network.JSONRPC.Interface
( -- * Establish JSON-RPC context
  JSONRPCT
, runJSONRPCT

  -- * Conduits for encoding/decoding
, decodeConduit
, encodeConduit

  -- * Communicate with remote party
, receiveRequest
, receiveBatchRequest
, sendResponse
, sendBatchResponse
, sendRequest
, sendBatchRequest

  -- * Transports
  -- ** Client
, jsonrpcTCPClient
  -- ** Server
, jsonrpcTCPServer

  -- * Internal data and functions
, 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.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
                       }

-- Context for JSON-RPC connection.  Connection will remain active as long
-- as context is maintaned.
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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (if Bool
ignore then Maybe (TBMChan BatchRequest) -> STM (Maybe (TBMChan BatchRequest))
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 (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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ver -> STM Ver
forall (m :: * -> *) a. Monad m => a -> m a
return Ver
v
            STM (TVar Bool -> Session) -> STM (TVar Bool) -> STM Session
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

-- Conduit to encode JSON to ByteString.
encodeConduit :: (ToJSON j, MonadLogger m) => ConduitT j ByteString m ()
encodeConduit :: 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 (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

-- | Conduit to decode incoming messages.  Left Response indicates
-- a response to send back to sender if parsing JSON fails.
decodeConduit :: MonadLogger m
              => Ver -> ConduitT ByteString (Either Response Value) m ()
decodeConduit :: 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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ConduitT ByteString (Either Response Value) m (Maybe ByteString)
forall (m :: * -> *) i. Monad m => Consumer i 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 (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 (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 (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 (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
_) =
        LogSource
-> LogSource
-> StateT
     (Maybe (ByteString -> IResult ByteString Value))
     (ConduitT ByteString (Either Response Value) m)
     ()
$logDebugS LogSource
"json-rpc" LogSource
"ignoring null string at end of incoming data"
    handl Bool
b (Fail ByteString
i [String]
_ String
_) = do
        LogSource
-> LogSource
-> StateT
     (Maybe (ByteString -> IResult ByteString Value))
     (ConduitT ByteString (Either Response Value) m)
     ()
$logErrorS LogSource
"json-rpc" LogSource
"error parsing incoming message"
        ConduitT ByteString (Either Response Value) m ()
-> StateT
     (Maybe (ByteString -> IResult ByteString Value))
     (ConduitT ByteString (Either Response Value) m)
     ()
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 (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 (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

-- | Process incoming messages. Do not use this directly unless you know
-- what you are doing. This is an internal function.
processIncoming :: (Functor m, MonadLoggerIO m) => JSONRPCT m ()
processIncoming :: JSONRPCT m ()
processIncoming =
    ReaderT Session m Session
forall r (m :: * -> *). MonadReader r m => m r
ask ReaderT Session m Session
-> (Session -> JSONRPCT m ()) -> JSONRPCT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Session
qs ->
        ReaderT Session m (JSONRPCT m ()) -> JSONRPCT m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ReaderT Session m (JSONRPCT m ()) -> JSONRPCT m ())
-> (STM (JSONRPCT m ()) -> ReaderT Session m (JSONRPCT m ()))
-> STM (JSONRPCT m ())
-> JSONRPCT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (JSONRPCT m ()) -> ReaderT Session m (JSONRPCT m ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (JSONRPCT m ()) -> ReaderT Session m (JSONRPCT m ()))
-> (STM (JSONRPCT m ()) -> IO (JSONRPCT m ()))
-> STM (JSONRPCT m ())
-> ReaderT Session m (JSONRPCT m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (JSONRPCT m ()) -> IO (JSONRPCT m ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (JSONRPCT m ()) -> JSONRPCT m ())
-> STM (JSONRPCT m ()) -> JSONRPCT 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 (JSONRPCT m ()))
-> STM (JSONRPCT m ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (Either Response Value)
Nothing -> Session -> STM (JSONRPCT 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
                        JSONRPCT m () -> STM (JSONRPCT m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (JSONRPCT m () -> STM (JSONRPCT m ()))
-> JSONRPCT m () -> STM (JSONRPCT m ())
forall a b. (a -> b) -> a -> b
$ do
                            LogSource -> LogSource -> JSONRPCT m ()
$logDebugS LogSource
"json-rpc" LogSource
"received message"
                            JSONRPCT 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)
                        JSONRPCT m () -> STM (JSONRPCT m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (JSONRPCT m () -> STM (JSONRPCT m ()))
-> JSONRPCT m () -> STM (JSONRPCT m ())
forall a b. (a -> b) -> a -> b
$ do
                            LogSource -> LogSource -> JSONRPCT m ()
$logDebugS LogSource
"json-rpc" LogSource
"received batch"
                            JSONRPCT 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
                        JSONRPCT m () -> STM (JSONRPCT m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (JSONRPCT m () -> STM (JSONRPCT m ()))
-> JSONRPCT m () -> STM (JSONRPCT m ())
forall a b. (a -> b) -> a -> b
$ do
                            LogSource -> LogSource -> JSONRPCT m ()
$logWarnS LogSource
"json-rpc" LogSource
"got invalid message"
                            JSONRPCT 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
                        JSONRPCT m () -> STM (JSONRPCT m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (JSONRPCT m () -> STM (JSONRPCT m ()))
-> JSONRPCT m () -> STM (JSONRPCT m ())
forall a b. (a -> b) -> a -> b
$ do
                            LogSource -> LogSource -> JSONRPCT m ()
$logWarnS LogSource
"json-rpc" LogSource
"error parsing JSON"
                            JSONRPCT 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 (m :: * -> *) a. Monad m => a -> m a
return (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$ do
            LogSource -> LogSource -> m ()
$logDebugS LogSource
"json-rpc" LogSource
"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
$ LogSource -> LogSource -> m ()
$logErrorS LogSource
"json-rpc" LogSource
"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 (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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Either Message Request)
-> STM (Maybe (Either Message Request))
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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either Message Request)
forall a. Maybe a
Nothing
                    Request {} -> do
                        let e :: ErrorObj
e = LogSource -> ErrorObj
errorMethod (Request -> LogSource
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 (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 -- Ignore orphan errors
        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 (m :: * -> *) a. Monad m => a -> m a
return () -- Ignore orphan responses
                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

-- | Returns Nothing if did not receive response, could not parse it, or
-- request is a notification. Just Left contains the error object returned
-- by server if any. Just Right means response was received just right.
sendRequest :: (MonadLoggerIO m , ToJSON q, ToRequest q, FromResponse r)
            => q -> JSONRPCT m (Maybe (Either ErrorObj r))
sendRequest :: q -> JSONRPCT m (Maybe (Either ErrorObj r))
sendRequest q
q = [Maybe (Either ErrorObj r)] -> Maybe (Either ErrorObj r)
forall a. [a] -> a
head ([Maybe (Either ErrorObj r)] -> Maybe (Either ErrorObj r))
-> ReaderT Session m [Maybe (Either ErrorObj r)]
-> JSONRPCT 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]

-- | Send multiple requests in a batch. If only a single request, do not
-- put it in a batch.
sendBatchRequest :: (MonadLoggerIO m, ToJSON q, ToRequest q, FromResponse r)
                 => [q] -> JSONRPCT m [Maybe (Either ErrorObj r)]
sendBatchRequest :: [q] -> JSONRPCT m [Maybe (Either ErrorObj r)]
sendBatchRequest [q]
qs = do
    Ver
v <- (Session -> Ver) -> ReaderT Session m Ver
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 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 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 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 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 (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 (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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return [(Request, Maybe (TMVar (Maybe Response)))]
aps
    if [(Request, Maybe (TMVar (Maybe Response)))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Request, Maybe (TMVar (Maybe Response)))]
aps
        then LogSource -> LogSource -> ReaderT Session m ()
$logDebugS LogSource
"json-rpc" LogSource
"no responses pending"
        else LogSource -> LogSource -> ReaderT Session m ()
$logDebugS LogSource
"json-rpc" LogSource
"listening for responses if pending"
    IO [Maybe (Either ErrorObj r)]
-> JSONRPCT m [Maybe (Either ErrorObj r)]
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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either ErrorObj r)
forall a. Maybe a
Nothing
                    Just r :: Response
r@Response{} ->
                        case LogSource -> Response -> Maybe r
forall r. FromResponse r => LogSource -> Response -> Maybe r
fromResponse (Request -> LogSource
getReqMethod Request
a) Response
r of
                            Maybe r
Nothing -> Maybe (Either ErrorObj r) -> STM (Maybe (Either ErrorObj r))
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 (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 (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

-- | Receive requests from remote endpoint. Returns Nothing if incoming
-- channel is closed or has never been opened. Will reject incoming request
-- if sent in a batch.
receiveRequest :: MonadLoggerIO m => JSONRPCT m (Maybe Request)
receiveRequest :: 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 (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 (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 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
$ LogSource -> Value
String LogSource
"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 (m :: * -> *) a. Monad m => a -> m a
return Maybe Request
forall a. Maybe a
Nothing

-- | Receive batch of requests. Will also accept single requests.
receiveBatchRequest :: MonadLoggerIO m => JSONRPCT m (Maybe BatchRequest)
receiveBatchRequest :: JSONRPCT m (Maybe BatchRequest)
receiveBatchRequest = do
    Maybe (TBMChan BatchRequest)
chM <- (Session -> Maybe (TBMChan BatchRequest))
-> ReaderT Session m (Maybe (TBMChan BatchRequest))
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
            LogSource -> LogSource -> ReaderT Session m ()
$logDebugS LogSource
"json-rpc" LogSource
"listening for a new request"
            IO (Maybe BatchRequest) -> JSONRPCT m (Maybe BatchRequest)
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
            LogSource -> LogSource -> ReaderT Session m ()
$logErrorS LogSource
"json-rpc" LogSource
"ignoring requests from remote endpoint"
            Maybe BatchRequest -> JSONRPCT m (Maybe BatchRequest)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BatchRequest
forall a. Maybe a
Nothing

-- | Send response message. Do not use to respond to a batch of requests.
sendResponse :: MonadLoggerIO m => Response -> JSONRPCT m ()
sendResponse :: Response -> JSONRPCT m ()
sendResponse Response
r = do
    TBMChan Message
o <- (Session -> TBMChan Message) -> ReaderT Session m (TBMChan Message)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TBMChan Message
outCh
    IO () -> JSONRPCT m ()
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

-- | Send batch of responses. Use to respond to a batch of requests.
sendBatchResponse :: MonadLoggerIO m => BatchResponse -> JSONRPCT m ()
sendBatchResponse :: BatchResponse -> JSONRPCT m ()
sendBatchResponse (BatchResponse [Response]
rs) = do
    TBMChan Message
o <- (Session -> TBMChan Message) -> ReaderT Session m (TBMChan Message)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TBMChan Message
outCh
    IO () -> JSONRPCT m ()
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 r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TBMChan Message
outCh
    IO () -> JSONRPCT m ()
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

-- | Send any message. Do not use this. Use the other high-level functions
-- instead. Will not track request ids. Incoming responses to requests sent
-- using this method will be ignored.
sendMessage :: MonadLoggerIO m => Message -> JSONRPCT m ()
sendMessage :: Message -> JSONRPCT m ()
sendMessage Message
msg = (Session -> TBMChan Message) -> ReaderT Session m (TBMChan Message)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader Session -> TBMChan Message
outCh ReaderT Session m (TBMChan Message)
-> (TBMChan Message -> JSONRPCT m ()) -> JSONRPCT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> JSONRPCT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSONRPCT m ())
-> (TBMChan Message -> IO ()) -> TBMChan 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 ())
-> (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)

-- | Create JSON-RPC session around conduits from transport layer.  When
-- context exits session disappears.
runJSONRPCT ::
       (MonadLoggerIO m, MonadUnliftIO m)
    => Ver -- ^ JSON-RPC version
    -> Bool -- ^ Ignore incoming requests/notifs
    -> ConduitT ByteString Void m () -- ^ Sink to send messages
    -> ConduitT () ByteString m () -- ^ Source to receive messages from
    -> JSONRPCT m a -- ^ JSON-RPC action
    -> m a -- ^ Output of action
runJSONRPCT :: 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 (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 =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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 ()
-> ConduitM (Either Response Value) Void m ()
-> ConduitT ByteString Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM (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 ()
-> ConduitM Message Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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 () -> ConduitM Message Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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 (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 (m :: * -> *) a. Monad m => a -> m a
return a
a


cr :: Monad m => ConduitT ByteString ByteString m ()
cr :: 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')

--
-- Transports
--

-- | TCP client transport for JSON-RPC.
jsonrpcTCPClient
    :: (MonadLoggerIO m, MonadUnliftIO m)
    => Ver            -- ^ JSON-RPC version
    -> Bool           -- ^ Ignore incoming requests or notifications
    -> ClientSettings -- ^ Connection settings
    -> JSONRPCT m a   -- ^ JSON-RPC action
    -> m a            -- ^ Output of action
jsonrpcTCPClient :: 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 =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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

-- | TCP server transport for JSON-RPC.
jsonrpcTCPServer
    :: (MonadLoggerIO m, MonadUnliftIO m)
    => Ver             -- ^ JSON-RPC version
    -> Bool            -- ^ Ignore incoming requests or notifications
    -> ServerSettings  -- ^ Connection settings
    -> JSONRPCT m ()   -- ^ Action to perform on connecting client thread
    -> m a
jsonrpcTCPServer :: 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 =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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