diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Network/JsonRpc.hs b/Network/JsonRpc.hs deleted file mode 100644 --- a/Network/JsonRpc.hs +++ /dev/null @@ -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 diff --git a/Network/JsonRpc/Conduit.hs b/Network/JsonRpc/Conduit.hs deleted file mode 100644 --- a/Network/JsonRpc/Conduit.hs +++ /dev/null @@ -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') diff --git a/Network/JsonRpc/Data.hs b/Network/JsonRpc/Data.hs deleted file mode 100644 --- a/Network/JsonRpc/Data.hs +++ /dev/null @@ -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) - diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 -``` diff --git a/UNLICENSE b/UNLICENSE deleted file mode 100644 --- a/UNLICENSE +++ /dev/null @@ -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 diff --git a/examples/concurrent-client.hs b/examples/concurrent-client.hs new file mode 100644 --- /dev/null +++ b/examples/concurrent-client.hs @@ -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 diff --git a/examples/concurrent-server.hs b/examples/concurrent-server.hs new file mode 100644 --- /dev/null +++ b/examples/concurrent-server.hs @@ -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 diff --git a/examples/time-client.hs b/examples/time-client.hs new file mode 100644 --- /dev/null +++ b/examples/time-client.hs @@ -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 diff --git a/examples/time-server.hs b/examples/time-server.hs new file mode 100644 --- /dev/null +++ b/examples/time-server.hs @@ -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 diff --git a/json-rpc.cabal b/json-rpc.cabal --- a/json-rpc.cabal +++ b/json-rpc.cabal @@ -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 +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 diff --git a/src/Network/JSONRPC.hs b/src/Network/JSONRPC.hs new file mode 100644 --- /dev/null +++ b/src/Network/JSONRPC.hs @@ -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. diff --git a/src/Network/JSONRPC/Arbitrary.hs b/src/Network/JSONRPC/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Network/JSONRPC/Arbitrary.hs @@ -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 + diff --git a/src/Network/JSONRPC/Data.hs b/src/Network/JSONRPC/Data.hs new file mode 100644 --- /dev/null +++ b/src/Network/JSONRPC/Data.hs @@ -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 diff --git a/src/Network/JSONRPC/Interface.hs b/src/Network/JSONRPC/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Network/JSONRPC/Interface.hs @@ -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 diff --git a/test/Network/JsonRpc/Arbitrary.hs b/test/Network/JsonRpc/Arbitrary.hs deleted file mode 100644 --- a/test/Network/JsonRpc/Arbitrary.hs +++ /dev/null @@ -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] - diff --git a/test/Network/JsonRpc/Tests.hs b/test/Network/JsonRpc/Tests.hs deleted file mode 100644 --- a/test/Network/JsonRpc/Tests.hs +++ /dev/null @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Test.Framework -import Network.JsonRpc.Tests - -main :: IO () -main = defaultMain (tests) -