json-rpc 0.7.1.1 → 0.8.0.0

raw patch · 16 files changed

+1924/−1485 lines, 16 filesdep +hspecdep +timedep +unliftiodep −lifted-asyncdep −monad-controldep −stmnew-component:exe:concurrent-clientnew-component:exe:concurrent-servernew-component:exe:time-clientnew-component:exe:time-serverPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec, time, unliftio

Dependencies removed: lifted-async, monad-control, stm, test-framework, test-framework-quickcheck2, transformers

API changes (from Hackage documentation)

Files

• Network/JsonRpc.hs +0/−23
• Network/JsonRpc/Arbitrary.hs +0/−81
• Network/JsonRpc/Data.hs +0/−413
• Network/JsonRpc/Interface.hs +0/−363
• examples/concurrent-client.hs +97/−0
• examples/concurrent-server.hs +81/−0
• examples/time-client.hs +71/−0
• examples/time-server.hs +70/−0
• json-rpc.cabal +166/−67
• src/Network/JSONRPC.hs +23/−0
• src/Network/JSONRPC/Arbitrary.hs +80/−0
• src/Network/JSONRPC/Data.hs +413/−0
• src/Network/JSONRPC/Interface.hs +365/−0
• test/Network/JsonRpc/Tests.hs +0/−532
• test/Spec.hs +558/−0
• test/main.hs +0/−6

@@ -1,23 +0,0 @@-module Network.JsonRpc-( -- * Introduction-  -- $introduction--  module Network.JsonRpc.Interface-, module Network.JsonRpc.Data-) where--import Network.JsonRpc.Interface-import Network.JsonRpc.Data-import Network.JsonRpc.Arbitrary()---- $introduction------ This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and 1.0. It--- provides an interface that combines a JSON-RPC client and server. It can--- set and keep track of request ids to parse responses.  There is support--- for sending and receiving notifications. You may use any underlying--- transport.  Basic TCP client and server provided.------ A JSON-RPC application using this interface is considered to be--- peer-to-peer, as it can send and receive all types of JSON-RPC message--- independent of whether it originated the connection.

@@ -1,81 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Network.JsonRpc.Arbitrary where--import Control.Applicative-import Data.Aeson.Types-import qualified Data.HashMap.Strict as M-import Data.Text (Text)-import qualified Data.Text as T-import Network.JsonRpc.Data-import Test.QuickCheck.Arbitrary-import Test.QuickCheck.Gen--instance Arbitrary Text where-    arbitrary = T.pack <$> arbitrary--instance Arbitrary Ver where-    arbitrary = elements [V1, V2]--instance Arbitrary Request where-    arbitrary = oneof-        [ Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-        , Notif <$> arbitrary <*> arbitrary <*> arbitrary-        ]--instance Arbitrary Response where-    arbitrary = oneof-        [ Response <$> arbitrary <*> arbitrary <*> arbitrary-        , ResponseError <$> arbitrary <*> arbitrary <*> arbitrary-        , OrphanError <$> arbitrary <*> arbitrary-        ]---instance Arbitrary ErrorObj where-    arbitrary = oneof-        [ ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary-        , ErrorVal <$> arbitrary-        ]--instance Arbitrary BatchRequest where-    arbitrary = oneof-        [ BatchRequest <$> arbitrary-        , SingleRequest <$> arbitrary-        ]--instance Arbitrary BatchResponse where-    arbitrary = oneof-        [ BatchResponse <$> arbitrary-        , SingleResponse <$> arbitrary-        ]--instance Arbitrary Message where-    arbitrary = oneof-        [ MsgRequest  <$> arbitrary-        , MsgResponse <$> arbitrary-        , MsgBatch    <$> batch-        ]-      where-        batch = listOf $ oneof [ MsgRequest  <$> arbitrary-                               , MsgResponse <$> arbitrary-                               ]--instance Arbitrary Id where-    arbitrary = oneof [IdInt <$> arbitrary, IdTxt <$> arbitrary]--instance Arbitrary Value where-    arbitrary = resize 10 $ oneof [nonull, lsn, objn] where-        nonull = oneof-            [ toJSON <$> (arbitrary :: Gen String)-            , toJSON <$> (arbitrary :: Gen Int)-            , toJSON <$> (arbitrary :: Gen Double)-            , toJSON <$> (arbitrary :: Gen Bool)-            ]-        val = oneof [ nonull, return Null ]-        ls   = toJSON <$> listOf val-        obj  = toJSON . M.fromList <$> listOf ps-        ps   = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls]-        lsn  = toJSON <$> listOf (oneof [ls, obj, val])-        objn = toJSON . M.fromList <$> listOf psn-        psn  = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls, obj]-

@@ -1,413 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveGeneric #-}--- | Implementation of basic JSON-RPC data types.-module Network.JsonRpc.Data-( -- * Requests-  Request(..)-, BatchRequest(..)-  -- ** Parsing-, FromRequest(..)-, fromRequest-  -- ** Encoding-, ToRequest(..)-, buildRequest--  -- * Responses-, Response(..)-, BatchResponse(..)-  -- ** Parsing-, FromResponse(..)-, fromResponse-  -- ** Encoding-, Respond-, buildResponse-  -- ** Errors-, ErrorObj(..)-, fromError-  -- ** Error messages-, errorParse-, errorInvalid-, errorParams-, errorMethod-, errorId--  -- * Others-, Message(..)-, Method-, Id(..)-, fromId-, Ver(..)--) where--import Control.Applicative-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as L-import Control.DeepSeq-import Control.Monad-import Data.Aeson (encode)-import Data.Aeson.Types-import Data.Hashable (Hashable)-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding-import GHC.Generics (Generic)-------- Requests-----data Request = Request { getReqVer      :: !Ver-                       , getReqMethod   :: !Method-                       , getReqParams   :: !Value-                       , getReqId       :: !Id-                       }-             | Notif   { getReqVer      :: !Ver-                       , getReqMethod   :: !Method-                       , getReqParams   :: !Value-                       }-             deriving (Eq, Show, Generic)--instance NFData Request where-    rnf (Request v m p i) = rnf v `seq` rnf m `seq` rnf p `seq` rnf i-    rnf (Notif v m p) = rnf v `seq` rnf m `seq` rnf p--instance ToJSON Request where-    toJSON (Request V2 m p i) = object $ case p of-        Null -> [jr2, "method" .= m, "id" .= i]-        _    -> [jr2, "method" .= m, "id" .= i, "params" .= p]-    toJSON (Request V1 m p i) = object $ case p of-        Null -> ["method" .= m, "params" .= emptyArray, "id" .= i]-        _    -> ["method" .= m, "params" .= p, "id" .= i]-    toJSON (Notif V2 m p) = object $ case p of-        Null -> [jr2, "method" .= m]-        _    -> [jr2, "method" .= m, "params" .= p]-    toJSON (Notif V1 m p) = object $ case p of-        Null -> ["method" .= m, "params" .= emptyArray, "id" .= Null]-        _    -> ["method" .= m, "params" .= p, "id" .= Null]--class FromRequest q where-    -- | Parser for params Value in JSON-RPC request.-    parseParams :: Method -> Maybe (Value -> Parser q)--fromRequest :: FromRequest q => Request -> Either ErrorObj q-fromRequest req =-    case parserM of-        Nothing -> Left $ errorMethod m-        Just parser ->-            case parseMaybe parser p of-                Nothing -> Left $ errorParams p-                Just  q -> Right q-  where-    m = getReqMethod req-    p = getReqParams req-    parserM = parseParams m--instance FromRequest Value where-    parseParams = const $ Just return--instance FromRequest () where-    parseParams = const . Just . const $ return ()--instance FromJSON Request where-    parseJSON = withObject "request" $ \o -> do-        (v, n, m, p) <- parseVerIdMethParams o-        case n of Nothing -> return $ Notif   v m p-                  Just i  -> return $ Request v m p i--parseVerIdMethParams :: Object -> Parser (Ver, Maybe Id, Method, Value)-parseVerIdMethParams o = do-    v <- parseVer o-    i <- o .:? "id"-    m <- o .: "method"-    p <- o .:? "params" .!= Null-    return (v, i, m, p)--class ToRequest q where-    -- | Method associated with request data to build a request object.-    requestMethod :: q -> Method--    -- | Is this request to be sent as a notification (no id, no response)?-    requestIsNotif :: q -> Bool--instance ToRequest Value where-    requestMethod = const "json"-    requestIsNotif = const False--instance ToRequest () where-    requestMethod = const "json"-    requestIsNotif = const False--buildRequest :: (ToJSON q, ToRequest q)-             => Ver             -- ^ JSON-RPC version-             -> q               -- ^ Request data-             -> Id-             -> Request-buildRequest ver q = if requestIsNotif q-                         then const $ Notif ver (requestMethod q) (toJSON q)-                         else Request ver (requestMethod q) (toJSON q)------- Responses-----data Response = Response      { getResVer :: !Ver-                              , getResult :: !Value-                              , getResId  :: !Id-                              }-              | ResponseError { getResVer :: !Ver-                              , getError  :: !ErrorObj-                              , getResId  :: !Id-                              }-              | OrphanError   { getResVer :: !Ver-                              , getError  :: !ErrorObj-                              }-              deriving (Eq, Show, Generic)-             --instance NFData Response where-    rnf (Response v r i) = rnf v `seq` rnf r `seq` rnf i-    rnf (ResponseError v o i) = rnf v `seq` rnf o `seq` rnf i-    rnf (OrphanError v o) = rnf v `seq` rnf o--instance ToJSON Response where-    toJSON (Response V1 r i) = object-        ["id" .= i, "result" .= r, "error" .= Null]-    toJSON (Response V2 r i) = object-        [jr2, "id" .= i, "result" .= r]-    toJSON (ResponseError V1 e i) = object-        ["id" .= i, "error" .= e, "result" .= Null]-    toJSON (ResponseError V2 e i) = object-        [jr2, "id" .= i, "error" .= e]-    toJSON (OrphanError V1 e) = object-        ["id" .= Null, "error" .= e, "result" .= Null]-    toJSON (OrphanError V2 e) = object-        [jr2, "id" .= Null, "error" .= e]--class FromResponse r where-    -- | Parser for result Value in JSON-RPC response.-    -- Method corresponds to request to which this response answers.-    parseResult :: Method -> Maybe (Value -> Parser r)---- | Parse a response knowing the method of the corresponding request.-fromResponse :: FromResponse r => Method -> Response -> Maybe r-fromResponse m (Response _ r _) = parseResult m >>= flip parseMaybe r-fromResponse _ _ = Nothing--instance FromResponse Value where-    parseResult = const $ Just return--instance FromResponse () where-    parseResult = const Nothing--instance FromJSON Response where-    parseJSON = withObject "response" $ \o -> do-        (v, d, s) <- parseVerIdResultError o-        case s of-            Right r -> do-                guard $ isJust d-                return $ Response v r (fromJust d)-            Left e ->-                case d of-                    Just  i -> return $ ResponseError v e i-                    Nothing -> return $ OrphanError v e--parseVerIdResultError :: Object-                      -> Parser (Ver, Maybe Id, Either ErrorObj Value)-parseVerIdResultError o = do-    v <- parseVer o-    i <- o .:? "id"-    r <- o .:? "result" .!= Null-    p <- if r == Null then Left <$> o .: "error" else return $ Right r-    return (v, i, p)---- | Create a response from a request. Use in servers.-buildResponse :: (Monad m, FromRequest q, ToJSON r)-              => Respond q m r-              -> Request-              -> m (Maybe Response)-buildResponse f req@(Request v _ _ i) =-    case fromRequest req of-        Left e -> return . Just $ ResponseError v e i-        Right q -> do-            rE <- f q-            case rE of-                Left  e -> return . Just $ ResponseError v e i-                Right r -> return . Just $ Response v (toJSON r) i-buildResponse _ _ = return Nothing---- | Type of function to make it easy to create a response from a request.--- Meant to be used in servers.-type Respond q m r = q -> m (Either ErrorObj r)---- | Error object from JSON-RPC 2.0. ErrorVal for backwards compatibility.-data ErrorObj = ErrorObj  { getErrMsg  :: !String-                          , getErrCode :: !Int-                          , getErrData :: !Value-                          }-              | ErrorVal  { getErrData :: !Value }-              deriving (Show, Eq, Generic)--instance NFData ErrorObj where-    rnf (ErrorObj m c d) = rnf m `seq` rnf c `seq` rnf d-    rnf (ErrorVal v) = rnf v--instance FromJSON ErrorObj where-    parseJSON Null = mzero-    parseJSON v@(Object o) = p1 <|> p2 where-        p1 = do-            m <- o .: "message"-            c <- o .: "code"-            d <- o .:? "data" .!= Null-            return $ ErrorObj m c d-        p2 = return $ ErrorVal v-    parseJSON v = return $ ErrorVal v--instance ToJSON ErrorObj where-    toJSON (ErrorObj s i d) = object $ ["message" .= s, "code" .= i]-        ++ if d == Null then [] else ["data" .= d]-    toJSON (ErrorVal v) = v---- | Get a user-friendly string with the error information.-fromError :: ErrorObj -> String-fromError (ErrorObj m c v) = show c ++ ": " ++ m ++ ": " ++ valueAsString v-fromError (ErrorVal (String t)) = T.unpack t-fromError (ErrorVal v) = valueAsString v--valueAsString :: Value -> String-valueAsString = T.unpack . decodeUtf8 . L.toStrict . encode---- | Parse error.-errorParse :: ByteString -> ErrorObj-errorParse = ErrorObj "Parse error" (-32700) . String . decodeUtf8---- | Invalid request.-errorInvalid :: Value -> ErrorObj-errorInvalid = ErrorObj "Invalid request" (-32600)---- | Invalid params.-errorParams :: Value -> ErrorObj-errorParams = ErrorObj "Invalid params" (-32602)---- | Method not found.-errorMethod :: Method -> ErrorObj-errorMethod = ErrorObj "Method not found" (-32601) . toJSON---- | Id not recognized.-errorId :: Id -> ErrorObj-errorId = ErrorObj "Id not recognized" (-32000) . toJSON-------- Messages-----data BatchRequest-    = BatchRequest     { getBatchRequest  :: ![Request] }-    | SingleRequest    { getSingleRequest ::  !Request  }-    deriving (Eq, Show, Generic)--instance NFData BatchRequest where-    rnf (BatchRequest qs) = rnf qs-    rnf (SingleRequest q) = rnf q--instance FromJSON BatchRequest where-    parseJSON qs@Array{} = BatchRequest  <$> parseJSON qs-    parseJSON q@Object{} = SingleRequest <$> parseJSON q-    parseJSON _ = mzero--instance ToJSON BatchRequest where-    toJSON (BatchRequest qs) = toJSON qs-    toJSON (SingleRequest q) = toJSON q--data BatchResponse-    = BatchResponse    { getBatchResponse :: ![Response] }-    | SingleResponse   { getSingleResponse :: !Response  }-    deriving (Eq, Show, Generic)--instance NFData BatchResponse where-    rnf (BatchResponse qs) = rnf qs-    rnf (SingleResponse q) = rnf q--instance FromJSON BatchResponse where-    parseJSON qs@Array{} = BatchResponse  <$> parseJSON qs-    parseJSON q@Object{} = SingleResponse <$> parseJSON q-    parseJSON _ = mzero--instance ToJSON BatchResponse where-    toJSON (BatchResponse qs) = toJSON qs-    toJSON (SingleResponse q) = toJSON q--data Message-    = MsgRequest  { getMsgRequest  :: !Request   }-    | MsgResponse { getMsgResponse :: !Response  }-    | MsgBatch    { getBatch       :: ![Message] }-    deriving (Eq, Show, Generic)--instance NFData Message where-    rnf (MsgRequest  q) = rnf q-    rnf (MsgResponse r) = rnf r-    rnf (MsgBatch    b) = rnf b--instance ToJSON Message where-    toJSON (MsgRequest  q) = toJSON q-    toJSON (MsgResponse r) = toJSON r-    toJSON (MsgBatch    b) = toJSON b--instance FromJSON Message where-    parseJSON v = (MsgRequest   <$> parseJSON v)-              <|> (MsgResponse  <$> parseJSON v)-              <|> (MsgBatch     <$> parseJSON v)------- Types-----type Method = Text--data Id = IdInt { getIdInt :: !Int  }-        | IdTxt { getIdTxt :: !Text }-    deriving (Eq, Show, Read, Generic)--instance Hashable Id--instance NFData Id where-    rnf (IdInt i) = rnf i-    rnf (IdTxt t) = rnf t--instance Enum Id where-    toEnum = IdInt-    fromEnum (IdInt i) = i-    fromEnum _ = error "Can't enumerate non-integral ids"--instance FromJSON Id where-    parseJSON s@(String _) = IdTxt <$> parseJSON s-    parseJSON n@(Number _) = IdInt <$> parseJSON n-    parseJSON _ = mzero--instance ToJSON Id where-    toJSON (IdTxt s) = toJSON s-    toJSON (IdInt n) = toJSON n---- | Pretty display a message id. Meant for logs.-fromId :: Id -> String-fromId (IdInt i) = show i-fromId (IdTxt t) = T.unpack t---- | JSON-RPC version.-data Ver = V1 -- ^ JSON-RPC 1.0-         | V2 -- ^ JSON-RPC 2.0-         deriving (Eq, Show, Read, Generic)--instance NFData Ver where-    rnf v = v `seq` ()--jr2 :: Pair-jr2 = "jsonrpc" .= ("2.0" :: Text)--parseVer :: Object -> Parser Ver-parseVer o = do-    j <- o .:? "jsonrpc"-    return $ if j == Just ("2.0" :: Text) then V2 else V1

