json-rpc 0.2.1.6 → 1.1.2
raw patch · 20 files changed
Files
- CHANGELOG.md +53/−0
- LICENSE +19/−0
- Network/JsonRpc.hs +0/−136
- Network/JsonRpc/Conduit.hs +0/−304
- Network/JsonRpc/Data.hs +0/−377
- README.md +10/−115
- UNLICENSE +0/−24
- 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 +173/−69
- src/Network/JSONRPC.hs +23/−0
- src/Network/JSONRPC/Arbitrary.hs +65/−0
- src/Network/JSONRPC/Data.hs +413/−0
- src/Network/JSONRPC/Interface.hs +366/−0
- test/Network/JsonRpc/Arbitrary.hs +0/−81
- test/Network/JsonRpc/Tests.hs +0/−425
- test/Spec.hs +558/−0
- test/main.hs +0/−6
+ CHANGELOG.md view
@@ -0,0 +1,53 @@+# Changelog+All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)+and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html).++## 1.1.2 - 2025-05-09++### Fixed+- Correct Arbitraty instance for errors.++## 1.1.1 - 2023-03-14++### Fixed+- Close TBMChan when the session is closed++## 1.1.0 - 2023-12-29++### Changed+- Update dependency to Aeson 2.2.++## 1.0.4 - 2022-05-15++### Fixed+- Remove `Arbitrary Value` instance because it is already provided by the `aeson` package.++### Changed+- Relax restrictions on `params` field for JSON-RPCv1 requests.+- Bump minimum version of `aeson` accordingly.++## 1.0.3 - 2020-06-19++### Changed+- `LogSource` (defined in `monad-logger`) for this library is set to `"json-rpc"` so that logs can be filtered base on it.++## 1.0.2 - 2020-06-12+### Changed+- Change license to MIT.++## 1.0.1 - 2019-01-01+### Fixed+- Correct JSON-RPC 2.0 methods returning null result.++## 1.0.0 - 2018-08-12+### Added+- Complete JSON-RPC 1.0 and 2.0 support.+- Ability to use either endpoint to send and receive requests, responses or notifications.+- Simple TCP client/server implementation available.+- Example files.+- Exhaustive test suite.+- Compatibility with GHC 8.4.+- Support semantic versioning.+- Add a changelog.
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright 2020 Haskoin Developers++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+
− Network/JsonRpc.hs
@@ -1,136 +0,0 @@-module Network.JsonRpc-( -- * Introduction- -- $introduction-- -- ** Server Example- -- $server-- -- ** Client Example- -- $client-- module Network.JsonRpc.Conduit-, module Network.JsonRpc.Data-) where--import Network.JsonRpc.Conduit-import Network.JsonRpc.Data---- $introduction------ This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and--- partially-compatible with JSON-RPC 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.------ The recommended interface to this library is provided as conduits that--- encode outgoing messages, and decode incoming messages. Incoming messages--- are delivered as an 'IncomingMsg' data structure, while outgoing messages--- are sent in a 'Message' data structure. The former packs responses and--- errors with their corresponding request, and has a separate constructor for--- decoding errors.------ 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.------ Type classes 'ToRequest', 'ToNotif' are for data that can be converted into--- JSON-RPC requests and notifications respectively. An instance of aeson's--- 'ToJSON' class is also required to serialize these data structures. Make--- sure that they serialize as a structured JSON value (array or object) that--- can go into the params field of the JSON-RPC object. Type classes--- 'FromRequest', 'FromNotif' and 'FromResult' are for deserializing JSON-RPC--- messages.------ Errors are deserialized to the 'ErrorObj' data type. Only a string is--- supported as contents inside a JSON-RPC 1.0 error. JSON-RPC 2.0 errors also--- have a code, and possibly additional data as an aeson 'Value'.----- $server------ This server returns the current time.------ >{-# LANGUAGE OverloadedStrings #-}--- >import Data.Aeson.Types--- >import Data.Conduit--- >import qualified Data.Conduit.List as CL--- >import Data.Conduit.Network--- >import Data.Time.Clock--- >import Data.Time.Format--- >import Network.JsonRpc--- >import System.Locale--- >--- >data TimeReq = TimeReq--- >data TimeRes = TimeRes UTCTime--- >--- >instance FromRequest TimeReq where--- > paramsParser "time" = Just $ const $ return TimeReq --- > paramsParser _ = Nothing--- >--- >instance ToJSON TimeRes where--- > toJSON (TimeRes t) = toJSON $ formatTime defaultTimeLocale "%c" t--- >--- >srv :: AppConduits () () TimeRes TimeReq () () IO -> IO ()--- >srv (src, snk) = src $= CL.mapM respond $$ snk--- >--- >respond :: IncomingMsg () TimeReq () ()--- > -> IO (Message () () TimeRes)--- >respond (IncomingMsg (MsgRequest (Request ver _ TimeReq i)) Nothing) = do --- > t <- getCurrentTime--- > return $ MsgResponse (Response ver (TimeRes t) i)--- >--- >respond (IncomingError e) = return $ MsgError e--- >respond (IncomingMsg (MsgError e) _) = return $ MsgError $ e--- >respond _ = undefined--- >--- >main :: IO ()--- >main = tcpServer V2 (serverSettings 31337 "127.0.0.1") srv----- $client------ Corresponding TCP client to get time from server.------ >{-# LANGUAGE OverloadedStrings #-}--- >import Data.Aeson.Types hiding (Error)--- >import Data.Conduit--- >import qualified Data.Conduit.List as CL--- >import Data.Conduit.Network--- >import qualified Data.Text as T--- >import Data.Time.Clock--- >import Data.Time.Format--- >import Network.JsonRpc--- >import System.Locale--- >--- >data TimeReq = TimeReq--- >data TimeRes = TimeRes UTCTime--- >--- >instance ToRequest TimeReq where--- > requestMethod TimeReq = "time"--- >--- >instance ToJSON TimeReq where--- > toJSON TimeReq = emptyArray--- >--- >instance FromResponse TimeRes where--- > parseResult "time" = withText "time" $ \t -> case f t of--- > Nothing -> fail "Could not parse time"--- > Just t' -> return $ TimeRes t'--- > where--- > f t = parseTime defaultTimeLocale "%c" (T.unpack t)--- >--- >cli :: AppConduits TimeReq () () () () TimeRes IO--- > -> IO UTCTime--- >cli (src, snk) = do--- > CL.sourceList [MsgRequest $ buildRequest V2 TimeReq] $$ snk--- > ts <- src $$ CL.consume--- > case ts of--- > [] -> error "No response received"--- > [IncomingError (ErrorObj _ m _ _ _)] -> error $ "Unknown: " ++ m--- > [IncomingMsg (MsgError (ErrorObj _ m _ _ _)) _] -> error m--- > [IncomingMsg (MsgResponse (Response _ (TimeRes t) _)) _] -> return t--- > _ -> undefined--- >--- >main :: IO ()--- >main = tcpClient V2 True (clientSettings 31337 "127.0.0.1") cli >>= print
− Network/JsonRpc/Conduit.hs
@@ -1,304 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Conduit Interface for JSON-RPC.-module Network.JsonRpc.Conduit-( -- * Conduits- -- ** High-Level- AppConduits-, IncomingMsg(..)-, runConduits-, tcpClient-, tcpServer-, query- -- ** Low-Level-, Session(..)-, SentRequests-, initSession-, encodeConduit-, msgConduit-, decodeConduit-) where--import Control.Applicative-import Control.Concurrent.Async-import Control.Concurrent.STM-import Control.DeepSeq-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Trans.State-import Data.Aeson-import Data.Aeson.Types (parseEither)-import Data.Attoparsec.ByteString-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.Conduit.Network-import Data.Conduit.TMChan-import Data.Maybe-import Data.Text (Text)-import Network.JsonRpc.Data---- | Conduits for sending and receiving JSON-RPC messages.-type AppConduits qo no ro qi ni ri m =- (Source m (IncomingMsg qo qi ni ri), Sink (Message qo no ro) m ())---- | Map of ids to sent requests.-type SentRequests qo = HashMap Id (Request qo)---- | Incoming messages. Responses and corresponding requests go together.--- 'IncomingError' is for problems decoding incoming messages. These should be--- sent to the remote party.-data IncomingMsg qo qi ni ri- = IncomingMsg { incomingMsg :: !(Message qi ni ri)- , matchingReq :: !(Maybe (Request qo))- }- | IncomingError { incomingError :: !ErrorObj- }- deriving (Eq, Show)--instance (NFData qo, NFData qi, NFData ni, NFData ri)- => NFData (IncomingMsg qo qi ni ri)- where- rnf (IncomingMsg msg qr) = rnf msg `seq` rnf qr- rnf (IncomingError e) = rnf e---- | JSON-RPC session mutable data.-data Session qo = Session- { lastId :: TVar Id -- ^ Last generated id- , sentRequests :: TVar (SentRequests qo) -- ^ Map of ids to requests- , isLast :: TQueue Bool- -- ^ For each sent request, write a False, when sink closes, write a True- }---- | Initialize JSON-RPC session.-initSession :: STM (Session qo)-initSession = Session <$> newTVar (IdInt 0)- <*> newTVar M.empty- <*> newTQueue---- | Conduit that serializes JSON documents for sending to the network.-encodeConduit :: (ToJSON a, Monad m) => Conduit a m ByteString-encodeConduit = CL.map (L8.toStrict . encode)---- | Conduit for outgoing JSON-RPC messages.--- Adds an id to requests whose id is 'IdNull'.--- Tracks all sent requests to match corresponding responses.-msgConduit :: MonadIO m- => Bool- -- ^ Set to true if decodeConduit must disconnect on last response- -> Session qo- -> Conduit (Message qo no ro) m (Message qo no ro)-msgConduit c qs = await >>= \nqM -> case nqM of- Nothing ->- when c . liftIO . atomically $ writeTQueue (isLast qs) True- Just (MsgRequest rq) -> do- msg <- MsgRequest <$> liftIO (atomically $ addId rq)- yield msg >> msgConduit c qs- Just msg ->- yield msg >> msgConduit c qs- where- addId rq = case getReqId rq of- IdNull -> do- i <- readTVar (lastId qs)- h <- readTVar (sentRequests qs)- let i' = succ i- rq' = rq { getReqId = i' }- h' = M.insert i' rq' h- writeTVar (lastId qs) i'- writeTVar (sentRequests qs) h'- when c $ writeTQueue (isLast qs) False- return rq'- i -> do- h <- readTVar (sentRequests qs)- writeTVar (sentRequests qs) (M.insert i rq h)- when c $ writeTQueue (isLast qs) False- return rq---- | Conduit to decode incoming JSON-RPC messages. An error in the decoding--- operation will output an 'IncomingError', which should be relayed to the--- remote party.-decodeConduit- :: (FromRequest qi, FromNotif ni, FromResponse ri, MonadIO m)- => Ver -- ^ JSON-RPC version- -> Bool -- ^ Close on last response- -> Session qo -- ^ JSON-RPC session- -> Conduit ByteString m (IncomingMsg qo qi ni ri)- -- ^ Decoded incoming messages-decodeConduit ver c qs = evalStateT (f True) Nothing where- f re = if c && re- then do- l <- liftIO . atomically $ readTQueue (isLast qs)- unless l loop- else loop-- loop = lift await >>= maybe flush process-- process = runParser >=> handle-- flush = do- p <- get- case p of- Nothing -> return ()- Just k -> handle (k B.empty)-- runParser chunk = do- p <- getPartialParser- return $ case p of- Nothing -> parse json' chunk- Just k -> k chunk-- getPartialParser = get <* put Nothing-- handle (Fail {}) = lift (yield . IncomingError $ errorParse ver Null)- handle (Partial k) = put (Just k) >> loop- handle (Done rest v) = do- msg <- liftIO . atomically $ decodeSTM v- lift $ yield msg- if B.null rest- then f (re msg)- else process rest- where- re (IncomingMsg _ (Just _)) = True- re _ = False-- decodeSTM v = do- h <- readTVar (sentRequests qs)- case parseEither (topParse h) v of- Left _ -> return . IncomingError $ errorParse ver Null- Right x -> case x of- Right m@(MsgResponse rs) -> do- rq <- requestSTM h $ getResId rs- return $ IncomingMsg m (Just rq)- Right m@(MsgError re) -> case getErrId re of- IdNull ->- return $ IncomingMsg m Nothing- i -> do- rq <- requestSTM h i- return $ IncomingMsg m (Just rq)- Right m -> return $ IncomingMsg m Nothing- Left e -> return $ IncomingError e-- requestSTM h i = do- let rq = fromJust $ i `M.lookup` h- h' = M.delete i h- writeTVar (sentRequests qs) h'- return rq-- topParse h v = parseReq v- <|> parseNot v- <|> parseRes h v- <|> return (Left $ errorInvalid ver v)-- parseRes h = withObject "response" $ \o -> do- r <- o .:? "result" .!= Null- e <- o .:? "error" .!= Null- when (r == Null && e == Null) mzero- i <- o .:? "id" .!= IdNull- j <- o .:? "jsonrpc"- let ver' = if j == Just ("2.0" :: Text) then V2 else V1- case i of- IdNull ->- Right . MsgError <$> parseJSON (Object o)- _ -> case M.lookup i h of- Nothing -> return . Left $ errorId ver' i- Just rq -> do- rsE <- parseResponse rq (Object o)- return $ case rsE of- Left er -> Right $ MsgError er- Right rs -> Right $ MsgResponse rs-- parseReq v = flip fmap (parseRequest v) $ \rqE -> case rqE of- Left e -> Left e- Right rq -> Right $ MsgRequest rq-- parseNot v = flip fmap (parseNotif v) $ \rnE -> case rnE of- Left e -> Left e- Right rn -> Right $ MsgNotif rn---- | Send requests and get responses (or errors).------ Example:------ >tcpClient V2 True (clientSettings 31337 "127.0.0.1") (query V2 [TimeReq])-query :: (ToJSON qo, ToRequest qo, FromResponse ri)- => Ver -- ^ JSON-RPC version- -> [qo] -- ^ List of requests- -> AppConduits qo () () () () ri IO -- ^ Message conduits- -> IO [IncomingMsg qo () () ri] -- ^ Incoming messages-query ver qs (src, snk) = withAsync (src $$ CL.consume) $ \a -> do- link a- CL.sourceList qs $= CL.map (MsgRequest . buildRequest ver) $$ snk- wait a---- Will create JSON-RPC conduits around 'ByteString' conduits from a transport--- layer.-runConduits :: ( FromRequest qi, FromNotif ni, FromResponse ri- , ToJSON qo, ToJSON no, ToJSON ro )- => Ver -- ^ JSON-RPC version- -> Bool -- ^ Disconnect on last response- -> Sink ByteString IO () -- ^ Sink to send messages- -> Source IO ByteString -- ^ Source of incoming messages- -> (AppConduits qo no ro qi ni ri IO -> IO a)- -- ^ JSON-RPC action- -> IO a -- ^ Output of action-runConduits ver d rpcSnk rpcSrc f = do- (reqChan, msgChan) <- atomically $ (,) <$> newTBMChan 128- <*> newTBMChan 128- let inbSrc = sourceTBMChan msgChan- inbSnk = sinkTBMChan msgChan True- outSrc = sourceTBMChan reqChan- outSnk = sinkTBMChan reqChan True- withAsync (rpcThread outSrc inbSnk) (g inbSrc outSnk)- where- rpcThread outSrc inbSnk = do- qs <- atomically initSession- withAsync (outThread qs outSrc) $ \a -> do- link a- _ <- rpcSrc $= decodeConduit ver d qs $$ inbSnk- wait a- outThread qs outSrc = outSrc $= msgConduit d qs $= encodeConduit $$ rpcSnk- g inbSrc outSnk a = do- link a- x <- f (inbSrc, outSnk)- _ <- wait a- return x---- JSON-RPC-over-TCP client.-tcpClient :: ( FromRequest qi, FromNotif ni, FromResponse ri- , ToJSON qo, ToJSON no, ToJSON ro )- => Ver -- ^ JSON-RPC version- -> Bool -- ^ Disconnect on last response- -> ClientSettings -- ^ Connection settings- -> (AppConduits qo no ro qi ni ri IO -> IO a)- -- ^ JSON-RPC action- -> IO a -- ^ Output of action-tcpClient ver d cs f = runTCPClient cs $ \ad ->- runConduits ver d (cr =$ appSink ad) (appSource ad $= ln) f- where- cr = CL.map (`B8.snoc` '\n')- ln = await >>= \bsM -> case bsM of- Nothing -> return ()- Just bs -> let (l, ls) = B8.break (=='\n') bs in case ls of- "" -> await >>= \bsM' -> case bsM' of- Nothing -> if B8.null l then return () else yield l- Just bs' -> leftover (bs `B8.append` bs') >> ln- _ -> case l of- "" -> leftover (B8.tail ls) >> ln- _ -> leftover (B8.tail ls) >> yield l >> ln---- JSON-RPC-over-TCP server.-tcpServer :: ( FromRequest qi, FromNotif ni, FromResponse ri- , ToJSON qo, ToJSON no, ToJSON ro )- => Ver -- ^ JSON-RPC version- -> ServerSettings -- ^ Connection settings- -> (AppConduits qo no ro qi ni ri IO -> IO ())- -- ^ JSON-RPC action to perform on connecting client thread- -> IO ()-tcpServer ver ss f = runTCPServer ss $ \cl ->- runConduits ver False (cr =$ appSink cl) (appSource cl) f- where- cr = CL.map (`B8.snoc` '\n')
− Network/JsonRpc/Data.hs
@@ -1,377 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveGeneric #-}--- | Implementation of basic JSON-RPC data types.-module Network.JsonRpc.Data-( -- * Requests- Request(..)- -- ** Parsing-, FromRequest(..)-, parseRequest- -- ** Encoding-, ToRequest(..)-, buildRequest-- -- * Responses-, Response(..)- -- ** Parsing-, FromResponse(..)-, parseResponse-- -- * Notifications-, Notif(..)- -- ** Parsing-, FromNotif(..)-, parseNotif- -- ** Encoding-, ToNotif(..)-, buildNotif-- -- * Errors-, ErrorObj(..)- -- ** Error Messages-, errorParse-, errorInvalid-, errorParams-, errorMethod-, errorId-- -- * Others-, Message(..)-, Method-, Id(..)-, Ver(..)--) where--import Control.Applicative ((<$>), (<*>), (<|>))-import Control.DeepSeq (NFData, rnf)-import Control.Monad (when, guard, mzero)-import Data.Aeson.Types-import Data.Hashable (Hashable)-import Data.Text (Text)-import GHC.Generics (Generic)--------- Requests------- Request data type.-data Request q = Request { getReqVer :: !Ver -- Version- , getReqMethod :: !Method -- Method- , getReqParams :: !q -- Params- , getReqId :: !Id -- Id- } deriving (Eq, Show, Read)--instance NFData q => NFData (Request q) where- rnf (Request v m q i) = rnf v `seq` rnf m `seq` rnf q `seq` rnf i--instance ToJSON q => ToJSON (Request q) where- toJSON (Request V2 m p i) = object $ case toJSON p of- Null -> [jr2, "method" .= m, "id" .= i]- v -> [jr2, "method" .= m, "id" .= i, "params" .= v]- toJSON (Request V1 m p i) = object $ case toJSON p of- Null -> ["method" .= m, "params" .= emptyArray, "id" .= i]- v -> ["method" .= m, "params" .= v, "id" .= i]---- | Class for data that can be received in JSON-RPC requests.-class FromRequest q where- -- | Parser for params field.- paramsParser :: Method -> Maybe (Value -> Parser q)--instance FromRequest Value where- paramsParser _ = Just return--instance FromRequest () where- paramsParser _ = Nothing---- | Parse JSON-RPC request.-parseRequest :: FromRequest q => Value -> Parser (Either ErrorObj (Request q))-parseRequest = withObject "request" $ \o -> do- j <- o .:? "jsonrpc"- i <- o .: "id"- when (i == IdNull) $ fail "Request must have non-null id"- m <- o .: "method"- p <- o .:? "params" .!= Null- let ver = if j == Just ("2.0" :: Text) then V2 else V1- case paramsParser m of- Nothing -> return (Left (errorMethod ver m i))- Just x -> parseIt ver m i x p <|> return (Left (errorParams ver p i))- where- parseIt ver m i x p = (\y -> Right (Request ver m y i)) <$> x p---- | Class for data that can be sent as JSON-RPC requests.--- Define a method name for each request.-class ToRequest q where- requestMethod :: q -> Method--instance ToRequest Value where- requestMethod _ = ""--instance ToRequest () where- requestMethod _ = undefined---- Build JSON-RPC request.-buildRequest :: ToRequest q- => Ver -- ^ JSON-RPC version- -> q -- ^ Request data- -> Request q-buildRequest ver q = Request ver (requestMethod q) q IdNull--------- Responses------- | JSON-RPC response data type-data Response r = Response { getResVer :: !Ver -- ^ Version- , getResult :: !r -- ^ Result- , getResId :: !Id -- ^ Id- } deriving (Eq, Show, Read)--instance NFData r => NFData (Response r) where- rnf (Response v r i) = rnf v `seq` rnf r `seq` rnf i--instance ToJSON r => ToJSON (Response r) where- toJSON (Response V1 r i) = object- ["id" .= i, "result" .= r, "error" .= Null]- toJSON (Response V2 r i) = object- [jr2, "id" .= i, "result" .= r]---- | Class for data that can be received inside JSON-RPC responses.-class FromResponse r where- -- | Parse result field from JSON-RPC response.- parseResult :: Method -> Value -> Parser r--instance FromResponse Value where- parseResult _ = return--instance FromResponse () where- parseResult _ _ = return ()---- | Parse JSON-RPC response.-parseResponse :: FromResponse r- => Request q -> Value -> Parser (Either ErrorObj (Response r))-parseResponse rq = withObject "response" $ \o -> do- let m = getReqMethod rq- qi = getReqId rq- j <- o .:? "jsonrpc"- i <- o .: "id"- when (i == IdNull) $ fail "Response must have non-null id"- when (qi /= i) $ fail "Response id mismatch"- let ver = if j == Just ("2.0" :: Text) then V2 else V1- (Right <$> parseRes ver i m o) <|> (Left <$> parseJSON (Object o))- where- parseRes ver i m o = do- v <- o .: "result"- guard $ v /= Null- r <- parseResult m v- return $ Response ver r i--------- Notifications------- | Class for JSON-RPC notifications.-data Notif n = Notif { getNotifVer :: !Ver -- ^ Version- , getNotifMethod :: !Method -- ^ Method- , getNotifParams :: !n -- ^ Params- } deriving (Eq, Show, Read)--instance NFData n => NFData (Notif n) where- rnf (Notif v m n) = rnf v `seq` rnf m `seq` rnf n--instance ToJSON n => ToJSON (Notif n) where- toJSON (Notif V2 m p) = object $ case toJSON p of- Null -> [jr2, "method" .= m]- v -> [jr2, "method" .= m, "params" .= v]- toJSON (Notif V1 m p) = object $ case toJSON p of- Null -> ["method" .= m, "params" .= emptyArray, "id" .= Null]- v -> ["method" .= m, "params" .= v, "id" .= Null]---- | Class for data that can be received in JSON-RPC notifications.-class FromNotif n where- -- | Parser for notification params field- notifParamsParser :: Method -> Maybe (Value -> Parser n)--instance FromNotif Value where- notifParamsParser _ = Just return--instance FromNotif () where- notifParamsParser _ = Nothing---- | Parse notifications.-parseNotif :: FromNotif n => Value -> Parser (Either ErrorObj (Notif n))-parseNotif = withObject "notification" $ \o -> do- j <- o .:? "jsonrpc"- i <- o .:? "id" .!= IdNull- m <- o .: "method"- p <- o .:? "params" .!= Null- guard $ i == IdNull- let ver = if j == Just ("2.0" :: Text) then V2 else V1- case notifParamsParser m of- Nothing -> return (Left $ errorMethod ver m IdNull)- Just x -> f ver m x p <|> return (Left (errorParams ver p i))- where- f ver m x p = (Right . Notif ver m) <$> x p--class ToNotif n where- notifMethod :: n -> Method--instance ToNotif Value where- notifMethod _ = ""--instance ToNotif () where- notifMethod _ = undefined---- | Build notifications.-buildNotif :: ToNotif n- => Ver -- ^ Version- -> n -- ^ Notification data- -> Notif n-buildNotif ver n = Notif ver (notifMethod n) n--------- Errors------- | JSON-RPC errors.-data ErrorObj = ErrorObj { getErrVer :: !Ver -- ^ Version- , getErrMsg :: !String -- ^ Message- , getErrCode :: !Int -- ^ Error code (2.0)- , getErrData :: !Value -- ^ Error data (2.0)- , getErrId :: !Id -- ^ Error id- } deriving (Eq, Show)--instance NFData ErrorObj where- rnf (ErrorObj v m c d i) =- rnf v `seq` rnf m `seq` rnf c `seq` rnf d `seq` rnf i--instance FromJSON ErrorObj where- parseJSON = withObject "error" $ \o -> do- i <- o .:? "id" .!= IdNull- j <- o .:? "jsonrpc"- let ver = if j == Just ("2.0" :: Text) then V2 else V1- case ver of- V2 -> o .: "error" >>= \e -> case e of- (Object b) -> ErrorObj V2 <$> b .: "message"- <*> b .: "code"- <*> b .:? "data" .!= Null- <*> return i- _ -> fail "JSON-RPC 2.0 error must be a JSON object"- V1 -> (o .: "error" >>= \e -> return $ ErrorObj V1 e 0 Null i) <|>- (o .: "result" >>= \e -> return $ ErrorObj V1 e 0 Null i)- -- Buggy servers sometimes put errors in result field--instance ToJSON ErrorObj where- toJSON (ErrorObj V2 m c d i) = object [jr2, "id" .= i, "error" .= o] where- o = case d of- Null -> object ["code" .= c, "message" .= m]- _ -> object ["code" .= c, "message" .= m, "data" .= d]- toJSON (ErrorObj V1 m _ _ i) =- object ["id" .= i, "error" .= m, "result" .= Null]---- | Parse error.-errorParse :: Ver -> Value -> ErrorObj-errorParse ver v = ErrorObj ver "Parse error" (-32700) v IdNull---- | Invalid request.-errorInvalid :: Ver -> Value -> ErrorObj-errorInvalid ver v = ErrorObj ver "Invalid request" (-32600) v IdNull---- | Invalid params.-errorParams :: Ver -> Value -> Id -> ErrorObj-errorParams ver v = ErrorObj ver "Invalid params" (-32602) v---- | Method not found.-errorMethod :: Ver -> Method -> Id -> ErrorObj-errorMethod ver m = ErrorObj ver "Method not found" (-32601) (toJSON m)---- | Id not recognized.-errorId :: Ver -> Id -> ErrorObj-errorId ver i = ErrorObj ver "Id not recognized" (-32000) (toJSON i) IdNull--------- Messages------- | Class for any JSON-RPC message.-data Message q n r- = MsgRequest { getMsgRequest :: !(Request q) }- | MsgNotif { getMsgNotif :: !(Notif n) }- | MsgResponse { getMsgResponse :: !(Response r) }- | MsgError { getMsgError :: !ErrorObj }- deriving (Eq, Show)--instance (NFData q, NFData n, NFData r) => NFData (Message q n r) where- rnf (MsgRequest q) = rnf q- rnf (MsgNotif n) = rnf n- rnf (MsgResponse r) = rnf r- rnf (MsgError e) = rnf e--instance (ToJSON q, ToJSON n, ToJSON r) => ToJSON (Message q n r) where- toJSON (MsgRequest rq) = toJSON rq- toJSON (MsgNotif rn) = toJSON rn- toJSON (MsgResponse rs) = toJSON rs- toJSON (MsgError e) = toJSON e------- Types------- | JSON-RPC methods in requests and notifications.-type Method = Text---- | JSON-RPC message id.-data Id = IdInt { getIdInt :: !Int }- | IdTxt { getIdTxt :: !Text }- | IdNull- deriving (Eq, Show, Read, Generic)--instance Hashable Id--instance NFData Id where- rnf (IdInt i) = rnf i- rnf (IdTxt t) = rnf t- rnf _ = ()--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 Null = return IdNull- parseJSON _ = mzero--instance ToJSON Id where- toJSON (IdTxt s) = toJSON s- toJSON (IdInt n) = toJSON n- toJSON IdNull = Null---- | JSON-RPC version-data Ver = V1 -- ^ JSON-RPC 1.0- | V2 -- ^ JSON-RPC 2.0- deriving (Eq, Show, Read)--instance NFData Ver--------- Helpers-----jr2 :: Pair-jr2 = "jsonrpc" .= ("2.0" :: Text)-
README.md view
@@ -3,122 +3,17 @@ Fully-featured JSON-RPC 2.0 library for Haskell programs. -This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and-partially-compatible with JSON-RPC 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.--The recommended interface to this library is provided as conduits that encode-outgoing messages, and decode incoming messages. Incoming messages are-delivered as an IncomingMsg data structure, while outgoing messages are sent in-a Message data structure. The former packs responses and errors with their-corresponding request, and has a separate constructor for decoding errors.--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.--Type classes ToRequest, ToNotif are for data that can be converted into-JSON-RPC requests and notifications respectively. An instance of aeson's ToJSON-class is also required to serialize these data structures. Make sure that they-serialize as a structured JSON value (array or object) that can go into the-params field of the JSON-RPC object. Type classes FromRequest, FromNotif and-FromResult are for deserializing JSON-RPC messages.--Errors are deserialized to the ErrorObj data type. Only a string is supported-as contents inside a JSON-RPC 1.0 error. JSON-RPC 2.0 errors also have a code,-and possibly additional data as an aeson Value. ---Server Example-----------------This server returns the current time.--``` haskell-{-# LANGUAGE OverloadedStrings #-}-import Data.Aeson.Types-import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.Conduit.Network-import Data.Time.Clock-import Data.Time.Format-import Network.JsonRpc-import System.Locale--data TimeReq = TimeReq-data TimeRes = TimeRes UTCTime--instance FromRequest TimeReq where- paramsParser "time" = Just $ const $ return TimeReq - paramsParser _ = Nothing--instance ToJSON TimeRes where- toJSON (TimeRes t) = toJSON $ formatTime defaultTimeLocale "%c" t--srv :: AppConduits () () TimeRes TimeReq () () IO -> IO ()-srv (src, snk) = src $= CL.mapM respond $$ snk--respond :: IncomingMsg () TimeReq () ()- -> IO (Message () () TimeRes)-respond (IncomingMsg (MsgRequest (Request ver _ TimeReq i)) Nothing) = do - t <- getCurrentTime- return $ MsgResponse (Response ver (TimeRes t) i)--respond (IncomingError e) = return $ MsgError e-respond (IncomingMsg (MsgError e) _) = return $ MsgError $ e-respond _ = undefined--main :: IO ()-main = tcpServer V2 (serverSettings 31337 "127.0.0.1") srv-```--Client Example-----------------Corresponding TCP client to get time from server.--``` haskell-{-# LANGUAGE OverloadedStrings #-}-import Data.Aeson.Types hiding (Error)-import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.Conduit.Network-import qualified Data.Text as T-import Data.Time.Clock-import Data.Time.Format-import Network.JsonRpc-import System.Locale--data TimeReq = TimeReq-data TimeRes = TimeRes UTCTime--instance ToRequest TimeReq where- requestMethod TimeReq = "time"+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. -instance ToJSON TimeReq where- toJSON TimeReq = emptyArray+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. -instance FromResponse TimeRes where- parseResult "time" = withText "time" $ \t -> case f t of- Nothing -> fail "Could not parse time"- Just t' -> return $ TimeRes t'- where- f t = parseTime defaultTimeLocale "%c" (T.unpack t)+[Documentation](http://hackage.haskell.org/package/json-rpc) -cli :: AppConduits TimeReq () () () () TimeRes IO- -> IO UTCTime-cli (src, snk) = do- CL.sourceList [MsgRequest $ buildRequest V2 TimeReq] $$ snk- ts <- src $$ CL.consume- case ts of- [] -> error "No response received"- [IncomingError (ErrorObj _ m _ _ _)] -> error $ "Unknown: " ++ m- [IncomingMsg (MsgError (ErrorObj _ m _ _ _)) _] -> error m- [IncomingMsg (MsgResponse (Response _ (TimeRes t) _)) _] -> return t- _ -> undefined+[Examples](https://github.com/xenog/json-rpc/tree/master/examples) -main :: IO ()-main = tcpClient V2 True (clientSettings 31337 "127.0.0.1") cli >>= print-```
− UNLICENSE
@@ -1,24 +0,0 @@-This is free and unencumbered software released into the public domain.--Anyone is free to copy, modify, publish, use, compile, sell, or-distribute this software, either in source code form or as a compiled-binary, for any purpose, commercial or non-commercial, and by any-means.--In jurisdictions that recognize copyright laws, the author or authors-of this software dedicate any and all copyright interest in the-software to the public domain. We make this dedication for the benefit-of the public at large and to the detriment of our heirs and-successors. We intend this dedication to be an overt act of-relinquishment in perpetuity of all present and future rights to this-software under copyright law.--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.-IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR-OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,-ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR-OTHER DEALINGS IN THE SOFTWARE.--For more information, please refer to <http://unlicense.org>
+ examples/concurrent-client.hs view
@@ -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
+ examples/concurrent-server.hs view
@@ -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
+ examples/time-client.hs view
@@ -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
+ examples/time-server.hs view
@@ -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
json-rpc.cabal view
@@ -1,75 +1,179 @@-name: json-rpc-version: 0.2.1.6-synopsis: Fully-featured JSON-RPC 2.0 library-description:- This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and- partially-compatible with JSON-RPC 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+cabal-version: 1.12 -source-repository head- type: git- location: https://github.com/xenog/json-rpc.git+-- This file has been generated from package.yaml by hpack version 0.38.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: af79897f0e82fbeacd851e9b286216ab406df7508ea4e6c07e7ced0f24912c64 -source-repository this- type: git- location: https://github.com/xenog/json-rpc.git- tag: 0.2.1.5+name: json-rpc+version: 1.1.2+synopsis: Fully-featured JSON-RPC 2.0 library+description: Please see the README on GitHub at <https://github.com/jprupp/json-rpc#readme>+category: Network+homepage: https://github.com/jprupp/json-rpc.git#readme+bug-reports: https://github.com/jprupp/json-rpc.git/issues+author: JP Rupp+maintainer: jprupp@protonmail.ch+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md +source-repository head+ type: git+ location: https://github.com/jprupp/json-rpc.git+ library- exposed-modules: Network.JsonRpc- other-modules: Network.JsonRpc.Data,- Network.JsonRpc.Conduit- build-depends: base >= 4.6 && < 5,- aeson >= 0.7 && < 0.9,- attoparsec >= 0.11,- async >= 2.0 && < 2.1,- bytestring >= 0.10 && < 0.11,- conduit >= 1.2 && < 1.3,- conduit-extra >= 1.1 && < 1.2,- deepseq >= 1.3 && < 1.4,- hashable >= 1.1 && < 1.3,- mtl >= 2.1 && < 2.3,- stm >= 2.4 && < 2.5,- stm-conduit >= 2.5 && < 2.6,- text >= 0.11 && < 1.3,- transformers >= 0.3,- unordered-containers >= 0.2 && < 0.3- default-language: Haskell2010- ghc-options: -Wall+ exposed-modules:+ Network.JSONRPC+ other-modules:+ Network.JSONRPC.Arbitrary+ Network.JSONRPC.Data+ Network.JSONRPC.Interface+ Paths_json_rpc+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ QuickCheck+ , aeson+ , attoparsec+ , attoparsec-aeson+ , base >=4.6 && <5+ , bytestring+ , conduit+ , conduit-extra+ , deepseq+ , hashable+ , monad-logger+ , mtl+ , stm-conduit+ , text+ , time+ , unliftio+ , unordered-containers+ , vector+ default-language: Haskell2010 +executable concurrent-client+ main-is: examples/concurrent-client.hs+ other-modules:+ Paths_json_rpc+ build-depends:+ QuickCheck+ , aeson+ , attoparsec-aeson+ , base >=4.6 && <5+ , bytestring+ , conduit+ , conduit-extra+ , json-rpc+ , monad-logger+ , mtl+ , stm-conduit+ , text+ , time+ , unliftio+ , unordered-containers+ , vector+ default-language: Haskell2010++executable concurrent-server+ main-is: examples/concurrent-server.hs+ other-modules:+ Paths_json_rpc+ build-depends:+ QuickCheck+ , aeson+ , attoparsec-aeson+ , base >=4.6 && <5+ , bytestring+ , conduit+ , conduit-extra+ , json-rpc+ , monad-logger+ , mtl+ , stm-conduit+ , text+ , time+ , unliftio+ , unordered-containers+ , vector+ default-language: Haskell2010++executable time-client+ main-is: examples/time-client.hs+ other-modules:+ Paths_json_rpc+ build-depends:+ QuickCheck+ , aeson+ , attoparsec-aeson+ , base >=4.6 && <5+ , bytestring+ , conduit+ , conduit-extra+ , json-rpc+ , monad-logger+ , mtl+ , stm-conduit+ , text+ , time+ , unliftio+ , unordered-containers+ , vector+ default-language: Haskell2010++executable time-server+ main-is: examples/time-server.hs+ other-modules:+ Paths_json_rpc+ build-depends:+ QuickCheck+ , aeson+ , attoparsec-aeson+ , base >=4.6 && <5+ , bytestring+ , conduit+ , conduit-extra+ , json-rpc+ , monad-logger+ , mtl+ , stm-conduit+ , text+ , time+ , unliftio+ , unordered-containers+ , vector+ 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,- Network.JsonRpc.Arbitrary- build-depends: base >= 4.6 && < 5,- aeson >= 0.7 && < 0.9,- async >= 2.0 && < 2.1,- bytestring >= 0.10 && < 0.11,- conduit >= 1.2 && < 1.3,- conduit-extra >= 1.1 && < 1.2,- deepseq >= 1.3 && < 1.4,- hashable >= 1.1 && < 1.3,- json-rpc >= 0.2 && < 0.3,- mtl >= 2.1 && < 2.3,- stm >= 2.4 && < 2.5,- stm-conduit >= 2.5 && < 2.6,- text >= 0.11 && < 1.3,- unordered-containers >= 0.2 && < 0.3,- QuickCheck >= 2.6 && < 2.8,- test-framework >= 0.8 && < 0.9,- test-framework-quickcheck2 >= 0.3 && < 0.4- default-language: Haskell2010- ghc-options: -Wall+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_json_rpc+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , aeson+ , attoparsec-aeson+ , base >=4.6 && <5+ , bytestring+ , conduit+ , conduit-extra+ , hspec+ , json-rpc+ , monad-logger+ , mtl+ , stm-conduit+ , text+ , time+ , unliftio+ , unordered-containers+ , vector+ default-language: Haskell2010
+ src/Network/JSONRPC.hs view
@@ -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.
+ src/Network/JSONRPC/Arbitrary.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Network.JSONRPC.Arbitrary where++import Data.Aeson+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 <*> res <*> arbitrary+ , ResponseError <$> arbitrary <*> arbitrary <*> arbitrary+ , OrphanError <$> arbitrary <*> arbitrary+ ]+ where+ res = arbitrary `suchThat` (/= Null)+++instance Arbitrary ErrorObj where+ arbitrary = oneof+ [ ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary+ , ErrorVal <$> (arbitrary `suchThat` (/= Null))+ ]++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+
+ src/Network/JSONRPC/Data.hs view
@@ -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 ["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 ["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 parseEither parser p of+ Left e -> Left $ errorParams p e+ Right 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 <- case v of+ V1 -> if r == Null then Left <$> o .: "error" else return $ Right r+ V2 -> maybe (Right r) Left <$> o .:? "error"+ 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 -> String -> ErrorObj+errorParams v e = ErrorObj ("Invalid params: " ++ e) (-32602) v++-- | 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
+ src/Network/JSONRPC/Interface.hs view
@@ -0,0 +1,366 @@+{-# 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.Parser+import Data.Aeson.Types (parseMaybe)+import Data.Attoparsec.ByteString+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Conduit.Network+import Data.Conduit.TMChan+import Data.Either+import qualified Data.Foldable as F+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as M+import Data.Maybe+import qualified Data.Vector as V+import Network.JSONRPC.Data+import UnliftIO++type SentRequests = HashMap Id (TMVar (Maybe Response))++data Session = Session { 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 "" _ _) =+ $logDebugS "json-rpc" "ignoring null string at end of incoming data"+ handl b (Fail i _ _) = do+ $logErrorS "json-rpc" "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+ $logDebugS "json-rpc" "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+ $logDebugS "json-rpc" "received batch"+ processIncoming+ Right v -> do+ let e = OrphanError (rpcVer qs) (errorInvalid v)+ writeTBMChan (outCh qs) $ MsgResponse e+ return $ do+ $logWarnS "json-rpc" "got invalid message"+ processIncoming+ Left e -> do+ writeTBMChan (outCh qs) $ MsgResponse e+ return $ do+ $logWarnS "json-rpc" "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+ $logDebugS "json-rpc" "session is now dead"+ unless (M.null m) $ $logErrorS "json-rpc" "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 $logDebugS "json-rpc" "no responses pending"+ else $logDebugS "json-rpc" "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+ $logDebugS "json-rpc" "listening for a new request"+ liftIO . atomically $ readTBMChan ch+ Nothing -> do+ $logErrorS "json-rpc" "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) >> liftIO (atomically $ closeTBMChan $ inCh qs)) $ 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
− test/Network/JsonRpc/Arbitrary.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | Arbitrary instances and data types for use in test suites.-module Network.JsonRpc.Arbitrary-( -- * Arbitrary Data- ReqRes(..)-) where--import Control.Applicative-import Data.Aeson.Types hiding (Error)-import qualified Data.HashMap.Strict as M-import Data.Text (Text)-import qualified Data.Text as T-import Network.JsonRpc-import Test.QuickCheck.Arbitrary-import Test.QuickCheck.Gen---- | A pair of a request and its corresponding response.--- Id and version should match.-data ReqRes q r = ReqRes !(Request q) !(Response r)- deriving (Show, Eq)--instance Arbitrary (ReqRes Value Value) where- arbitrary = do- rq <- arbitrary- rs <- arbitrary- let rs' = rs { getResId = getReqId rq, getResVer = getReqVer rq }- return $ ReqRes rq rs'--instance Arbitrary Text where- arbitrary = T.pack <$> arbitrary--instance Arbitrary Ver where- arbitrary = elements [V1, V2]--instance (Arbitrary q, ToRequest q) => Arbitrary (Request q) where- arbitrary = do- q <- arbitrary- v <- arbitrary- let m = requestMethod q- Request v m q <$> arbitrary--instance (Arbitrary n, ToNotif n) => Arbitrary (Notif n) where- arbitrary = do- n <- arbitrary- v <- arbitrary- let m = notifMethod n- return $ Notif v m n--instance Arbitrary r => Arbitrary (Response r) where- arbitrary = Response <$> arbitrary <*> arbitrary <*> arbitrary--instance Arbitrary ErrorObj where- arbitrary = ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary- <*> arbitrary <*> arbitrary--instance ( Arbitrary q, Arbitrary n, Arbitrary r- , ToRequest q, ToNotif n, ToJSON r )- => Arbitrary (Message q n r)- where- arbitrary = oneof [ MsgRequest <$> arbitrary- , MsgNotif <$> arbitrary- , MsgResponse <$> arbitrary- , MsgError <$> arbitrary ]--instance Arbitrary Id where- arbitrary = oneof [IdInt <$> arbitrary, IdTxt <$> arbitrary]--instance Arbitrary Value where- arbitrary = resize 10 $ oneof [val, lsn, objn] where- val = oneof [ toJSON <$> (arbitrary :: Gen String)- , toJSON <$> (arbitrary :: Gen Int)- , toJSON <$> (arbitrary :: Gen Double)- , toJSON <$> (arbitrary :: Gen Bool) ]- 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]-
− test/Network/JsonRpc/Tests.hs
@@ -1,425 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Rank2Types #-}-module Network.JsonRpc.Tests (tests) where--import Control.Concurrent-import Control.Concurrent.Async-import Control.Concurrent.STM-import Control.Exception hiding (assert)-import Control.Monad-import Data.Aeson.Types-import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.List-import Data.Conduit.Network-import Data.Conduit.TMChan-import qualified Data.HashMap.Strict as M-import Data.Maybe-import Data.Text (Text)-import Network.JsonRpc-import Network.JsonRpc.Arbitrary-import Test.QuickCheck-import Test.QuickCheck.Monadic-import Test.Framework-import Test.Framework.Providers.QuickCheck2--tests :: [Test]-tests =- [ testGroup "JSON-RPC Requests"- [ testProperty "Check fields"- (reqFields :: Request Value -> Bool)- , testProperty "Encode/decode"- (reqDecode :: Request Value -> Bool)- ]- , testGroup "JSON-RPC Notifications"- [ testProperty "Check fields"- (notifFields :: Notif Value -> Bool)- , testProperty "Encode/decode"- (notifDecode :: Notif Value -> Bool)- ]- , testGroup "JSON-RPC Responses"- [ testProperty "Check fields"- (resFields :: Response Value -> Bool)- , testProperty "Encode/decode"- (resDecode :: ReqRes Value Value -> Bool)- , testProperty "Bad response id"- (rpcBadResId :: ReqRes Value Value -> Bool)- , testProperty "Error response"- (rpcErrRes :: (ReqRes Value Value, ErrorObj) -> Bool)- ]- , testGroup "JSON-RPC Conduits"- [ testProperty "Outgoing conduit"- (newMsgConduit :: [Message Value Value Value] -> Property)- , testProperty "Decode requests"- (decodeReqConduit :: ([Request Value], Ver) -> Property)- , testProperty "Decode responses"- (decodeResConduit :: ([ReqRes Value Value], Ver) -> Property)- , testProperty "Bad responses"- (decodeErrConduit :: ([ReqRes Value Value], Ver) -> Property)- , testProperty "Sending messages" sendMsgNet- , testProperty "Two-way communication" twoWayNet- , testProperty "Real network communication" realNet- ]- ]------- Requests-----reqFields :: (ToRequest a, ToJSON a) => Request a -> Bool-reqFields rq = case rq of- Request V1 m p i -> r1ks && vals m p i- Request V2 m p i -> r2ks && vals m p i- where- (Object o) = toJSON rq- r1ks = sort (M.keys o) == ["id", "method", "params"]- r2ks = sort (M.keys o) == ["id", "jsonrpc", "method", "params"]- || sort (M.keys o) == ["id", "jsonrpc", "method"]- vals m p i = fromMaybe False $ parseMaybe (f m p i) o- f m p i _ = do- j <- o .:? "jsonrpc"- guard $ maybe True (== ("2.0" :: Text)) j- i' <- o .: "id"- guard $ i == i'- m' <- o .: "method"- guard $ m == m'- p' <- o .:? "params" .!= Null- guard $ toJSON p == p'- return True--reqDecode :: (Eq a, ToRequest a, ToJSON a, FromRequest a) => Request a -> Bool-reqDecode rq = case parseMaybe parseRequest (toJSON rq) of- Nothing -> False- Just rqE -> either (const False) (rq ==) rqE------- Notifications-----notifFields :: (ToNotif a, ToJSON a) => Notif a -> Bool-notifFields rn = case rn of- Notif V1 m p -> n1ks && vals m p- Notif V2 m p -> n2ks && vals m p- where- (Object o) = toJSON rn- n1ks = sort (M.keys o) == ["id", "method", "params"]- n2ks = sort (M.keys o) == ["jsonrpc", "method", "params"]- || sort (M.keys o) == ["jsonrpc", "method"]- vals m p = fromMaybe False $ parseMaybe (f m p) o- f m p _ = do- i <- o .:? "id" .!= Null- guard $ i == Null- j <- o .:? "jsonrpc"- guard $ maybe True (== ("2.0" :: Text)) j- m' <- o .: "method"- guard $ m == m'- p' <- o .:? "params" .!= Null- guard $ toJSON p == p'- return True--notifDecode :: (Eq a, ToNotif a, ToJSON a, FromNotif a)- => Notif a -> Bool-notifDecode rn = case parseMaybe parseNotif (toJSON rn) of- Nothing -> False- Just rnE -> either (const False) (rn ==) rnE------- Responses-----resFields :: (Eq a, ToJSON a, FromJSON a) => Response a -> Bool-resFields rs = case rs of- Response V1 s i -> s1ks && vals s i- Response V2 s i -> s2ks && vals s i- where- (Object o) = toJSON rs- s1ks = sort (M.keys o) == ["error", "id", "result"]- s2ks = sort (M.keys o) == ["id", "jsonrpc", "result"]- vals s i = fromMaybe False $ parseMaybe (f s i) o- f s i _ = do- i' <- o .: "id"- guard $ i == i'- j <- o .:? "jsonrpc"- guard $ maybe True (== ("2.0" :: Text)) j- s' <- o .: "result"- guard $ s == s'- e <- o .:? "error" .!= Null- guard $ e == Null- return True--resDecode :: (Eq r, ToJSON r, FromResponse r)- => ReqRes q r -> Bool-resDecode (ReqRes rq rs) = case parseMaybe (parseResponse rq) (toJSON rs) of- Nothing -> False- Just rsE -> either (const False) (rs ==) rsE--rpcBadResId :: forall q r. (ToJSON r, FromResponse r)- => ReqRes q r -> Bool-rpcBadResId (ReqRes rq rs) = case parseMaybe f (toJSON rs') of- Nothing -> True- _ -> False- where- f :: FromResponse r => Value -> Parser (Either ErrorObj (Response r))- f = parseResponse rq- rs' = rs { getResId = IdNull }--rpcErrRes :: forall q r. FromResponse r => (ReqRes q r, ErrorObj) -> Bool-rpcErrRes (ReqRes rq _, re) = case parseMaybe f (toJSON re') of- Nothing -> False- Just (Left _) -> True- _ -> False- where- f :: FromResponse r => Value -> Parser (Either ErrorObj (Response r))- f = parseResponse rq- re' = re { getErrId = getReqId rq }------- Conduit-----newMsgConduit :: ( ToRequest q, ToJSON q, ToNotif n, ToJSON n- , ToJSON r, FromResponse r )- => [Message q n r] -> Property-newMsgConduit (snds) = monadicIO $ do- msgs <- run $ do- qs <- atomically initSession- CL.sourceList snds' $= msgConduit False qs $$ CL.consume- assert $ length msgs == length snds'- assert $ length (filter rqs msgs) == length (filter rqs snds')- assert $ map idn (filter rqs msgs) == take (length (filter rqs msgs)) [1..]- where- rqs (MsgRequest _) = True- rqs _ = False- idn (MsgRequest rq) = getIdInt $ getReqId rq- idn _ = error "Unexpected request"- snds' = flip map snds $ \m -> case m of- (MsgRequest rq) -> MsgRequest $ rq { getReqId = IdNull }- _ -> m--decodeReqConduit :: forall q. (ToRequest q, FromRequest q, Eq q, ToJSON q)- => ([Request q], Ver) -> Property-decodeReqConduit (vs, ver) = monadicIO $ do- inmsgs <- run $ do- qs <- atomically initSession- qs' <- atomically initSession- CL.sourceList vs- $= CL.map f- $= msgConduit False qs- $= encodeConduit- $= decodeConduit ver False qs'- $$ CL.consume- assert $ not (any unexpected inmsgs)- assert $ all (uncurry match) (zip vs inmsgs)- where- unexpected :: IncomingMsg () q () () -> Bool- unexpected (IncomingMsg (MsgRequest _) Nothing) = False- unexpected _ = True- match rq (IncomingMsg (MsgRequest rq') _) =- rq { getReqId = getReqId rq' } == rq'- match _ _ = False- f rq = MsgRequest $ rq { getReqId = IdNull } :: Message q () ()--decodeResConduit :: forall q r.- ( ToRequest q, FromRequest q, Eq q, ToJSON q, ToJSON r- , FromResponse r, Eq r )- => ([ReqRes q r], Ver) -> Property-decodeResConduit (rr, ver) = monadicIO $ do- inmsgs <- run $ do- qs <- atomically initSession- qs' <- atomically initSession- CL.sourceList vs- $= CL.map f- $= msgConduit False qs- $= encodeConduit- $= decodeConduit ver False qs'- $= CL.map respond- $= encodeConduit- $= decodeConduit ver False qs- $$ CL.consume- assert $ not (any unexpected inmsgs)- assert $ all (uncurry match) (zip vs inmsgs)- where- unexpected :: IncomingMsg q () () r -> Bool- unexpected (IncomingMsg (MsgResponse _) (Just _)) = False- unexpected _ = True-- match rq (IncomingMsg (MsgResponse rs) (Just rq')) =- rq { getReqId = getReqId rq' } == rq'- && rs == g rq'- match _ _ = False-- respond :: IncomingMsg () q () () -> Response r- respond (IncomingMsg (MsgRequest rq) Nothing) = g rq- respond _ = undefined-- f rq = MsgRequest $ rq { getReqId = IdNull } :: Message q () ()- vs = map (\(ReqRes rq _) -> rq) rr-- g rq = let (ReqRes _ rs) = fromJust $ find h rr- h (ReqRes rq' _) = getReqParams rq == getReqParams rq'- in rs { getResId = getReqId rq }--decodeErrConduit :: forall q r.- ( ToRequest q, FromRequest q, Eq q, ToJSON q, ToJSON r- , FromResponse r, Eq r, Show r, Show q )- => ([ReqRes q r], Ver) -> Property-decodeErrConduit (vs, ver) = monadicIO $ do- inmsgs <- run $ do- qs <- atomically initSession- qs' <- atomically initSession- CL.sourceList vs- $= CL.map f- $= msgConduit False qs- $= encodeConduit- $= decodeConduit ver False qs'- $= CL.map respond- $= encodeConduit- $= decodeConduit ver False qs- $$ CL.consume- assert $ not (any unexpected inmsgs)- assert $ all (uncurry match) (zip vs inmsgs)- where- unexpected :: IncomingMsg q () () r -> Bool- unexpected (IncomingMsg (MsgError _) (Just _)) = False- -- unexpected _ = True- unexpected i = error $ show i-- match (ReqRes rq _) (IncomingMsg (MsgError _) (Just rq')) =- rq' { getReqId = getReqId rq } == rq- match _ _ = False-- respond :: IncomingMsg () q () () -> ErrorObj- respond (IncomingMsg (MsgRequest (Request ver' _ _ i)) Nothing) =- ErrorObj ver' "test" (getIdInt i) Null i- respond _ = undefined-- f (ReqRes rq _) = MsgRequest $ rq { getReqId = IdNull } :: Message q () ()--type ClientAppConduits = AppConduits Value Value Value () () () IO-type ServerAppConduits = AppConduits () () () Value Value Value IO--sendMsgNet :: ([Message Value Value Value], Ver) -> Property-sendMsgNet (rs, ver) = monadicIO $ do- rt <- run $ do- mv <- newEmptyMVar- to <- atomically $ newTBMChan 128- ti <- atomically $ newTBMChan 128- let tiSink = sinkTBMChan ti True- toSource = sourceTBMChan to- toSink = sinkTBMChan to True- tiSource = sourceTBMChan ti- withAsync (srv tiSink toSource mv) $ \_ ->- runConduits ver False toSink tiSource (cliApp mv)- assert $ length rt == length rs- assert $ all (uncurry match) (zip rs rt)- where- srv tiSink toSource mv = runConduits ver False tiSink toSource (srvApp mv)-- srvApp :: MVar [IncomingMsg () Value Value Value]- -> ServerAppConduits -> IO ()- srvApp mv (src, snk) =- (CL.sourceNull $$ snk) >> (src $$ CL.consume) >>= putMVar mv-- cliApp :: MVar [IncomingMsg () Value Value Value]- -> ClientAppConduits -> IO [IncomingMsg () Value Value Value]- cliApp mv (src, snk) =- (CL.sourceList rs $$ snk) >> (src $$ CL.sinkNull) >> readMVar mv-- match (MsgRequest rq) (IncomingMsg (MsgRequest rq') Nothing) =- rq == rq'- match (MsgNotif rn) (IncomingMsg (MsgNotif rn') Nothing) =- rn == rn'- match (MsgResponse _) (IncomingError e) =- getErrMsg e == "Id not recognized"- match (MsgError e) (IncomingMsg (MsgError e') Nothing) =- getErrMsg e == getErrMsg e'- match (MsgError _) (IncomingError e) =- getErrMsg e == "Id not recognized"- match _ _ = False--type TwoWayAppConduits = AppConduits Value Value Value Value Value Value IO--twoWayNet :: ([Message Value Value Value], Ver) -> Property-twoWayNet (rr, ver) = monadicIO $ do- rt <- run $ do- to <- atomically $ newTBMChan 128- ti <- atomically $ newTBMChan 128- let tiSink = sinkTBMChan ti True- toSource = sourceTBMChan to- toSink = sinkTBMChan to True- tiSource = sourceTBMChan ti- withAsync (srv tiSink toSource) $ \_ ->- runConduits ver False toSink tiSource cliApp- assert $ length rt == length rs- assert $ all (uncurry match) (zip rs rt)- where- rs = map f rr where- f (MsgRequest rq) = MsgRequest $ rq { getReqId = IdNull }- f m = m-- cliApp :: TwoWayAppConduits -> IO [IncomingMsg Value Value Value Value]- cliApp (src, snk) = (CL.sourceList rs $$ snk) >> (src $$ CL.consume)-- srv tiSink toSource = runConduits ver False tiSink toSource srvApp-- srvApp :: TwoWayAppConduits -> IO ()- srvApp (src, snk) = src $= CL.map respond $$ snk-- respond (IncomingError e) =- MsgError e- respond (IncomingMsg (MsgRequest (Request ver' _ p i)) _) =- MsgResponse (Response ver' p i)- respond (IncomingMsg (MsgNotif rn) _) =- MsgNotif rn- respond (IncomingMsg (MsgError e) _) =- MsgNotif (Notif (getErrVer e) "error" (toJSON e))- respond _ = undefined-- match (MsgRequest (Request ver' m p _))- ( IncomingMsg (MsgResponse (Response ver'' p' _))- (Just (Request ver''' m' p'' _)) ) =- p == p' && p == p'' && m == m' && ver' == ver'' && ver'' == ver'''- match (MsgNotif (Notif ver' _ p))- (IncomingMsg (MsgNotif (Notif ver'' _ p')) Nothing) =- p == p' && ver' == ver''- match (MsgResponse (Response ver' _ _))- (IncomingMsg (MsgError e) Nothing) =- ver' == getErrVer e && getErrMsg e == "Id not recognized"- match (MsgError e@(ErrorObj _ _ _ _ IdNull))- (IncomingMsg (MsgNotif (Notif _ "error" e')) Nothing) =- toJSON e == e'- match (MsgError _)- (IncomingMsg (MsgError e) Nothing) =- getErrMsg e == "Id not recognized"- match _ _ = False--realNet :: ([Request Value], Ver) -> Property-realNet (rr, ver) = monadicIO $ do- rs <- run $ withAsync (tcpServer ver ss srvApp) $ const cli- assert $ length rs == length rr- assert $- map (getReqParams . fromJust . matchingReq) rs == map getReqParams rr- where- ss = serverSettings 58493 "127.0.0.1"- cs = clientSettings 58493 "127.0.0.1"-- cli = do- cE <- try $ tcpClient ver True cs cliApp- either (const cli) return- (cE :: Either SomeException [IncomingMsg Value () () Value])-- srvApp :: AppConduits () () Value Value () () IO -> IO ()- srvApp (src, snk) = src $= CL.map respond $$ snk-- cliApp :: AppConduits Value () () () () Value IO- -> IO [IncomingMsg Value () () Value]- cliApp (src, snk) = do- CL.sourceList (map f rr) $$ snk- src $$ CL.consume- where- f rq = MsgRequest (rq { getReqId = IdNull })-- respond (IncomingMsg (MsgRequest (Request ver' _ p i)) _) =- MsgResponse (Response ver' p i)- respond _ = undefined
+ test/Spec.hs view
@@ -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
− test/main.hs
@@ -1,6 +0,0 @@-import Test.Framework-import Network.JsonRpc.Tests--main :: IO ()-main = defaultMain (tests)-