@@ -1,363 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# 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.Applicative-import Control.Concurrent.Async.Lifted-import Control.Concurrent.STM-import Control.Monad-import Control.Monad.Logger-import Control.Monad.Reader-import Control.Monad.Trans.State-import Control.Monad.Trans.Control-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.Either-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.Maybe-import Data.Conduit.Network-import Data.Conduit.TMChan-import qualified Data.Foldable as F-import qualified Data.Vector as V-import Network.JsonRpc.Data--type SentRequests = HashMap Id (TMVar (Maybe Response))--data Session = Session { inCh     :: TBMChan (Either Response Value)-                       , outCh    :: TBMChan Message-                       , reqCh    :: Maybe (TBMChan BatchRequest)-                       , lastId   :: TVar Id-                       , sentReqs :: TVar SentRequests-                       , rpcVer   :: Ver-                       , 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 v ignore =-    Session <$> newTBMChan 128-            <*> newTBMChan 128-            <*> (if ignore then return Nothing else Just <$> newTBMChan 128)-            <*> newTVar (IdInt 0)-            <*> newTVar M.empty-            <*> return v-            <*> newTVar False---- Conduit to encode JSON to ByteString.-encodeConduit :: (ToJSON j, MonadLogger m) => Conduit j m ByteString-encodeConduit = CL.mapM $ \m -> return . L8.toStrict $ encode m---- | Conduit to decode incoming messages.  Left Response indicates--- a response to send back to sender if parsing JSON fails.-decodeConduit :: MonadLogger m-              => Ver -> Conduit ByteString m (Either Response Value)-decodeConduit ver = evalStateT loop Nothing where-    loop = lift await >>= maybe flush (process False)-    flush = get >>= maybe (return ()) (handle True . ($ B8.empty))-    process b = runParser >=> handle b-    runParser ck = maybe (parse json ck) ($ ck) <$> get <* put Nothing--    handle True (Fail "" _ _) =-        $(logDebug) "ignoring null string at end of incoming data"-    handle b (Fail i _ _) = do-        $(logError) "error parsing incoming message"-        lift . yield . Left $ OrphanError ver (errorParse i)-        unless b loop-    handle _ (Partial k) = put (Just k) >> loop-    handle b (Done rest v) = do-        lift $ yield $ Right v-        if B8.null rest-           then unless b loop-           else process b 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 = ask >>= \qs -> join . liftIO . atomically $ do-    vEM <- readTBMChan $ inCh qs-    case vEM of-        Nothing -> flush qs-        Just vE ->-            case vE of-                Right v@Object{} -> do-                    single qs v-                    return $ do-                        $(logDebug) "received message"-                        processIncoming-                Right v@(Array a) -> do-                    if V.null a-                        then do-                            let e = OrphanError (rpcVer qs) (errorInvalid v)-                            writeTBMChan (outCh qs) $ MsgResponse e-                        else batch qs (V.toList a)-                    return $ do-                        $(logDebug) "received batch"-                        processIncoming-                Right v -> do-                    let e = OrphanError (rpcVer qs) (errorInvalid v)-                    writeTBMChan (outCh qs) $ MsgResponse e-                    return $ do-                        $(logWarn) "got invalid message"-                        processIncoming-                Left e -> do-                    writeTBMChan (outCh qs) $ MsgResponse e-                    return $ do-                        $(logWarn) "error parsing JSON"-                        processIncoming-  where-    flush qs = do-        m <- readTVar $ sentReqs qs-        F.forM_ (reqCh qs) closeTBMChan-        closeTBMChan $ outCh qs-        writeTVar (dead qs) True-        mapM_ ((`putTMVar` Nothing) . snd) $ M.toList m-        return $ do-            $(logDebug) "session is now dead"-            unless (M.null m) $ $(logError) "requests remained unfulfilled"-    batch qs vs = do-        ts <- catMaybes <$> forM vs (process qs)-        unless (null ts) $-            if any isRight ts-                then do-                    let ch = fromJust $ reqCh qs-                    writeTBMChan ch $ BatchRequest $ rights ts-                else writeTBMChan (outCh qs) $ MsgBatch $ lefts ts-    single qs v = do-        tM <- process qs v-        case tM of-            Nothing -> return ()-            Just (Right t) -> do-                let ch = fromJust $ reqCh qs-                writeTBMChan ch $ SingleRequest t-            Just (Left e) -> writeTBMChan (outCh qs) e-    process qs v = do-        let qM = parseMaybe parseJSON v-        case qM of-            Just q -> request qs q-            Nothing -> do-                let rM = parseMaybe parseJSON v-                case rM of-                    Just r -> response qs r >> return Nothing-                    Nothing -> do-                        let e = OrphanError (rpcVer qs) (errorInvalid v)-                            m = MsgResponse e-                        return $ Just $ Left m-    request qs t =-        case reqCh qs of-            Just _ -> return $ Just $ Right t-            Nothing ->-                case t of-                    Notif{} -> return Nothing-                    Request{} -> do-                        let e = errorMethod (getReqMethod t)-                            v = getReqVer t-                            i = getReqId t-                            m = MsgResponse $ ResponseError v e i-                        return $ Just $ Left m-    response qs r = do-        let hasid = case r of-                        Response{}      -> True-                        ResponseError{} -> True-                        OrphanError{}   -> False -- Ignore orphan errors-        when hasid $ do-            let x = getResId r-            m <- readTVar (sentReqs qs)-            case x `M.lookup` m of-                Nothing -> return () -- Ignore orphan responses-                Just p -> do-                    writeTVar (sentReqs qs) $ M.delete x m-                    putTMVar p $ Just 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 = head `liftM` sendBatchRequest [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 qs = do-    v <- reader rpcVer-    l <- reader lastId-    s <- reader sentReqs-    o <- reader outCh-    k <- reader dead-    aps <- liftIO . atomically $ do-        d <- readTVar k-        aps <- forM qs $ \q ->-            if requestIsNotif q-                then return (buildRequest v q undefined, Nothing)-                else do-                    p <- newEmptyTMVar -                    i <- succ <$> readTVar l-                    m <- readTVar s-                    unless d $ writeTVar s $ M.insert i p m-                    unless d $ writeTVar l i-                    if d-                        then return (buildRequest v q i, Nothing)-                        else return (buildRequest v q i, Just p)-        case map fst aps of-            []  -> return ()-            [a] -> unless d $ writeTBMChan o $ MsgRequest a-            as  -> unless d $ writeTBMChan o $ MsgBatch $ map MsgRequest as-        return aps-    if null aps-        then $(logDebug) "no responses pending"-        else $(logDebug) "listening for responses if pending"-    liftIO . atomically $ forM aps $ \(a, pM) ->-        case pM of-            Nothing -> return Nothing-            Just  p -> do-                rM <- takeTMVar p-                case rM of-                    Nothing -> return Nothing-                    Just r@Response{} ->-                        case fromResponse (getReqMethod a) r of-                            Nothing -> return Nothing-                            Just  x -> return $ Just $ Right x-                    Just e -> return $ Just $ Left $ getError 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 = do-    bt <- receiveBatchRequest-    case bt of-        Nothing -> return Nothing-        Just (SingleRequest q) -> return $ Just q-        Just BatchRequest{} -> do-            v <- reader rpcVer-            let e = errorInvalid $ String "not accepting batches"-                m = OrphanError v e-            sendResponse m-            return Nothing---- | Receive batch of requests. Will also accept single requests.-receiveBatchRequest :: MonadLoggerIO m => JsonRpcT m (Maybe BatchRequest)-receiveBatchRequest = do-    chM <- reader reqCh-    case chM of-        Just ch -> do-            $(logDebug) "listening for a new request"-            liftIO . atomically $ readTBMChan ch-        Nothing -> do-            $(logError) "ignoring requests from remote endpoint"-            return Nothing---- | Send response message. Do not use to respond to a batch of requests.-sendResponse :: MonadLoggerIO m => Response -> JsonRpcT m ()-sendResponse r = do-    o <- reader outCh-    liftIO . atomically . writeTBMChan o $ MsgResponse r---- | Send batch of responses. Use to respond to a batch of requests.-sendBatchResponse :: MonadLoggerIO m => BatchResponse -> JsonRpcT m ()-sendBatchResponse (BatchResponse rs) = do-    o <- reader outCh-    liftIO . atomically . writeTBMChan o $ MsgBatch $ map MsgResponse rs-sendBatchResponse (SingleResponse r) = do-    o <- reader outCh-    liftIO . atomically . writeTBMChan o $ MsgResponse 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 msg = reader outCh >>= liftIO . atomically . (`writeTBMChan` msg)---- | Create JSON-RPC session around conduits from transport layer.  When--- context exits session disappears.-runJsonRpcT :: (MonadLoggerIO m, MonadBaseControl IO m)-            => Ver                  -- ^ JSON-RPC version-            -> Bool                 -- ^ Ignore incoming requests/notifs-            -> Sink ByteString m () -- ^ Sink to send messages-            -> Source m ByteString  -- ^ Source to receive messages from-            -> JsonRpcT m a         -- ^ JSON-RPC action-            -> m a                  -- ^ Output of action-runJsonRpcT ver ignore snk src f = do-    qs <- liftIO . atomically $ initSession ver ignore-    let inSnk  = sinkTBMChan (inCh qs) True-        outSrc = sourceTBMChan (outCh qs)-    withAsync (src $$ decodeConduit ver $= inSnk) $ const $-        withAsync (outSrc =$ encodeConduit $$ snk) $ \o ->-            withAsync (runReaderT processIncoming qs) $ const $ do-                a <- runReaderT f qs-                liftIO $ do-                    atomically . closeTBMChan $ outCh qs-                    _ <- wait o-                    return a---cr :: Monad m => Conduit ByteString m ByteString-cr = CL.map (`B8.snoc` '\n')------- Transports------- | TCP client transport for JSON-RPC.-jsonRpcTcpClient-    :: (MonadLoggerIO m, MonadBaseControl IO 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 ignore cs f = runGeneralTCPClient cs $ \ad ->-    runJsonRpcT ver ignore (cr =$ appSink ad) (appSource ad) f---- | TCP server transport for JSON-RPC.-jsonRpcTcpServer-    :: (MonadLoggerIO m, MonadBaseControl IO 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 ignore ss f = runGeneralTCPServer ss $ \cl ->-    runJsonRpcT ver ignore (cr =$ appSink cl) (appSource cl) f

@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+import           Control.Monad+import           Control.Monad.Logger+import           Data.Aeson+import           Data.Aeson.Types     hiding (Error)+import           Data.Conduit.Network+import qualified Data.Foldable        as F+import           Data.Maybe+import qualified Data.Text            as T+import           Data.Time.Clock+import           Data.Time.Format+import           Network.JSONRPC+import           UnliftIO+import           UnliftIO.Concurrent++data Req = TimeReq | Ping deriving (Show, Eq)++instance FromRequest Req where+    parseParams "time" = Just $ const $ return TimeReq+    parseParams "ping" = Just $ const $ return Ping+    parseParams _      = Nothing++instance ToRequest Req where+    requestMethod TimeReq = "time"+    requestMethod Ping    = "ping"+    requestIsNotif        = const False++instance ToJSON Req where+    toJSON = const emptyArray++data Res = Time { getTime :: UTCTime } | Pong deriving (Show, Eq)++instance FromResponse Res where+    parseResult "time" = Just $ withText "time" $ \t ->+        case parseTimeM True defaultTimeLocale "%c" $ T.unpack t of+            Just t' -> return $ Time t'+            Nothing -> mzero+    parseResult "ping" = Just $ const $ return Pong+    parseResult _ = Nothing++instance ToJSON Res where+    toJSON (Time t) = toJSON $ formatTime defaultTimeLocale "%c" t+    toJSON Pong     = emptyArray++handleResponse :: Maybe (Either ErrorObj Res) -> Res+handleResponse t =+    case t of+        Nothing        -> error "could not receive or parse response"+        Just (Left e)  -> error $ fromError e+        Just (Right r) -> r++req :: MonadLoggerIO m => JSONRPCT m Res+req = do+    tEM <- sendRequest TimeReq+    $(logDebug) "sending time request"+    return $ handleResponse tEM++reqBatch :: MonadLoggerIO m => JSONRPCT m [Res]+reqBatch = do+    $(logDebug) "sending pings"+    tEMs <- sendBatchRequest $ replicate 2 Ping+    return $ map handleResponse tEMs++respond :: MonadLoggerIO m => Respond Req m Res+respond TimeReq = (Right . Time) <$> liftIO getCurrentTime+respond Ping    = return $ Right Pong++main :: IO ()+main = runStderrLoggingT $+    jsonrpcTCPClient V2 False (clientSettings 31337 "::1") $+        withAsync responder $ const $ do+            $(logDebug) "sending four time requests one second apart"+            replicateM_ 4 $ do+                req >>= $(logDebug) . T.pack . ("response: "++) . show+                liftIO (threadDelay 1000000)+            $(logDebug) "sending two pings in a batch"+            reqBatch >>= $(logDebug) . T.pack . ("response: "++) . show++responder :: MonadLoggerIO m => JSONRPCT m ()+responder = do+    $(logDebug) "listening for new request"+    qM <- receiveBatchRequest+    case qM of+        Nothing -> do+            $(logDebug) "closed request channel, exting"+            return ()+        Just (SingleRequest q) -> do+            $(logDebug) "got request"+            rM <- buildResponse respond q+            F.forM_ rM sendResponse+            responder+        Just (BatchRequest qs) -> do+            $(logDebug) "got request batch"+            rs <- catMaybes `liftM` forM qs (buildResponse respond)+            sendBatchResponse $ BatchResponse rs+            responder

@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+import           Control.Monad+import           Control.Monad.Logger+import           Control.Monad.Trans+import           Data.Aeson.Types     hiding (Error)+import           Data.Conduit.Network+import qualified Data.Foldable        as F+import           Data.Maybe+import qualified Data.Text            as T+import           Data.Time.Clock+import           Data.Time.Format+import           Network.JSONRPC+import           UnliftIO+import           UnliftIO.Concurrent++data Req = TimeReq | Ping deriving (Show, Eq)++instance FromRequest Req where+    parseParams "time" = Just $ const $ return TimeReq+    parseParams "ping" = Just $ const $ return Ping+    parseParams _      = Nothing++instance ToRequest Req where+    requestMethod TimeReq = "time"+    requestMethod Ping    = "ping"+    requestIsNotif        = const False++instance ToJSON Req where+    toJSON = const emptyArray++data Res = Time { getTime :: UTCTime } | Pong deriving (Show, Eq)++instance FromResponse Res where+    parseResult "time" = Just $ withText "time" $ \t ->+        case parseTimeM True defaultTimeLocale "%c" $ T.unpack t of+            Just t' -> return $ Time t'+            Nothing -> mzero+    parseResult "ping" = Just $ const $ return Pong+    parseResult _ = Nothing++instance ToJSON Res where+    toJSON (Time t) = toJSON $ formatTime defaultTimeLocale "%c" t+    toJSON Pong     = emptyArray++respond :: MonadLoggerIO m => Respond Req m Res+respond TimeReq = (Right . Time) <$> liftIO getCurrentTime+respond Ping    = return $ Right Pong++main :: IO ()+main = runStderrLoggingT $ do+    let ss = serverSettings 31337 "::1"+    jsonrpcTCPServer V2 False ss $ withAsync pinger $ const srv++srv :: MonadLoggerIO m => JSONRPCT m ()+srv = do+    $(logDebug) "listening for new request"+    qM <- receiveBatchRequest+    case qM of+        Nothing -> do+            $(logDebug) "closed request channel, exting"+            return ()+        Just (SingleRequest q) -> do+            $(logDebug) "got request"+            rM <- buildResponse respond q+            F.forM_ rM sendResponse+            srv+        Just (BatchRequest qs) -> do+            $(logDebug) "got request batch"+            rs <- catMaybes `liftM` forM qs (buildResponse respond)+            sendBatchResponse $ BatchResponse rs+            srv++pinger :: MonadLoggerIO m => JSONRPCT m ()+pinger = do+    $(logDebug) "ping client"+    p <- sendRequest Ping+    $(logDebug) $ T.pack $+        "received " ++ show (p :: Maybe (Either ErrorObj Res))+    liftIO $ threadDelay 1500000+    pinger

@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+import           Control.Monad+import           Control.Monad.Logger+import           Control.Monad.Trans+import           Data.Aeson+import           Data.Aeson.Types     hiding (Error)+import           Data.Conduit.Network+import qualified Data.Text            as T+import           Data.Time.Clock+import           Data.Time.Format+import           Network.JSONRPC+import           UnliftIO.Concurrent++data Req = TimeReq | Ping deriving (Show, Eq)++instance FromRequest Req where+    parseParams "time" = Just $ const $ return TimeReq+    parseParams "ping" = Just $ const $ return Ping+    parseParams _      = Nothing++instance ToRequest Req where+    requestMethod TimeReq = "time"+    requestMethod Ping    = "ping"+    requestIsNotif        = const False++instance ToJSON Req where+    toJSON = const emptyArray++data Res = Time { getTime :: UTCTime } | Pong deriving (Show, Eq)++instance FromResponse Res where+    parseResult "time" = Just $ withText "time" $ \t ->+        case parseTimeM True defaultTimeLocale "%c" $ T.unpack t of+            Just t' -> return $ Time t'+            Nothing -> mzero+    parseResult "ping" = Just $ const $ return Pong+    parseResult _ = Nothing++instance ToJSON Res where+    toJSON (Time t) = toJSON $ formatTime defaultTimeLocale "%c" t+    toJSON Pong     = emptyArray++handleResponse :: Maybe (Either ErrorObj Res) -> Res+handleResponse t =+    case t of+        Nothing        -> error "could not receive or parse response"+        Just (Left e)  -> error $ fromError e+        Just (Right r) -> r++req :: MonadLoggerIO m => JSONRPCT m Res+req = do+    tEM <- sendRequest TimeReq+    $(logDebug) "sending time request"+    return $ handleResponse tEM++reqBatch :: MonadLoggerIO m => JSONRPCT m [Res]+reqBatch = do+    $(logDebug) "sending pings"+    tEMs <- sendBatchRequest $ replicate 2 Ping+    return $ map handleResponse tEMs++main :: IO ()+main = runStderrLoggingT $+    jsonrpcTCPClient V2 True (clientSettings 31337 "::1") $ do+        $(logDebug) "sending two time requests one second apart"+        replicateM_ 2 $ do+            req >>= $(logDebug) . T.pack . ("response: "++) . show+            liftIO (threadDelay 1000000)+        $(logDebug) "sending two pings in a batch"+        reqBatch >>= $(logDebug) . T.pack . ("response: "++) . show

@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+import           Control.Monad+import           Control.Monad.Logger+import           Control.Monad.Trans+import           Data.Aeson.Types+import           Data.Conduit.Network+import qualified Data.Foldable        as F+import           Data.Maybe+import qualified Data.Text            as T+import           Data.Time.Clock+import           Data.Time.Format+import           Network.JSONRPC++data Req = TimeReq | Ping deriving (Show, Eq)++instance FromRequest Req where+    parseParams "time" = Just $ const $ return TimeReq+    parseParams "ping" = Just $ const $ return Ping+    parseParams _      = Nothing++instance ToRequest Req where+    requestMethod TimeReq = "time"+    requestMethod Ping    = "ping"+    requestIsNotif        = const False++instance ToJSON Req where+    toJSON = const emptyArray++data Res = Time { getTime :: UTCTime } | Pong deriving (Show, Eq)++instance FromResponse Res where+    parseResult "time" = Just $ withText "time" $ \t ->+        case parseTimeM True defaultTimeLocale "%c" $ T.unpack t of+            Just t' -> return $ Time t'+            Nothing -> mzero+    parseResult "ping" = Just $ const $ return Pong+    parseResult _ = Nothing++instance ToJSON Res where+    toJSON (Time t) = toJSON $ formatTime defaultTimeLocale "%c" t+    toJSON Pong     = emptyArray++respond :: MonadLoggerIO m => Respond Req m Res+respond TimeReq = (Right . Time) <$> liftIO getCurrentTime+respond Ping    = return $ Right Pong++main :: IO ()+main = runStderrLoggingT $ do+    let ss = serverSettings 31337 "::1"+    jsonrpcTCPServer V2 False ss srv++srv :: MonadLoggerIO m => JSONRPCT m ()+srv = do+    $(logDebug) "listening for new request"+    qM <- receiveBatchRequest+    case qM of+        Nothing -> do+            $(logDebug) "closed request channel, exting"+            return ()+        Just (SingleRequest q) -> do+            $(logDebug) "got request"+            rM <- buildResponse respond q+            F.forM_ rM sendResponse+            srv+        Just (BatchRequest qs) -> do+            $(logDebug) "got request batch"+            rs <- catMaybes `liftM` forM qs (buildResponse respond)+            sendBatchResponse $ BatchResponse rs+            srv

@@ -1,73 +1,172 @@-name:                   json-rpc-version:                0.7.1.1-synopsis:               Fully-featured JSON-RPC 2.0 library-description:-  This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and 1.0. It-  provides an interface that combines a JSON-RPC client and server. It can set-  and keep track of request ids to parse responses. There is support for-  sending and receiving notifications.  You may use any underlying transport.-  Basic TCP client and server provided.-homepage:               https://github.com/xenog/json-rpc-license:                PublicDomain-license-file:           UNLICENSE-author:                 Jean-Pierre Rupp-maintainer:             root@haskoin.com-category:               Network-build-type:             Simple-extra-source-files:     README.md-cabal-version:          >= 1.10+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: a02d2b107df6439cd518ee3c9bd65b181355abbe8d1c04d46fe6d0fdbe6045eb +name:           json-rpc+version:        0.8.0.0+synopsis:       Fully-featured JSON-RPC 2.0 library+description:    Library compatible with JSON-RPC 2.0 and 1.0+category:       Network+homepage:       https://github.com/xenog/json-rpc.git#readme+bug-reports:    https://github.com/xenog/json-rpc.git/issues+author:         Jean-Pierre Rupp+maintainer:     xenog@protonmail.com+license:        PublicDomain+license-file:   UNLICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    README.md+ source-repository head-  type:                 git-  location:             https://github.com/xenog/json-rpc.git+  type: git+  location: https://github.com/xenog/json-rpc.git  library-  exposed-modules:      Network.JsonRpc-  other-modules:        Network.JsonRpc.Data,-                        Network.JsonRpc.Interface-                        Network.JsonRpc.Arbitrary-  build-depends:        base                        >= 4.6      && < 5,-                        aeson,-                        attoparsec,-                        bytestring,-                        conduit,-                        conduit-extra,-                        deepseq,-                        hashable,-                        lifted-async,-                        monad-control,-                        monad-logger,-                        mtl,-                        stm,-                        stm-conduit,-                        text,-                        transformers,-                        unordered-containers,-                        vector,-                        QuickCheck-  default-language:     Haskell2010-  ghc-options:          -Wall+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      QuickCheck+    , aeson+    , attoparsec+    , base >=4.6 && <5+    , bytestring+    , conduit+    , conduit-extra+    , deepseq+    , hashable+    , monad-logger+    , mtl+    , stm-conduit+    , text+    , time+    , unliftio+    , unordered-containers+    , vector+  exposed-modules:+      Network.JSONRPC+  other-modules:+      Network.JSONRPC.Arbitrary+      Network.JSONRPC.Data+      Network.JSONRPC.Interface+      Paths_json_rpc+  default-language: Haskell2010 +executable concurrent-client+  main-is: examples/concurrent-client.hs+  build-depends:+      QuickCheck+    , aeson+    , base >=4.6 && <5+    , bytestring+    , conduit+    , conduit-extra+    , json-rpc+    , monad-logger+    , mtl+    , stm-conduit+    , text+    , time+    , unliftio+    , unordered-containers+    , vector+  other-modules:+      Paths_json_rpc+  default-language: Haskell2010++executable concurrent-server+  main-is: examples/concurrent-server.hs+  build-depends:+      QuickCheck+    , aeson+    , base >=4.6 && <5+    , bytestring+    , conduit+    , conduit-extra+    , json-rpc+    , monad-logger+    , mtl+    , stm-conduit+    , text+    , time+    , unliftio+    , unordered-containers+    , vector+  other-modules:+      Paths_json_rpc+  default-language: Haskell2010++executable time-client+  main-is: examples/time-client.hs+  build-depends:+      QuickCheck+    , aeson+    , base >=4.6 && <5+    , bytestring+    , conduit+    , conduit-extra+    , json-rpc+    , monad-logger+    , mtl+    , stm-conduit+    , text+    , time+    , unliftio+    , unordered-containers+    , vector+  other-modules:+      Paths_json_rpc+  default-language: Haskell2010++executable time-server+  main-is: examples/time-server.hs+  build-depends:+      QuickCheck+    , aeson+    , base >=4.6 && <5+    , bytestring+    , conduit+    , conduit-extra+    , json-rpc+    , monad-logger+    , mtl+    , stm-conduit+    , text+    , time+    , unliftio+    , unordered-containers+    , vector+  other-modules:+      Paths_json_rpc+  default-language: Haskell2010+ test-suite test-json-rpc-  hs-source-dirs:       test-  type:                 exitcode-stdio-1.0 -  main-is:              main.hs-  other-modules:        Network.JsonRpc.Tests-  build-depends:        base                        >= 4.6      && < 5,-                        aeson,-                        bytestring,-                        conduit,-                        json-rpc,-                        lifted-async,-                        monad-logger,-                        mtl,-                        text,-                        unordered-containers,-                        stm,-                        stm-conduit,-                        transformers,-                        QuickCheck,-                        test-framework,-                        test-framework-quickcheck2-  default-language:     Haskell2010-  ghc-options:          -Wall+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , aeson+    , base >=4.6 && <5+    , bytestring+    , conduit+    , conduit-extra+    , hspec+    , json-rpc+    , monad-logger+    , mtl+    , stm-conduit+    , text+    , time+    , unliftio+    , unordered-containers+    , vector+  other-modules:+      Paths_json_rpc+  default-language: Haskell2010

@@ -0,0 +1,23 @@+module Network.JSONRPC+( -- * Introduction+  -- $introduction++  module Network.JSONRPC.Interface+, module Network.JSONRPC.Data+) where++import           Network.JSONRPC.Arbitrary ()+import           Network.JSONRPC.Data+import           Network.JSONRPC.Interface++-- $introduction+--+-- This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and 1.0. It+-- provides an interface that combines a JSON-RPC client and server. It can+-- set and keep track of request ids to parse responses.  There is support+-- for sending and receiving notifications. You may use any underlying+-- transport.  Basic TCP client and server provided.+--+-- A JSON-RPC application using this interface is considered to be+-- peer-to-peer, as it can send and receive all types of JSON-RPC message+-- independent of whether it originated the connection.

@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Network.JSONRPC.Arbitrary where++import           Data.Aeson.Types+import qualified Data.HashMap.Strict       as M+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Network.JSONRPC.Data+import           Test.QuickCheck.Arbitrary+import           Test.QuickCheck.Gen++instance Arbitrary Text where+    arbitrary = T.pack <$> arbitrary++instance Arbitrary Ver where+    arbitrary = elements [V1, V2]++instance Arbitrary Request where+    arbitrary = oneof+        [ Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+        , Notif <$> arbitrary <*> arbitrary <*> arbitrary+        ]++instance Arbitrary Response where+    arbitrary = oneof+        [ Response <$> arbitrary <*> arbitrary <*> arbitrary+        , ResponseError <$> arbitrary <*> arbitrary <*> arbitrary+        , OrphanError <$> arbitrary <*> arbitrary+        ]+++instance Arbitrary ErrorObj where+    arbitrary = oneof+        [ ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary+        , ErrorVal <$> arbitrary+        ]++instance Arbitrary BatchRequest where+    arbitrary = oneof+        [ BatchRequest <$> arbitrary+        , SingleRequest <$> arbitrary+        ]++instance Arbitrary BatchResponse where+    arbitrary = oneof+        [ BatchResponse <$> arbitrary+        , SingleResponse <$> arbitrary+        ]++instance Arbitrary Message where+    arbitrary = oneof+        [ MsgRequest  <$> arbitrary+        , MsgResponse <$> arbitrary+        , MsgBatch    <$> batch+        ]+      where+        batch = listOf $ oneof [ MsgRequest  <$> arbitrary+                               , MsgResponse <$> arbitrary+                               ]++instance Arbitrary Id where+    arbitrary = IdInt <$> arbitraryBoundedRandom++instance Arbitrary Value where+    arbitrary = resize 10 $ oneof [nonull, lsn, objn] where+        nonull = oneof+            [ toJSON <$> (arbitrary :: Gen String)+            , toJSON <$> (arbitrary :: Gen Int)+            , toJSON <$> (arbitrary :: Gen Double)+            , toJSON <$> (arbitrary :: Gen Bool)+            ]+        val = oneof [ nonull, return Null ]+        ls   = toJSON <$> listOf val+        obj  = toJSON . M.fromList <$> listOf ps+        ps   = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls]+        lsn  = toJSON <$> listOf (oneof [ls, obj, val])+        objn = toJSON . M.fromList <$> listOf psn+        psn  = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls, obj]+

@@ -0,0 +1,413 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Implementation of basic JSON-RPC data types.+module Network.JSONRPC.Data+( -- * Requests+  Request(..)+, BatchRequest(..)+  -- ** Parsing+, FromRequest(..)+, fromRequest+  -- ** Encoding+, ToRequest(..)+, buildRequest++  -- * Responses+, Response(..)+, BatchResponse(..)+  -- ** Parsing+, FromResponse(..)+, fromResponse+  -- ** Encoding+, Respond+, buildResponse+  -- ** Errors+, ErrorObj(..)+, fromError+  -- ** Error messages+, errorParse+, errorInvalid+, errorParams+, errorMethod+, errorId++  -- * Others+, Message(..)+, Method+, Id(..)+, fromId+, Ver(..)++) where++import           Control.Applicative+import           Control.DeepSeq+import           Control.Monad+import           Data.Aeson           (encode)+import           Data.Aeson.Types+import           Data.ByteString      (ByteString)+import qualified Data.ByteString.Lazy as L+import           Data.Hashable        (Hashable)+import           Data.Maybe+import           Data.Text            (Text)+import qualified Data.Text            as T+import           Data.Text.Encoding+import           GHC.Generics         (Generic)+++--+-- Requests+--++data Request = Request { getReqVer    :: !Ver+                       , getReqMethod :: !Method+                       , getReqParams :: !Value+                       , getReqId     :: !Id+                       }+             | Notif   { getReqVer    :: !Ver+                       , getReqMethod :: !Method+                       , getReqParams :: !Value+                       }+             deriving (Eq, Show, Generic)++instance NFData Request where+    rnf (Request v m p i) = rnf v `seq` rnf m `seq` rnf p `seq` rnf i+    rnf (Notif v m p)     = rnf v `seq` rnf m `seq` rnf p++instance ToJSON Request where+    toJSON (Request V2 m p i) = object $ case p of+        Null -> [jr2, "method" .= m, "id" .= i]+        _    -> [jr2, "method" .= m, "id" .= i, "params" .= p]+    toJSON (Request V1 m p i) = object $ case p of+        Null -> ["method" .= m, "params" .= emptyArray, "id" .= i]+        _    -> ["method" .= m, "params" .= p, "id" .= i]+    toJSON (Notif V2 m p) = object $ case p of+        Null -> [jr2, "method" .= m]+        _    -> [jr2, "method" .= m, "params" .= p]+    toJSON (Notif V1 m p) = object $ case p of+        Null -> ["method" .= m, "params" .= emptyArray, "id" .= Null]+        _    -> ["method" .= m, "params" .= p, "id" .= Null]++class FromRequest q where+    -- | Parser for params Value in JSON-RPC request.+    parseParams :: Method -> Maybe (Value -> Parser q)++fromRequest :: FromRequest q => Request -> Either ErrorObj q+fromRequest req =+    case parserM of+        Nothing -> Left $ errorMethod m+        Just parser ->+            case parseMaybe parser p of+                Nothing -> Left $ errorParams p+                Just  q -> Right q+  where+    m = getReqMethod req+    p = getReqParams req+    parserM = parseParams m++instance FromRequest Value where+    parseParams = const $ Just return++instance FromRequest () where+    parseParams = const . Just . const $ return ()++instance FromJSON Request where+    parseJSON = withObject "request" $ \o -> do+        (v, n, m, p) <- parseVerIdMethParams o+        case n of Nothing -> return $ Notif   v m p+                  Just i  -> return $ Request v m p i++parseVerIdMethParams :: Object -> Parser (Ver, Maybe Id, Method, Value)+parseVerIdMethParams o = do+    v <- parseVer o+    i <- o .:? "id"+    m <- o .: "method"+    p <- o .:? "params" .!= Null+    return (v, i, m, p)++class ToRequest q where+    -- | Method associated with request data to build a request object.+    requestMethod :: q -> Method++    -- | Is this request to be sent as a notification (no id, no response)?+    requestIsNotif :: q -> Bool++instance ToRequest Value where+    requestMethod = const "json"+    requestIsNotif = const False++instance ToRequest () where+    requestMethod = const "json"+    requestIsNotif = const False++buildRequest :: (ToJSON q, ToRequest q)+             => Ver             -- ^ JSON-RPC version+             -> q               -- ^ Request data+             -> Id+             -> Request+buildRequest ver q = if requestIsNotif q+                         then const $ Notif ver (requestMethod q) (toJSON q)+                         else Request ver (requestMethod q) (toJSON q)++--+-- Responses+--++data Response = Response      { getResVer :: !Ver+                              , getResult :: !Value+                              , getResId  :: !Id+                              }+              | ResponseError { getResVer :: !Ver+                              , getError  :: !ErrorObj+                              , getResId  :: !Id+                              }+              | OrphanError   { getResVer :: !Ver+                              , getError  :: !ErrorObj+                              }+              deriving (Eq, Show, Generic)+++instance NFData Response where+    rnf (Response v r i)      = rnf v `seq` rnf r `seq` rnf i+    rnf (ResponseError v o i) = rnf v `seq` rnf o `seq` rnf i+    rnf (OrphanError v o)     = rnf v `seq` rnf o++instance ToJSON Response where+    toJSON (Response V1 r i) = object+        ["id" .= i, "result" .= r, "error" .= Null]+    toJSON (Response V2 r i) = object+        [jr2, "id" .= i, "result" .= r]+    toJSON (ResponseError V1 e i) = object+        ["id" .= i, "error" .= e, "result" .= Null]+    toJSON (ResponseError V2 e i) = object+        [jr2, "id" .= i, "error" .= e]+    toJSON (OrphanError V1 e) = object+        ["id" .= Null, "error" .= e, "result" .= Null]+    toJSON (OrphanError V2 e) = object+        [jr2, "id" .= Null, "error" .= e]++class FromResponse r where+    -- | Parser for result Value in JSON-RPC response.+    -- Method corresponds to request to which this response answers.+    parseResult :: Method -> Maybe (Value -> Parser r)++-- | Parse a response knowing the method of the corresponding request.+fromResponse :: FromResponse r => Method -> Response -> Maybe r+fromResponse m (Response _ r _) = parseResult m >>= flip parseMaybe r+fromResponse _ _                = Nothing++instance FromResponse Value where+    parseResult = const $ Just return++instance FromResponse () where+    parseResult = const Nothing++instance FromJSON Response where+    parseJSON = withObject "response" $ \o -> do+        (v, d, s) <- parseVerIdResultError o+        case s of+            Right r -> do+                guard $ isJust d+                return $ Response v r (fromJust d)+            Left e ->+                case d of+                    Just  i -> return $ ResponseError v e i+                    Nothing -> return $ OrphanError v e++parseVerIdResultError :: Object+                      -> Parser (Ver, Maybe Id, Either ErrorObj Value)+parseVerIdResultError o = do+    v <- parseVer o+    i <- o .:? "id"+    r <- o .:? "result" .!= Null+    p <- if r == Null then Left <$> o .: "error" else return $ Right r+    return (v, i, p)++-- | Create a response from a request. Use in servers.+buildResponse :: (Monad m, FromRequest q, ToJSON r)+              => Respond q m r+              -> Request+              -> m (Maybe Response)+buildResponse f req@(Request v _ _ i) =+    case fromRequest req of+        Left e -> return . Just $ ResponseError v e i+        Right q -> do+            rE <- f q+            case rE of+                Left  e -> return . Just $ ResponseError v e i+                Right r -> return . Just $ Response v (toJSON r) i+buildResponse _ _ = return Nothing++-- | Type of function to make it easy to create a response from a request.+-- Meant to be used in servers.+type Respond q m r = q -> m (Either ErrorObj r)++-- | Error object from JSON-RPC 2.0. ErrorVal for backwards compatibility.+data ErrorObj = ErrorObj  { getErrMsg  :: !String+                          , getErrCode :: !Int+                          , getErrData :: !Value+                          }+              | ErrorVal  { getErrData :: !Value }+              deriving (Show, Eq, Generic)++instance NFData ErrorObj where+    rnf (ErrorObj m c d) = rnf m `seq` rnf c `seq` rnf d+    rnf (ErrorVal v)     = rnf v++instance FromJSON ErrorObj where+    parseJSON Null = mzero+    parseJSON v@(Object o) = p1 <|> p2 where+        p1 = do+            m <- o .: "message"+            c <- o .: "code"+            d <- o .:? "data" .!= Null+            return $ ErrorObj m c d+        p2 = return $ ErrorVal v+    parseJSON v = return $ ErrorVal v++instance ToJSON ErrorObj where+    toJSON (ErrorObj s i d) = object $ ["message" .= s, "code" .= i]+        ++ if d == Null then [] else ["data" .= d]+    toJSON (ErrorVal v) = v++-- | Get a user-friendly string with the error information.+fromError :: ErrorObj -> String+fromError (ErrorObj m c v) = show c ++ ": " ++ m ++ ": " ++ valueAsString v+fromError (ErrorVal (String t)) = T.unpack t+fromError (ErrorVal v) = valueAsString v++valueAsString :: Value -> String+valueAsString = T.unpack . decodeUtf8 . L.toStrict . encode++-- | Parse error.+errorParse :: ByteString -> ErrorObj+errorParse = ErrorObj "Parse error" (-32700) . String . decodeUtf8++-- | Invalid request.+errorInvalid :: Value -> ErrorObj+errorInvalid = ErrorObj "Invalid request" (-32600)++-- | Invalid params.+errorParams :: Value -> ErrorObj+errorParams = ErrorObj "Invalid params" (-32602)++-- | Method not found.+errorMethod :: Method -> ErrorObj+errorMethod = ErrorObj "Method not found" (-32601) . toJSON++-- | Id not recognized.+errorId :: Id -> ErrorObj+errorId = ErrorObj "Id not recognized" (-32000) . toJSON+++--+-- Messages+--++data BatchRequest+    = BatchRequest     { getBatchRequest  :: ![Request] }+    | SingleRequest    { getSingleRequest ::  !Request  }+    deriving (Eq, Show, Generic)++instance NFData BatchRequest where+    rnf (BatchRequest qs) = rnf qs+    rnf (SingleRequest q) = rnf q++instance FromJSON BatchRequest where+    parseJSON qs@Array{} = BatchRequest  <$> parseJSON qs+    parseJSON q@Object{} = SingleRequest <$> parseJSON q+    parseJSON _          = mzero++instance ToJSON BatchRequest where+    toJSON (BatchRequest qs) = toJSON qs+    toJSON (SingleRequest q) = toJSON q++data BatchResponse+    = BatchResponse    { getBatchResponse :: ![Response] }+    | SingleResponse   { getSingleResponse :: !Response  }+    deriving (Eq, Show, Generic)++instance NFData BatchResponse where+    rnf (BatchResponse qs) = rnf qs+    rnf (SingleResponse q) = rnf q++instance FromJSON BatchResponse where+    parseJSON qs@Array{} = BatchResponse  <$> parseJSON qs+    parseJSON q@Object{} = SingleResponse <$> parseJSON q+    parseJSON _          = mzero++instance ToJSON BatchResponse where+    toJSON (BatchResponse qs) = toJSON qs+    toJSON (SingleResponse q) = toJSON q++data Message+    = MsgRequest  { getMsgRequest  :: !Request   }+    | MsgResponse { getMsgResponse :: !Response  }+    | MsgBatch    { getBatch       :: ![Message] }+    deriving (Eq, Show, Generic)++instance NFData Message where+    rnf (MsgRequest  q) = rnf q+    rnf (MsgResponse r) = rnf r+    rnf (MsgBatch    b) = rnf b++instance ToJSON Message where+    toJSON (MsgRequest  q) = toJSON q+    toJSON (MsgResponse r) = toJSON r+    toJSON (MsgBatch    b) = toJSON b++instance FromJSON Message where+    parseJSON v = (MsgRequest   <$> parseJSON v)+              <|> (MsgResponse  <$> parseJSON v)+              <|> (MsgBatch     <$> parseJSON v)++--+-- Types+--++type Method = Text++data Id = IdInt { getIdInt :: !Int  }+        | IdTxt { getIdTxt :: !Text }+    deriving (Eq, Show, Read, Generic)++instance Hashable Id++instance NFData Id where+    rnf (IdInt i) = rnf i+    rnf (IdTxt t) = rnf t++instance Enum Id where+    toEnum = IdInt+    fromEnum (IdInt i) = i+    fromEnum _         = error "Can't enumerate non-integral ids"++instance FromJSON Id where+    parseJSON s@(String _) = IdTxt <$> parseJSON s+    parseJSON n@(Number _) = IdInt <$> parseJSON n+    parseJSON _            = mzero++instance ToJSON Id where+    toJSON (IdTxt s) = toJSON s+    toJSON (IdInt n) = toJSON n++-- | Pretty display a message id. Meant for logs.+fromId :: Id -> String+fromId (IdInt i) = show i+fromId (IdTxt t) = T.unpack t++-- | JSON-RPC version.+data Ver = V1 -- ^ JSON-RPC 1.0+         | V2 -- ^ JSON-RPC 2.0+         deriving (Eq, Show, Read, Generic)++instance NFData Ver where+    rnf v = v `seq` ()++jr2 :: Pair+jr2 = "jsonrpc" .= ("2.0" :: Text)++parseVer :: Object -> Parser Ver+parseVer o = do+    j <- o .:? "jsonrpc"+    return $ if j == Just ("2.0" :: Text) then V2 else V1

@@ -0,0 +1,365 @@+{-# 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 { inCh     :: TBMChan (Either Response Value)+                       , outCh    :: TBMChan Message+                       , reqCh    :: Maybe (TBMChan BatchRequest)+                       , lastId   :: TVar Id+                       , sentReqs :: TVar SentRequests+                       , rpcVer   :: Ver+                       , 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 v ignore =+    Session <$> newTBMChan 128+            <*> newTBMChan 128+            <*> (if ignore then return Nothing else Just <$> newTBMChan 128)+            <*> newTVar (IdInt 0)+            <*> newTVar M.empty+            <*> return v+            <*> newTVar False++-- Conduit to encode JSON to ByteString.+encodeConduit :: (ToJSON j, MonadLogger m) => ConduitT j ByteString m ()+encodeConduit = CL.mapM $ \m -> return . L8.toStrict $ encode 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 = evalStateT loop Nothing where+    loop = lift await >>= maybe flush (process False)+    flush = get >>= maybe (return ()) (handl True . ($ B8.empty))+    process b = runParser >=> handl b+    runParser ck = maybe (parse json ck) ($ ck) <$> get <* put Nothing++    handl True (Fail "" _ _) =+        $(logDebug) "ignoring null string at end of incoming data"+    handl b (Fail i _ _) = do+        $(logError) "error parsing incoming message"+        lift . yield . Left $ OrphanError ver (errorParse i)+        unless b loop+    handl _ (Partial k) = put (Just k) >> loop+    handl b (Done rest v) = do+        lift $ yield $ Right v+        if B8.null rest+           then unless b loop+           else process b 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 =+    ask >>= \qs ->+        join . liftIO . atomically $+        readTBMChan (inCh qs) >>= \case+            Nothing -> flush qs+            Just vE ->+                case vE of+                    Right v@Object {} -> do+                        single qs v+                        return $ do+                            $(logDebug) "received message"+                            processIncoming+                    Right v@(Array a) -> do+                        if V.null a+                            then do+                                let e = OrphanError (rpcVer qs) (errorInvalid v)+                                writeTBMChan (outCh qs) $ MsgResponse e+                            else batch qs (V.toList a)+                        return $ do+                            $(logDebug) "received batch"+                            processIncoming+                    Right v -> do+                        let e = OrphanError (rpcVer qs) (errorInvalid v)+                        writeTBMChan (outCh qs) $ MsgResponse e+                        return $ do+                            $(logWarn) "got invalid message"+                            processIncoming+                    Left e -> do+                        writeTBMChan (outCh qs) $ MsgResponse e+                        return $ do+                            $(logWarn) "error parsing JSON"+                            processIncoming+  where+    flush qs = do+        m <- readTVar $ sentReqs qs+        F.forM_ (reqCh qs) closeTBMChan+        closeTBMChan $ outCh qs+        writeTVar (dead qs) True+        mapM_ ((`putTMVar` Nothing) . snd) $ M.toList m+        return $ do+            $(logDebug) "session is now dead"+            unless (M.null m) $ $(logError) "requests remained unfulfilled"+    batch qs vs = do+        ts <- catMaybes <$> forM vs (process qs)+        unless (null ts) $+            if any isRight ts+                then do+                    let ch = fromJust $ reqCh qs+                    writeTBMChan ch $ BatchRequest $ rights ts+                else writeTBMChan (outCh qs) $ MsgBatch $ lefts ts+    single qs v = do+        tM <- process qs v+        case tM of+            Nothing -> return ()+            Just (Right t) -> do+                let ch = fromJust $ reqCh qs+                writeTBMChan ch $ SingleRequest t+            Just (Left e) -> writeTBMChan (outCh qs) e+    process qs v = do+        let qM = parseMaybe parseJSON v+        case qM of+            Just q -> request qs q+            Nothing -> do+                let rM = parseMaybe parseJSON v+                case rM of+                    Just r -> response qs r >> return Nothing+                    Nothing -> do+                        let e = OrphanError (rpcVer qs) (errorInvalid v)+                            m = MsgResponse e+                        return $ Just $ Left m+    request qs t =+        case reqCh qs of+            Just _ -> return $ Just $ Right t+            Nothing ->+                case t of+                    Notif {} -> return Nothing+                    Request {} -> do+                        let e = errorMethod (getReqMethod t)+                            v = getReqVer t+                            i = getReqId t+                            m = MsgResponse $ ResponseError v e i+                        return $ Just $ Left m+    response qs r = do+        let hasid =+                case r of+                    Response {} -> True+                    ResponseError {} -> True+                    OrphanError {} -> False -- Ignore orphan errors+        when hasid $ do+            let x = getResId r+            m <- readTVar (sentReqs qs)+            case x `M.lookup` m of+                Nothing -> return () -- Ignore orphan responses+                Just p -> do+                    writeTVar (sentReqs qs) $ M.delete x m+                    putTMVar p $ Just 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 = head `liftM` sendBatchRequest [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 qs = do+    v <- reader rpcVer+    l <- reader lastId+    s <- reader sentReqs+    o <- reader outCh+    k <- reader dead+    aps <- liftIO . atomically $ do+        d <- readTVar k+        aps <- forM qs $ \q ->+            if requestIsNotif q+                then return (buildRequest v q undefined, Nothing)+                else do+                    p <- newEmptyTMVar+                    i <- succ <$> readTVar l+                    m <- readTVar s+                    unless d $ writeTVar s $ M.insert i p m+                    unless d $ writeTVar l i+                    if d+                        then return (buildRequest v q i, Nothing)+                        else return (buildRequest v q i, Just p)+        case map fst aps of+            []  -> return ()+            [a] -> unless d $ writeTBMChan o $ MsgRequest a+            as  -> unless d $ writeTBMChan o $ MsgBatch $ map MsgRequest as+        return aps+    if null aps+        then $(logDebug) "no responses pending"+        else $(logDebug) "listening for responses if pending"+    liftIO . atomically $ forM aps $ \(a, pM) ->+        case pM of+            Nothing -> return Nothing+            Just  p -> do+                rM <- takeTMVar p+                case rM of+                    Nothing -> return Nothing+                    Just r@Response{} ->+                        case fromResponse (getReqMethod a) r of+                            Nothing -> return Nothing+                            Just  x -> return $ Just $ Right x+                    Just e -> return $ Just $ Left $ getError 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 = do+    bt <- receiveBatchRequest+    case bt of+        Nothing -> return Nothing+        Just (SingleRequest q) -> return $ Just q+        Just BatchRequest{} -> do+            v <- reader rpcVer+            let e = errorInvalid $ String "not accepting batches"+                m = OrphanError v e+            sendResponse m+            return Nothing++-- | Receive batch of requests. Will also accept single requests.+receiveBatchRequest :: MonadLoggerIO m => JSONRPCT m (Maybe BatchRequest)+receiveBatchRequest = do+    chM <- reader reqCh+    case chM of+        Just ch -> do+            $(logDebug) "listening for a new request"+            liftIO . atomically $ readTBMChan ch+        Nothing -> do+            $(logError) "ignoring requests from remote endpoint"+            return Nothing++-- | Send response message. Do not use to respond to a batch of requests.+sendResponse :: MonadLoggerIO m => Response -> JSONRPCT m ()+sendResponse r = do+    o <- reader outCh+    liftIO . atomically . writeTBMChan o $ MsgResponse r++-- | Send batch of responses. Use to respond to a batch of requests.+sendBatchResponse :: MonadLoggerIO m => BatchResponse -> JSONRPCT m ()+sendBatchResponse (BatchResponse rs) = do+    o <- reader outCh+    liftIO . atomically . writeTBMChan o $ MsgBatch $ map MsgResponse rs+sendBatchResponse (SingleResponse r) = do+    o <- reader outCh+    liftIO . atomically . writeTBMChan o $ MsgResponse 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 msg = reader outCh >>= liftIO . atomically . (`writeTBMChan` 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 ignore snk src f = do+    qs <- liftIO . atomically $ initSession ver ignore+    let inSnk  = sinkTBMChan (inCh qs)+        outSrc = sourceTBMChan (outCh qs)+    withAsync (runConduit $ src .| decodeConduit ver .| inSnk) $ const $+        withAsync (runConduit $ outSrc .| encodeConduit .| snk) $ \o ->+            withAsync (runReaderT processIncoming qs) $ const $ do+                a <- runReaderT f qs+                liftIO $ do+                    atomically . closeTBMChan $ outCh qs+                    _ <- wait o+                    return a+++cr :: Monad m => ConduitT ByteString ByteString m ()+cr = CL.map (`B8.snoc` '\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 ignore cs f = runGeneralTCPClient cs $ \ad ->+    runJSONRPCT ver ignore (cr .| appSink ad) (appSource ad) 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 ignore ss f = runGeneralTCPServer ss $ \cl ->+    runJSONRPCT ver ignore (cr .| appSink cl) (appSource cl) f

@@ -1,532 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Rank2Types #-}-module Network.JsonRpc.Tests (tests) where--import Control.Applicative-import Control.Arrow-import Control.Concurrent.Async.Lifted-import Control.Concurrent.STM-import Control.Monad-import Control.Monad.Logger-import Control.Monad.Trans-import Control.Monad.Reader-import Data.Aeson-import Data.Aeson.Types-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.Conduit.TMChan-import qualified Data.Foldable as F-import Data.Function-import Data.List-import Data.Either-import qualified Data.HashMap.Strict as M-import Data.Maybe-import Data.Word-import System.IO-import Network.JsonRpc-import Test.QuickCheck-import Test.QuickCheck.Monadic-import Test.Framework-import Test.Framework.Providers.QuickCheck2--tests :: [Test]-tests =-    [ testGroup "Messages"-        [ testProperty "Check request fields"-            (reqFields :: Request -> Bool)-        , testProperty "Encode/decode request"-            (testEncodeDecode :: Request -> Bool)-        , testProperty "Check response fields"-            (resFields :: Response -> Bool)-        , testProperty "Encode/decode response"-            (testEncodeDecode :: Response -> Bool)-        , testProperty "Encode/decode message"-            (testEncodeDecode :: Message -> Bool)-        ]-    , testGroup "Conduits"-        [ testProperty "Encoding" testEncodeConduit-        , testProperty "Decoding" testDecodeConduit-        , testProperty "Decode Garbage" testDecodeGarbageConduit-        ]-    , testGroup "Functions"-        [ testProperty "Processing incoming messages" testProcessIncoming-        , testProperty "Processing incoming responses" testIncomingResponse-        , testProperty "Receiving incoming requests" testReceiveRequest-        , testProperty "Receiving incoming batch requests"-            testReceiveBatchRequest-        , testProperty "Sending responses" testSendResponse-        , testProperty "Sending batch responses" testSendBatchResponse-        , testProperty "Sending request batch" testSendBatchRequest-        ]-    , testGroup "Network"-        [ testProperty "Client/server talk" clientTest-        , testProperty "Notifications" notifTest-        ]-    ]--data ReqList = ReqList { getReqList :: [Req] } deriving (Show, Eq)--instance Arbitrary ReqList where-    arbitrary = resize 3 $ ReqList <$> arbitrary--data Req = Req { getReq :: Request } deriving (Show, Eq)--instance Arbitrary Req where-    arbitrary = do-        rq <- Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-        return $ Req rq--data ReqNot = ReqNotReq { getReqNotParams :: Value }-            | ReqNotNot { getReqNotParams :: Value }-            deriving (Show, Eq)--instance ToJSON ReqNot where-    toJSON = toJSON . getReqNotParams--instance Arbitrary ReqNot where-    arbitrary = oneof [ ReqNotReq <$> arbitrary , ReqNotNot <$> arbitrary ]--instance ToRequest ReqNot where-    requestMethod ReqNotReq{} = "request"-    requestMethod ReqNotNot{} = "notification"-    requestIsNotif ReqNotReq{} = False-    requestIsNotif ReqNotNot{} = True--data Struct = Struct Value deriving (Show, Eq)--instance Arbitrary Struct where-    arbitrary = resize 10 $ Struct <$> oneof [lsn, objn] where-        nonull = oneof-            [ toJSON <$> (arbitrary :: Gen String)-            , toJSON <$> (arbitrary :: Gen Int)-            , toJSON <$> (arbitrary :: Gen Double)-            , toJSON <$> (arbitrary :: Gen Bool)-            ]-        val = oneof [ nonull, return Null ]-        ls   = toJSON <$> listOf val-        obj  = toJSON . M.fromList <$> listOf ps-        ps   = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls]-        lsn  = toJSON <$> listOf (oneof [ls, obj, val])-        objn = toJSON . M.fromList <$> listOf psn-        psn  = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls, obj]--reqFields :: Request -> Bool-reqFields rq = testFields (checkFieldsReq rq) rq--resFields :: Response -> Bool-resFields rs = testFields (checkFieldsRes rs) rs--fromRight :: Either a b -> b-fromRight (Right x) = x-fromRight _ = undefined--checkVerId :: Ver -> Maybe Id -> Object -> Parser Bool-checkVerId ver i o = do-    j <- o .:? "jsonrpc"-    guard $ if ver == V2 then j == Just (String "2.0") else isNothing j-    o .:? "id" >>= guard . (==i)-    return True--checkFieldsReqNotif-    :: Ver -> Method -> Value -> Maybe Id -> Object -> Parser Bool-checkFieldsReqNotif ver m v i o = do-    checkVerId ver i o >>= guard-    o .: "method" >>= guard . (==m)-    o .: "params" >>= guard . (==v)-    return True--checkFieldsReq :: Request -> Object -> Parser Bool-checkFieldsReq (Request ver m v i) = checkFieldsReqNotif ver m v (Just i)-checkFieldsReq (Notif   ver m v)   = checkFieldsReqNotif ver m v Nothing--checkFieldsRes :: Response -> Object -> Parser Bool-checkFieldsRes (Response ver v i) o = do-    checkVerId ver (Just i) o >>= guard-    o .: "result" >>= guard . (==v)-    return True-checkFieldsRes (ResponseError ver e i) o = do-    checkVerId ver (Just i) o >>= guard-    o .: "error" >>= guard . (==e)-    return True-checkFieldsRes (OrphanError ver e) o = do-    checkVerId ver Nothing o >>= guard-    o .: "error" >>= guard . (==e)-    return True--testFields :: ToJSON r => (Object -> Parser Bool) -> r -> Bool-testFields ck r = fromMaybe False . parseMaybe f $ toJSON r where-    f = withObject "json" ck--testEncodeDecode :: (Eq r, ToJSON r, FromJSON r) => r -> Bool-testEncodeDecode r = maybe False (==r) $ parseMaybe parseJSON (toJSON r)--testEncodeConduit :: [Message] -> Property-testEncodeConduit msgs = monadicIO $ do-    rt <- run $ runNoLoggingT $ do-        bs <- CL.sourceList msgs =$ encodeConduit $$ CL.consume-        return $ map decodeStrict' bs-    assert $ msgs == map fromJust rt--testDecodeConduit :: ([Message], Ver) -> Property-testDecodeConduit (msgs, ver) = monadicIO $ do-    rt <- run $ runNoLoggingT $-        CL.sourceList (buffer encoded) =$ decodeConduit ver $$ CL.consume-    assert $ rt == map (Right . toJSON) msgs-  where-    encoded = B.concat $ map (L.toStrict . encode) msgs-    buffer bs | B.null bs = []-              | otherwise = B.take 16 bs : buffer (B.drop 16 bs)--testDecodeGarbageConduit :: ([[Word8]], Ver) -> Property-testDecodeGarbageConduit (ss, ver) = monadicIO $ do-    _ <- run $ runNoLoggingT $-        CL.sourceList bss =$ decodeConduit ver $$ CL.consume-    -- Just getting here without crashing is enough-    assert True-  where-    bss = map B.pack ss--testProcessIncoming :: ([Either Response Message], Ver, Bool)-                    -> Property-testProcessIncoming (msgs, ver, ignore) = monadicIO $ do-    rt <- run $ runNoLoggingT $ do-        expect <- liftIO . atomically $ newTMChan-        qs <- liftIO . atomically $ initSession ver ignore-        withAsync (cli qs expect msgs) $ \c -> do-            runReaderT processIncoming qs-            wait c-        validate expect True-    assert rt-  where-    validate expect state = do-        newM <- liftIO . atomically $ readTMChan expect-        case newM of-            Just new -> validate expect $ new && state-            Nothing  -> return state-    cli qs expect [] = liftIO . atomically $ do-        closeTMChan expect-        closeTBMChan $ inCh qs-    cli qs expect (x:xs) = do-        liftIO . atomically $ writeTBMChan (inCh qs) (toJSON <$> x)-        liftIO . atomically $ case x of-            Left e ->-                caseLeftResponse qs e >>= writeTMChan expect-            Right (MsgRequest req@Request{}) ->-                caseSingleRequest req qs >>= writeTMChan expect-            Right (MsgRequest nt@Notif{}) ->-                caseSingleNotif nt qs >>= writeTMChan expect-            Right MsgResponse{} ->-                writeTMChan expect True-            Right (MsgBatch []) ->-                caseEmptyBatch qs >>= writeTMChan expect-            Right (MsgBatch ms) ->-                caseBatch qs ms >>= writeTMChan expect-        cli qs expect xs-    caseLeftResponse qs e = do-        m <- readTBMChan $ outCh qs-        case m of-            Just (MsgResponse err) -> return $ err == e-            _ -> return False-    caseEmptyBatch qs = do-        m <- readTBMChan $ outCh qs-        case m of-            Just (MsgResponse (OrphanError v (ErrorObj _ i _))) ->-                return $ v == rpcVer qs && i == (-32600)-            _ -> return False-    caseBatch qs ms = do-        let isrq (MsgRequest Request{}) = True-            isrq _ = False-            isnotif (MsgRequest Notif{}) = True-            isnotif _ = False-        if any isrq ms-            then-                if ignore-                    then do-                        m <- readTBMChan $ outCh qs-                        case m of-                            Just MsgBatch{} -> return True-                            _ -> return False-                    else do-                        m <- readTBMChan $ fromJust $ reqCh qs-                        case m of-                            Just BatchRequest{} -> return True-                            _ -> return False-            else-                if any isnotif ms-                    then-                        if ignore-                            then return True-                            else do-                                m <- readTBMChan $ fromJust $ reqCh qs-                                case m of-                                    Just BatchRequest{} -> return True-                                    _ -> return False-                    else return True-    caseSingleRequest req qs =-        if ignore-            then do-                m <- readTBMChan $ outCh qs-                case m of-                    Just (MsgResponse (ResponseError _ e@ErrorObj{} _)) ->-                        return $ getErrCode e == (-32601)-                    _ -> return False-            else do-                m <- readTBMChan (fromJust $ reqCh qs)-                return $ m == Just (SingleRequest req)-    caseSingleNotif nt qs =-        if ignore-            then return True-            else do-                m <- readTBMChan (fromJust $ reqCh qs)-                return $ m == Just (SingleRequest nt)--testIncomingResponse :: ([ReqList], Ver, Bool) -> Property-testIncomingResponse (reqss', ver, ignore) = nodup ==> monadicIO $ do-    rt <- run $ runNoLoggingT $ do-        expect <- liftIO . atomically $ newTMChan-        qs <- liftIO . atomically $ do-            qs <- initSession ver ignore-            s <- sent-            writeTVar (sentReqs qs) s-            return qs-        withAsync (cli qs expect msgs) $ \c -> do-            runReaderT processIncoming qs-            wait c-        valid <- validate expect responses True-        mapempty <- liftIO . atomically $ M.null <$> readTVar (sentReqs qs)-        return $ valid && mapempty-    assert rt-  where-    reqss = map getReqList reqss'-    reqs = let f [q] = SingleRequest (getReq q)-               f qs  = BatchRequest (map getReq qs)-           in map f reqss-    flatreqs = let f (BatchRequest bt) = bt-                   f (SingleRequest rt) = [rt]-               in concatMap f reqs-    nodup = length (nubBy ((==) `on` getReqId) flatreqs) == length flatreqs-    respond (Request v _ p i) = Response v p i-    respond _ = undefined-    responses = map respond flatreqs-    msgs = map MsgResponse responses-    sent = do-        promises <- forM flatreqs $-            \Request{getReqId = i} -> (,) i <$> newEmptyTMVar-        return $ M.fromList promises-    validate _ [] state = return state-    validate expect (x:xs) state = do-        newM <- liftIO . atomically $ readTMChan expect-        case newM of-            Just new -> validate expect xs (new == x && state)-            Nothing  -> return state-    cli qs expect [] = liftIO . atomically $ do-        closeTMChan expect-        closeTBMChan $ inCh qs-    cli qs expect (x:xs) =-        case x of-            MsgResponse res -> do-                p <- getpromise qs res-                liftIO . atomically $ writeTBMChan (inCh qs) (Right $ toJSON x)-                liftIO . atomically $ do-                    rE <- readTMVar p-                    F.forM_ rE $ writeTMChan expect-                cli qs expect xs-            MsgBatch resps -> do-                ps <- mapM (getpromise qs . getMsgResponse) resps-                liftIO . atomically $ writeTBMChan (inCh qs) (Right $ toJSON x)-                forM_ ps $ \p -> liftIO . atomically $ do-                    rE <- readTMVar p-                    F.forM_ rE $ writeTMChan expect-            _ -> undefined-    getpromise qs res = do-        let i = getResId res-        liftIO . atomically $ do-            snt <- readTVar (sentReqs qs)-            return . fromJust $ M.lookup i snt--testSendBatchRequest :: ([(ReqNot, Either ErrorObj Value)], Ver, Bool)-                     -> Property-testSendBatchRequest (reqnotres, ver, ignore) = nonull ==> monadicIO $ do-    rs <- run $ runNoLoggingT $ do-        qs <- liftIO . atomically $ initSession ver ignore-        withAsync (cli qs) $ \c -> do-            rs <- runReaderT (sendBatchRequest $ map fst reqnotres) qs-            wait c-            return (rs :: [Maybe (Either ErrorObj Value)])-    assert $ length rs == length reqnotres-  where-    nonull = not $ null reqnotres-    resmap = M.fromList $ map (first toJSON) reqnotres-    respond (Request v _ _ i) (Left  y) = Just $ ResponseError v y i-    respond (Request v _ _ i) (Right y) = Just $ Response      v y i-    respond _ _ = undefined-    fulfill req sent = F.forM_ (getReqId req `M.lookup` sent) $ \p ->-        putTMVar p $ respond req $ fromJust $ getReqParams req `M.lookup` resmap-    cli qs = liftIO . atomically $ do-        msg <- readTBMChan (outCh qs)-        sent <- readTVar (sentReqs qs)-        case msg of-            Just (MsgRequest req@Request{}) -> fulfill req sent-            Just (MsgBatch bt) ->-                forM_ bt $ \m ->-                    case m of-                        MsgRequest req@Request{} -> fulfill req sent-                        _ -> return ()-            _ -> return ()--testReceiveRequest :: ([BatchRequest], Ver, Bool) -> Property-testReceiveRequest (reqs, ver, ignore) = monadicIO $ do-    rt <- run $ runNoLoggingT $ do-        qs <- liftIO . atomically $ initSession ver ignore-        withAsync (send qs) $ \c -> do-            res <- runReaderT receive qs-            wait c-            return res-    assert $ and rt-  where-    send qs = F.forM_ (reqCh qs) $ \qch -> do-        forM_ reqs $ liftIO . atomically . writeTBMChan qch-        liftIO . atomically $ closeTBMChan qch-    receive = forM reqs $ \q -> do-        t <- receiveRequest-        if ignore-            then return $ isNothing t-            else-                case q of-                    SingleRequest{} ->-                        return $ Just q == fmap SingleRequest t-                    BatchRequest{} -> do-                        ch <- reader outCh-                        m <- liftIO . atomically $ readTBMChan ch-                        case m of-                            Just (MsgResponse OrphanError{}) -> -                                return $ isNothing t-                            _ -> return $ isNothing t---testReceiveBatchRequest :: ([BatchRequest], Ver, Bool) -> Property-testReceiveBatchRequest (reqs, ver, ignore) = monadicIO $ do-    rt <- run $ runNoLoggingT $ do-        qs <- liftIO . atomically $ initSession ver ignore-        withAsync (send qs) $ \c -> do-            rt <- runReaderT receive qs-            wait c-            return rt-    if ignore-        then assert $ all isNothing rt-        else assert $ all isJust rt && map fromJust rt == reqs-  where-    send qs = F.forM_ (reqCh qs) $ \qch -> do-        forM_ reqs $ liftIO . atomically . writeTBMChan qch-        liftIO . atomically $ closeTBMChan qch-    receive = forM reqs $ const receiveBatchRequest--testSendResponse :: ([Response], Ver, Bool) -> Property-testSendResponse (responses, ver, ignore) = monadicIO $ do-    ex <- run $ runNoLoggingT $ do-        qs <- liftIO . atomically $ initSession ver ignore-        withAsync (receive qs) $ \c -> do-            runReaderT send qs-            wait c-    assert $ length ex == length responses-    assert $ all isJust ex && map fromJust ex == map MsgResponse responses-  where-    send = forM_ responses sendResponse-    receive qs = forM responses $ const $ liftIO . atomically $-        readTBMChan (outCh qs)--testSendBatchResponse :: ([BatchResponse], Ver, Bool) -> Property-testSendBatchResponse (responses, ver, ignore) = monadicIO $ do-    ex <- run $ runNoLoggingT $ do-        qs <- liftIO . atomically $ initSession ver ignore-        withAsync (receive qs) $ \c -> do-            runReaderT send qs-            wait c-    assert $ length ex == length responses-    assert $ all isJust ex && map fromJust ex == map msg responses-  where-    msg (BatchResponse bt) = MsgBatch $ map MsgResponse bt-    msg (SingleResponse r) = MsgResponse r-    send = forM_ responses sendBatchResponse-    receive qs = forM responses $ const $ liftIO . atomically $-        readTBMChan (outCh qs)--createChans :: MonadIO m-            => m ((TBMChan a, TBMChan b), (Sink a m (), Source m b))-createChans = do-    (bso, bsi) <- liftIO . atomically $ (,) <$> newTBMChan 16 <*> newTBMChan 16-    let (snk, src) = (sinkTBMChan bso False, sourceTBMChan bsi)-    return ((bso, bsi), (snk, src))--clientTest :: ([Value], Ver) -> Property-clientTest (qs, ver) = monadicIO $ do-    rt <- run $ runNoLoggingT $ do-        ((bso, bsi), (snk, src)) <- createChans-        let csnk = sinkTBMChan bsi False :: Sink B.ByteString (NoLoggingT IO) ()-            csrc = sourceTBMChan bso :: Source (NoLoggingT IO) B.ByteString-        withAsync (server snk src) $ const $ cli csnk csrc-    assert $ length rt == length qs-    assert $ null rt || all correct rt-    assert $ qs == results rt-  where-    respond q = return $ Right (q :: Value)-    server snk src = runJsonRpcT ver False snk src (srv respond)-    cli snk src = runJsonRpcT ver True snk src . forM qs $ sendRequest-    results = map $ fromRight . fromJust-    correct (Just (Right _)) = True-    correct _ = False--notifTest :: ([Request], Ver) -> Property-notifTest (qs, ver) = monadicIO $ do-    nt <- run $ runNoLoggingT $ do-        ((bso, bsi), (snk, src)) <- createChans-        let csnk = sinkTBMChan bsi False-            csrc = sourceTBMChan bso-        (sig, notifs) <- liftIO . atomically $-            (,) <$> newEmptyTMVar <*> newTVar []-        withAsync (server snk src sig notifs) $ const $ cli sig csnk csrc-        liftIO . atomically $ readTVar notifs-    assert $ length nt == length ntfs-    assert $ reverse nt == ntfs-  where-    respond q = return $ Right (q :: Value)-    server snk src sig notifs =-        runJsonRpcT ver False snk src (process sig notifs)-    process sig notifs = do-        qM <- receiveRequest-        case qM of-            Nothing -> return ()-            Just q -> do-                case q of-                    Notif{} -> liftIO . atomically $-                        readTVar notifs >>= writeTVar notifs . (q:)-                    Request{ getReqParams = String "disconnect" } ->-                        liftIO . atomically $ putTMVar sig ()-                    Request{} -> return ()-                rM <- buildResponse respond q-                case rM of-                    Nothing -> process sig notifs-                    Just  r -> sendResponse r >> process sig notifs-    reqs = map MsgRequest qs-    cli sig snk src = runJsonRpcT ver True snk src $ do-        forM_ reqs sendMessage-        _ <- sendRequest $ String "disconnect"-            :: JsonRpcT (NoLoggingT IO) (Maybe (Either ErrorObj Value))-        liftIO . atomically $ takeTMVar sig-    ntfs = flip filter qs $ \q -> case q of Notif{} -> True; _ -> False--srv :: (MonadLoggerIO m, FromRequest q, ToJSON r)-    => Respond q (JsonRpcT m) r -> JsonRpcT m ()-srv respond = do-    qM <- receiveRequest-    case qM of-        Nothing -> return ()-        Just q -> do-            rM <- buildResponse respond q-            case rM of-                Nothing -> srv respond-                Just r -> sendResponse r >> srv respond

@@ -0,0 +1,558 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}+import           Control.Arrow+import           Control.Monad+import           Control.Monad.Logger+import           Control.Monad.Reader+import           Data.Aeson+import           Data.Aeson.Types+import qualified Data.ByteString         as B+import qualified Data.ByteString.Lazy    as L+import           Data.Conduit+import qualified Data.Conduit.List       as CL+import           Data.Conduit.TMChan+import qualified Data.Foldable           as F+import           Data.Function+import qualified Data.HashMap.Strict     as M+import           Data.List+import           Data.Maybe+import           Data.Word+import           Network.JSONRPC+import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck+import           Test.QuickCheck.Monadic+import           UnliftIO                hiding (assert)++main :: IO ()+main = hspec $ do+    describe "encoder/decoder" $ do+        prop "checks request fields" (reqFields :: Request -> Bool)+        prop "encodes and decodes requests" (testEncodeDecode :: Request -> Bool)+        prop "checks response fields" (resFields :: Response -> Bool)+        prop "encodes and decodes responses" (testEncodeDecode :: Response -> Bool)+        prop "encodes and decodes messages" (testEncodeDecode :: Message -> Bool)+    describe "conduits" $ do+        prop "encodes messages" testEncodeConduit+        prop "decodes messages" testDecodeConduit+        prop "tries to decode garbage" testDecodeGarbageConduit+    describe "processor" $ do+        prop "processes incoming messages" testProcessIncoming+        prop "processes incoming responses" testIncomingResponse+        prop "receives incoming requests" testReceiveRequest+        prop "receives incoming batch requests" testReceiveBatchRequest+        prop "sends responses" testSendResponse+        prop "sends batch responses" testSendBatchResponse+        prop "sends request batch" testSendBatchRequest+    describe "network client and server" $ do+        prop "communicates" clientTest+        prop "sends and receives notifications" notifTest++newtype ReqList = ReqList { getReqList :: [Req] } deriving (Show, Eq)++instance Arbitrary ReqList where+    arbitrary = resize 3 $ ReqList <$> arbitrary++newtype Req = Req { getReq :: Request } deriving (Show, Eq)++instance Arbitrary Req where+    arbitrary = do+        rq <- Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+        return $ Req rq++data ReqNot = ReqNotReq { getReqNotParams :: Value }+            | ReqNotNot { getReqNotParams :: Value }+            deriving (Show, Eq)++instance ToJSON ReqNot where+    toJSON = toJSON . getReqNotParams++instance Arbitrary ReqNot where+    arbitrary = oneof [ ReqNotReq <$> arbitrary , ReqNotNot <$> arbitrary ]++instance ToRequest ReqNot where+    requestMethod ReqNotReq{} = "request"+    requestMethod ReqNotNot{} = "notification"+    requestIsNotif ReqNotReq{} = False+    requestIsNotif ReqNotNot{} = True++newtype Struct = Struct Value deriving (Show, Eq)++instance Arbitrary Struct where+    arbitrary = resize 10 $ Struct <$> oneof [lsn, objn] where+        nonull = oneof+            [ toJSON <$> (arbitrary :: Gen String)+            , toJSON <$> (arbitrary :: Gen Int)+            , toJSON <$> (arbitrary :: Gen Double)+            , toJSON <$> (arbitrary :: Gen Bool)+            ]+        val = oneof [ nonull, return Null ]+        ls   = toJSON <$> listOf val+        obj  = toJSON . M.fromList <$> listOf ps+        ps   = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls]+        lsn  = toJSON <$> listOf (oneof [ls, obj, val])+        objn = toJSON . M.fromList <$> listOf psn+        psn  = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls, obj]++reqFields :: Request -> Bool+reqFields rq = testFields (checkFieldsReq rq) rq++resFields :: Response -> Bool+resFields rs = testFields (checkFieldsRes rs) rs++checkVerId :: Ver -> Maybe Id -> Object -> Parser Bool+checkVerId ver i o = do+    j <- o .:? "jsonrpc"+    guard $ if ver == V2 then j == Just (String "2.0") else isNothing j+    o .:? "id" >>= guard . (==i)+    return True++checkFieldsReqNotif+    :: Ver -> Method -> Value -> Maybe Id -> Object -> Parser Bool+checkFieldsReqNotif ver m v i o = do+    checkVerId ver i o >>= guard+    o .: "method" >>= guard . (==m)+    o .: "params" >>= guard . (==v)+    return True++checkFieldsReq :: Request -> Object -> Parser Bool+checkFieldsReq (Request ver m v i) = checkFieldsReqNotif ver m v (Just i)+checkFieldsReq (Notif   ver m v)   = checkFieldsReqNotif ver m v Nothing++checkFieldsRes :: Response -> Object -> Parser Bool+checkFieldsRes (Response ver v i) o = do+    checkVerId ver (Just i) o >>= guard+    o .: "result" >>= guard . (==v)+    return True+checkFieldsRes (ResponseError ver e i) o = do+    checkVerId ver (Just i) o >>= guard+    o .: "error" >>= guard . (==e)+    return True+checkFieldsRes (OrphanError ver e) o = do+    checkVerId ver Nothing o >>= guard+    o .: "error" >>= guard . (==e)+    return True++testFields :: ToJSON r => (Object -> Parser Bool) -> r -> Bool+testFields ck r = fromMaybe False . parseMaybe f $ toJSON r where+    f = withObject "json" ck++testEncodeDecode :: (Eq r, ToJSON r, FromJSON r) => r -> Bool+testEncodeDecode r = (== Just r) $ parseMaybe parseJSON (toJSON r)++testEncodeConduit :: [Message] -> Property+testEncodeConduit msgs =+    monadicIO $ do+        rt <-+            run . runNoLoggingT $ do+                bs <-+                    runConduit $+                    CL.sourceList msgs .| encodeConduit .| CL.consume+                return $ map decodeStrict' bs+        assert $ msgs == map fromJust rt++testDecodeConduit :: ([Message], Ver) -> Property+testDecodeConduit (msgs, ver) =+    monadicIO $ do+        rt <-+            run . runNoLoggingT . runConduit $+            CL.sourceList (buffer encoded) .| decodeConduit ver .| CL.consume+        assert $ rt == map (Right . toJSON) msgs+  where+    encoded = B.concat $ map (L.toStrict . encode) msgs+    buffer bs+        | B.null bs = []+        | otherwise = B.take 16 bs : buffer (B.drop 16 bs)++testDecodeGarbageConduit :: ([[Word8]], Ver) -> Property+testDecodeGarbageConduit (ss, ver) =+    monadicIO $ do+        _ <-+            run . runNoLoggingT . runConduit $+            CL.sourceList bss .| decodeConduit ver .| CL.consume+    -- Just getting here without crashing is enough+        assert True+  where+    bss = map B.pack ss++testProcessIncoming :: ([Either Response Message], Ver, Bool)+                    -> Property+testProcessIncoming (msgs, ver, ignore) = monadicIO $ do+    rt <- run $ runNoLoggingT $ do+        expect <- liftIO . atomically $ newTMChan+        qs <- liftIO . atomically $ initSession ver ignore+        withAsync (cli qs expect msgs) $ \c -> do+            runReaderT processIncoming qs+            wait c+        validate expect True+    assert rt+  where+    validate expect state = do+        newM <- liftIO . atomically $ readTMChan expect+        case newM of+            Just new -> validate expect $ new && state+            Nothing  -> return state+    cli qs expect [] = liftIO . atomically $ do+        closeTMChan expect+        closeTBMChan $ inCh qs+    cli qs expect (x:xs) = do+        liftIO . atomically $ writeTBMChan (inCh qs) (toJSON <$> x)+        liftIO . atomically $ case x of+            Left e ->+                caseLeftResponse qs e >>= writeTMChan expect+            Right (MsgRequest req@Request{}) ->+                caseSingleRequest req qs >>= writeTMChan expect+            Right (MsgRequest nt@Notif{}) ->+                caseSingleNotif nt qs >>= writeTMChan expect+            Right MsgResponse{} ->+                writeTMChan expect True+            Right (MsgBatch []) ->+                caseEmptyBatch qs >>= writeTMChan expect+            Right (MsgBatch ms) ->+                caseBatch qs ms >>= writeTMChan expect+        cli qs expect xs+    caseLeftResponse qs e = do+        m <- readTBMChan $ outCh qs+        case m of+            Just (MsgResponse err) -> return $ err == e+            _                      -> return False+    caseEmptyBatch qs = do+        m <- readTBMChan $ outCh qs+        case m of+            Just (MsgResponse (OrphanError v (ErrorObj _ i _))) ->+                return $ v == rpcVer qs && i == (-32600)+            _ -> return False+    caseBatch qs ms = do+        let isrq (MsgRequest Request{}) = True+            isrq _                      = False+            isnotif (MsgRequest Notif{}) = True+            isnotif _                    = False+        if any isrq ms+            then+                if ignore+                    then do+                        m <- readTBMChan $ outCh qs+                        case m of+                            Just MsgBatch{} -> return True+                            _               -> return False+                    else do+                        m <- readTBMChan $ fromJust $ reqCh qs+                        case m of+                            Just BatchRequest{} -> return True+                            _                   -> return False+            else+                if any isnotif ms+                    then+                        if ignore+                            then return True+                            else do+                                m <- readTBMChan $ fromJust $ reqCh qs+                                case m of+                                    Just BatchRequest{} -> return True+                                    _                   -> return False+                    else return True+    caseSingleRequest req qs =+        if ignore+            then do+                m <- readTBMChan $ outCh qs+                case m of+                    Just (MsgResponse (ResponseError _ e@ErrorObj{} _)) ->+                        return $ getErrCode e == (-32601)+                    _ -> return False+            else do+                m <- readTBMChan (fromJust $ reqCh qs)+                return $ m == Just (SingleRequest req)+    caseSingleNotif nt qs =+        if ignore+            then return True+            else do+                m <- readTBMChan (fromJust $ reqCh qs)+                return $ m == Just (SingleRequest nt)++testIncomingResponse :: ([ReqList], Ver, Bool) -> Property+testIncomingResponse (reqss', ver, ignore) =+    nodup ==> monadicIO . run . runNoLoggingT $ do+        expect <- liftIO $ atomically newTMChan+        qs <-+            liftIO . atomically $ do+                qs <- initSession ver ignore+                s <- sent+                writeTVar (sentReqs qs) s+                return qs+        withAsync (cli qs expect msgs) $ \c -> do+            runReaderT processIncoming qs+            wait c+        valid <- validate expect responses+        unless valid (error "Could not validate expected responses")+        mapempty <- liftIO . atomically $ M.null <$> readTVar (sentReqs qs)+        unless mapempty (error "Sent requests still found in state")+  where+    reqss = map getReqList reqss'+    reqs =+        let f [q] = SingleRequest (getReq q)+            f qs = BatchRequest (map getReq qs)+        in map f reqss+    flatreqs =+        let f (BatchRequest bt) = bt+            f (SingleRequest rt) = [rt]+        in concatMap f reqs+    nodup = length (nubBy ((==) `on` getReqId) flatreqs) == length flatreqs+    respond (Request v _ p i) = Response v p i+    respond _ = undefined+    responses = map respond flatreqs+    msgs = map MsgResponse responses+    sent = do+        promises <-+            forM flatreqs $ \Request {getReqId = i} -> (,) i <$> newEmptyTMVar+        return $ M.fromList promises+    validate _ [] = return True+    validate expect (x:xs) =+        liftIO (atomically (readTMChan expect)) >>= \case+            Nothing -> return False+            Just new+                | new == x -> validate expect xs+                | otherwise -> return False+    cli qs expect [] =+        liftIO . atomically $ do+            closeTMChan expect+            closeTBMChan $ inCh qs+    cli qs expect (x:xs) =+        case x of+            MsgResponse res ->+                getpromise qs res >>= \case+                    Nothing -> error "Could not find promise"+                    Just p -> do+                        liftIO . atomically $+                            writeTBMChan (inCh qs) (Right $ toJSON x)+                        liftIO . atomically $ do+                            rE <- readTMVar p+                            F.forM_ rE $ writeTMChan expect+                        cli qs expect xs+            MsgBatch resps -> do+                ps <- catMaybes <$> mapM (getpromise qs . getMsgResponse) resps+                when+                    (length ps /= length resps)+                    (error "Could not find a promise for a batch response")+                liftIO . atomically $ writeTBMChan (inCh qs) (Right $ toJSON x)+                forM_ ps $ \p ->+                    liftIO . atomically $ do+                        rE <- readTMVar p+                        F.forM_ rE $ writeTMChan expect+            _ -> error "Unexpected response type"+    getpromise qs res =+        liftIO . atomically $ do+            let i = getResId res+            snt <- readTVar (sentReqs qs)+            return $ M.lookup i snt++testSendBatchRequest :: ([(ReqNot, Either ErrorObj Value)], Ver, Bool)+                     -> Property+testSendBatchRequest (reqnotres, ver, ignore) =+    nonull ==> monadicIO $ do+        rs <-+            run $+            runNoLoggingT $ do+                qs <- liftIO . atomically $ initSession ver ignore+                withAsync (cli qs) $ \c -> do+                    rs <- runReaderT (sendBatchRequest $ map fst reqnotres) qs+                    wait c+                    return (rs :: [Maybe (Either ErrorObj Value)])+        assert $ length rs == length reqnotres+  where+    nonull = not $ null reqnotres+    resmap = M.fromList $ map (first toJSON) reqnotres+    respond (Request v _ _ i) (Left y)  = Just $ ResponseError v y i+    respond (Request v _ _ i) (Right y) = Just $ Response v y i+    respond _ _                         = undefined+    fulfill req sent =+        F.forM_ (getReqId req `M.lookup` sent) $ \p ->+            putTMVar p $+            respond req $ fromJust $ getReqParams req `M.lookup` resmap+    cli qs =+        liftIO . atomically $ do+            msg <- readTBMChan (outCh qs)+            sent <- readTVar (sentReqs qs)+            case msg of+                Just (MsgRequest req@Request {}) -> fulfill req sent+                Just (MsgBatch bt) ->+                    forM_ bt $ \case+                        MsgRequest req@Request {} -> fulfill req sent+                        _ -> return ()+                _ -> return ()++testReceiveRequest :: ([BatchRequest], Ver, Bool) -> Property+testReceiveRequest (reqs, ver, ignore) =+    monadicIO $ do+        rt <-+            run . runNoLoggingT $ do+                qs <- liftIO . atomically $ initSession ver ignore+                withAsync (send qs) $ \c -> do+                    res <- runReaderT receive qs+                    wait c+                    return res+        assert $ and rt+  where+    send qs =+        F.forM_ (reqCh qs) $ \qch -> do+            forM_ reqs $ liftIO . atomically . writeTBMChan qch+            liftIO . atomically $ closeTBMChan qch+    receive =+        forM reqs $ \q -> do+            t <- receiveRequest+            if ignore+                then return $ isNothing t+                else case q of+                         SingleRequest {} ->+                             return $ Just q == fmap SingleRequest t+                         BatchRequest {} -> do+                             ch <- reader outCh+                             m <- liftIO . atomically $ readTBMChan ch+                             case m of+                                 Just (MsgResponse OrphanError {}) ->+                                     return $ isNothing t+                                 _ -> return $ isNothing t+++testReceiveBatchRequest :: ([BatchRequest], Ver, Bool) -> Property+testReceiveBatchRequest (reqs, ver, ignore) = monadicIO $ do+    rt <- run $ runNoLoggingT $ do+        qs <- liftIO . atomically $ initSession ver ignore+        withAsync (send qs) $ \c -> do+            rt <- runReaderT receive qs+            wait c+            return rt+    if ignore+        then assert $ all isNothing rt+        else assert $ all isJust rt && map fromJust rt == reqs+  where+    send qs = F.forM_ (reqCh qs) $ \qch -> do+        forM_ reqs $ liftIO . atomically . writeTBMChan qch+        liftIO . atomically $ closeTBMChan qch+    receive = forM reqs $ const receiveBatchRequest++testSendResponse :: ([Response], Ver, Bool) -> Property+testSendResponse (responses, ver, ignore) = monadicIO $ do+    ex <- run $ runNoLoggingT $ do+        qs <- liftIO . atomically $ initSession ver ignore+        withAsync (receive qs) $ \c -> do+            runReaderT send qs+            wait c+    assert $ length ex == length responses+    assert $ all isJust ex && map fromJust ex == map MsgResponse responses+  where+    send = forM_ responses sendResponse+    receive qs = forM responses $ const $ liftIO . atomically $+        readTBMChan (outCh qs)++testSendBatchResponse :: ([BatchResponse], Ver, Bool) -> Property+testSendBatchResponse (responses, ver, ignore) = monadicIO $ do+    ex <- run $ runNoLoggingT $ do+        qs <- liftIO . atomically $ initSession ver ignore+        withAsync (receive qs) $ \c -> do+            runReaderT send qs+            wait c+    assert $ length ex == length responses+    assert $ all isJust ex && map fromJust ex == map msg responses+  where+    msg (BatchResponse bt) = MsgBatch $ map MsgResponse bt+    msg (SingleResponse r) = MsgResponse r+    send = forM_ responses sendBatchResponse+    receive qs = forM responses $ const $ liftIO . atomically $+        readTBMChan (outCh qs)++createChans ::+       MonadIO m+    => m ((TBMChan a, TBMChan b), (ConduitT a Void m (), ConduitT () b m ()))+createChans = do+    (bso, bsi) <- liftIO . atomically $ (,) <$> newTBMChan 16 <*> newTBMChan 16+    let (snk, src) = (sinkTBMChan bso, sourceTBMChan bsi)+    return ((bso, bsi), (snk, src))++clientTest :: ([Value], Ver) -> Property+clientTest (qs, ver) =+    monadicIO $ do+        rt <-+            run $+            runNoLoggingT $ do+                ((bso, bsi), (snk, src)) <- createChans+                let csnk =+                        sinkTBMChan bsi :: ConduitT B.ByteString Void (NoLoggingT IO) ()+                    csrc =+                        sourceTBMChan bso :: ConduitT () B.ByteString (NoLoggingT IO) ()+                withAsync (server snk src) $ const $ cli csnk csrc+        assert $ length rt == length qs+        assert $ null rt || all correct rt+        assert $ qs == results rt+  where+    respond q = return $ Right (q :: Value)+    server snk src = runJSONRPCT ver False snk src (srv respond)+    cli snk src = runJSONRPCT ver True snk src . forM qs $ sendRequest+    results =+        map $ \case+            (Just (Right r)) -> r+            _ -> error "Bad result"+    correct (Just (Right _)) = True+    correct _                = False++notifTest :: ([Request], Ver) -> Property+notifTest (qs, ver) =+    monadicIO $ do+        nt <-+            run $+            runNoLoggingT $ do+                ((bso, bsi), (snk, src)) <- createChans+                let csnk = sinkTBMChan bsi+                    csrc = sourceTBMChan bso+                (sig, notifs) <-+                    liftIO . atomically $ (,) <$> newEmptyTMVar <*> newTVar []+                withAsync (server snk src sig notifs) $+                    const $ cli sig csnk csrc+                liftIO . atomically $ readTVar notifs+        assert $ length nt == length ntfs+        assert $ reverse nt == ntfs+  where+    respond q = return $ Right (q :: Value)+    server snk src sig notifs =+        runJSONRPCT ver False snk src (process sig notifs)+    process sig notifs = do+        qM <- receiveRequest+        case qM of+            Nothing -> return ()+            Just q -> do+                case q of+                    Notif {} ->+                        liftIO . atomically $+                        readTVar notifs >>= writeTVar notifs . (q :)+                    Request {getReqParams = String "disconnect"} ->+                        liftIO . atomically $ putTMVar sig ()+                    Request {} -> return ()+                rM <- buildResponse respond q+                case rM of+                    Nothing -> process sig notifs+                    Just r  -> sendResponse r >> process sig notifs+    reqs = map MsgRequest qs+    cli sig snk src =+        runJSONRPCT ver True snk src $ do+            forM_ reqs sendMessage+            _ <-+                sendRequest $ String "disconnect" :: JSONRPCT (NoLoggingT IO) (Maybe (Either ErrorObj Value))+            liftIO . atomically $ takeTMVar sig+    ntfs =+        flip filter qs $ \case+            Notif {} -> True+            _ -> False++srv :: (MonadLoggerIO m, FromRequest q, ToJSON r)+    => Respond q (JSONRPCT m) r -> JSONRPCT m ()+srv respond = do+    qM <- receiveRequest+    case qM of+        Nothing -> return ()+        Just q -> do+            rM <- buildResponse respond q+            case rM of+                Nothing -> srv respond+                Just r  -> sendResponse r >> srv respond

@@ -1,6 +0,0 @@-import Test.Framework-import Network.JsonRpc.Tests--main :: IO ()-main = defaultMain tests-