json-rpc (empty) → 0.1.0.0
raw patch · 10 files changed
+1460/−0 lines, 10 filesdep +QuickCheckdep +aesondep +asyncsetup-changed
Dependencies added: QuickCheck, aeson, async, base, bytestring, conduit, conduit-extra, deepseq, hashable, json-rpc, mtl, stm, stm-conduit, test-framework, test-framework-quickcheck2, text, unordered-containers
Files
- Network/JsonRpc.hs +136/−0
- Network/JsonRpc/Conduit.hs +256/−0
- Network/JsonRpc/Data.hs +375/−0
- README.md +124/−0
- Setup.hs +2/−0
- UNLICENSE +24/−0
- json-rpc.cabal +64/−0
- test/Network/JsonRpc/Arbitrary.hs +81/−0
- test/Network/JsonRpc/Tests.hs +392/−0
- test/main.hs +6/−0
+ Network/JsonRpc.hs view
@@ -0,0 +1,136 @@+module Network.JsonRpc+( -- * Introduction+ -- $introduction++ -- ** Server Example+ -- $server++ -- ** Client Example+ -- $client++ module Network.JsonRpc.Conduit+, module Network.JsonRpc.Data+) where++import Network.JsonRpc.Conduit+import Network.JsonRpc.Data++-- $introduction+--+-- This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and+-- partially-compatible with JSON-RPC 1.0. It provides an interface that+-- combines a JSON-RPC client and server. It can set and keep track of request+-- ids to parse responses. There is support for sending and receiving+-- notifications. You may use any underlying transport. Basic TCP client and+-- server provided.+--+-- The recommended interface to this library is provided as conduits that+-- encode outgoing messages, and decode incoming messages. Incoming messages+-- are delivered as an 'IncomingMsg' data structure, while outgoing messages+-- are sent in a 'Message' data structure. The former packs responses and+-- errors with their corresponding request, and has a separate constructor for+-- decoding errors.+--+-- A JSON-RPC application using this interface is considered to be+-- peer-to-peer, as it can send and receive all types of JSON-RPC message+-- independent of whether it originated the connection.+--+-- Type classes 'ToRequest', 'ToNotif' are for data that can be converted into+-- JSON-RPC requests and notifications respectively. An instance of aeson's+-- 'ToJSON' class is also required to serialize these data structures. Make+-- sure that they serialize as a structured JSON value (array or object) that+-- can go into the params field of the JSON-RPC object. Type classes+-- 'FromRequest', 'FromNotif' and 'FromResult' are for deserializing JSON-RPC+-- messages.+--+-- Errors are deserialized to the 'ErrorObj' data type. Only a string is+-- supported as contents inside a JSON-RPC 1.0 error. JSON-RPC 2.0 errors also+-- have a code, and possibly additional data as an aeson 'Value'.+++-- $server+--+-- This server returns the current time.+--+-- >{-# LANGUAGE OverloadedStrings #-}+-- >import Data.Aeson.Types+-- >import Data.Conduit+-- >import qualified Data.Conduit.List as CL+-- >import Data.Conduit.Network+-- >import Data.Time.Clock+-- >import Data.Time.Format+-- >import Network.JsonRpc+-- >import System.Locale+-- >+-- >data TimeReq = TimeReq+-- >data TimeRes = TimeRes UTCTime+-- >+-- >instance FromRequest TimeReq where+-- > paramsParser "time" = Just $ const $ return TimeReq +-- > paramsParser _ = Nothing+-- >+-- >instance ToJSON TimeRes where+-- > toJSON (TimeRes t) = toJSON $ formatTime defaultTimeLocale "%c" t+-- >+-- >srv :: AppConduits () () TimeRes TimeReq () () IO -> IO ()+-- >srv (src, snk) = src $= CL.mapM respond $$ snk+-- >+-- >respond :: IncomingMsg () TimeReq () ()+-- > -> IO (Message () () TimeRes)+-- >respond (IncomingMsg (MsgRequest (Request ver _ TimeReq i)) Nothing) = do +-- > t <- getCurrentTime+-- > return $ MsgResponse (Response ver (TimeRes t) i)+-- >+-- >respond (IncomingError e) = return $ MsgError e+-- >respond (IncomingMsg (MsgError e) _) = return $ MsgError $ e+-- >respond _ = undefined+-- >+-- >main :: IO ()+-- >main = tcpServer V2 (serverSettings 31337 "127.0.0.1") srv+++-- $client+--+-- Corresponding TCP client to get time from server.+--+-- >{-# LANGUAGE OverloadedStrings #-}+-- >import Data.Aeson.Types hiding (Error)+-- >import Data.Conduit+-- >import qualified Data.Conduit.List as CL+-- >import Data.Conduit.Network+-- >import qualified Data.Text as T+-- >import Data.Time.Clock+-- >import Data.Time.Format+-- >import Network.JsonRpc+-- >import System.Locale+-- >+-- >data TimeReq = TimeReq+-- >data TimeRes = TimeRes UTCTime+-- >+-- >instance ToRequest TimeReq where+-- > requestMethod TimeReq = "time"+-- >+-- >instance ToJSON TimeReq where+-- > toJSON TimeReq = emptyArray+-- >+-- >instance FromResponse TimeRes where+-- > parseResult "time" = withText "time" $ \t -> case f t of+-- > Nothing -> fail "Could not parse time"+-- > Just t' -> return $ TimeRes t'+-- > where+-- > f t = parseTime defaultTimeLocale "%c" (T.unpack t)+-- >+-- >cli :: AppConduits TimeReq () () () () TimeRes IO+-- > -> IO UTCTime+-- >cli (src, snk) = do+-- > CL.sourceList [MsgRequest $ buildRequest V2 TimeReq] $$ snk+-- > ts <- src $$ CL.consume+-- > case ts of+-- > [] -> error "No response received"+-- > [IncomingError (ErrorObj _ m _ _ _)] -> error $ "Unknown: " ++ m+-- > [IncomingMsg (MsgError (ErrorObj _ m _ _ _)) _] -> error m+-- > [IncomingMsg (MsgResponse (Response _ (TimeRes t) _)) _] -> return t+-- > _ -> undefined+-- >+-- >main :: IO ()+-- >main = tcpClient V2 True (clientSettings 31337 "127.0.0.1") cli >>= print
+ Network/JsonRpc/Conduit.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Conduit Interface for JSON-RPC.+module Network.JsonRpc.Conduit+( -- * Conduits+ -- ** High-Level+ AppConduits+, IncomingMsg(..)+, runConduits+, tcpClient+, tcpServer+, query+ -- ** Low-Level+, Session(..)+, 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 Data.Aeson+import Data.Aeson.Types+import Data.ByteString (ByteString)+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.Binary as CB+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 of 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 :: TVar Bool -- ^ Has the sink closed?+ }++-- | Initialize JSON-RPC session.+initSession :: STM (Session qo)+initSession = Session <$> newTVar (IdInt 0)+ <*> newTVar M.empty+ <*> newTVar False++-- | Conduit that serializes JSON documents for sending to the network.+encodeConduit :: (ToJSON a, Monad m) => Conduit a m ByteString+encodeConduit = CL.map (L8.toStrict . flip L8.append "\n" . 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+ => Session qo+ -> Conduit (Message qo no ro) m (Message qo no ro)+msgConduit qs = await >>= \nqM -> case nqM of+ Nothing ->+ liftIO (atomically $ writeTVar (isLast qs) True) >> return ()+ Just (MsgRequest rq) -> do+ msg <- MsgRequest <$> liftIO (atomically $ addId rq)+ yield msg >> msgConduit qs+ Just msg ->+ yield msg >> msgConduit 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'+ return rq'+ i -> do+ h <- readTVar (sentRequests qs)+ writeTVar (sentRequests qs) (M.insert i rq h)+ 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 = CB.lines =$= f where+ f = await >>= \bsM -> case bsM of+ Nothing ->+ return ()+ Just bs -> do+ (m, d) <- liftIO . atomically $ decodeSTM bs+ yield m >> unless d f++ decodeSTM bs = readTVar (sentRequests qs) >>= \h -> case decodeMsg h bs of+ Right m@(MsgResponse rs) -> do+ (rq, dis) <- requestSTM h $ getResId rs+ return (IncomingMsg m (Just rq), dis)+ Right m@(MsgError re) -> case getErrId re of+ IdNull ->+ return (IncomingMsg m Nothing, False)+ i -> do+ (rq, dis) <- requestSTM h i+ return (IncomingMsg m (Just rq), dis)+ Right m -> return (IncomingMsg m Nothing, False)+ Left e -> return (IncomingError e, False)++ requestSTM h i = do+ let rq = fromJust $ i `M.lookup` h+ h' = M.delete i h+ writeTVar (sentRequests qs) h'+ t <- readTVar $ isLast qs+ return (rq, c && t && M.null h')++ decodeMsg h bs = case eitherDecodeStrict' bs of+ Left _ -> Left $ errorParse ver Null+ Right v -> case parseEither (topParse h) v of+ Left _ -> Left $ errorParse ver Null+ Right x -> x++ 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 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 -> do+ runConduits ver d (appSink ad) (appSource ad) f++-- 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 -> do+ runConduits ver False (appSink cl) (appSource cl) f+
+ Network/JsonRpc/Data.hs view
@@ -0,0 +1,375 @@+{-# 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++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 i = ErrorObj ver "Invalid params" (-32602) v i++-- | Method not found.+errorMethod :: Ver -> Method -> Id -> ErrorObj+errorMethod ver m i = ErrorObj ver "Method not found" (-32601) (toJSON m) i++-- | 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 i = IdInt i+ fromEnum (IdInt i) = i+ fromEnum _ = error $ "Can't enumerate non-integral ids"++instance FromJSON Id where+ parseJSON s@(String _) = IdTxt <$> parseJSON s+ parseJSON n@(Number _) = IdInt <$> parseJSON n+ parseJSON Null = return $ IdNull+ parseJSON _ = mzero++instance ToJSON Id where+ toJSON (IdTxt s) = toJSON s+ toJSON (IdInt n) = toJSON n+ toJSON IdNull = Null++-- | JSON-RPC version+data Ver = V1 -- ^ JSON-RPC 1.0+ | V2 -- ^ JSON-RPC 2.0+ deriving (Eq, Show, Read)++instance NFData Ver++++--+-- Helpers+--++jr2 :: Pair+jr2 = "jsonrpc" .= ("2.0" :: Text)+
+ README.md view
@@ -0,0 +1,124 @@+json-rpc+========++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"++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+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ UNLICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++For more information, please refer to <http://unlicense.org>
+ json-rpc.cabal view
@@ -0,0 +1,64 @@+name: json-rpc+version: 0.1.0.0+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++library+ exposed-modules: Network.JsonRpc+ other-modules: Network.JsonRpc.Data,+ Network.JsonRpc.Conduit+ build-depends: base >= 4.6 && < 5,+ aeson >= 0.7.0.5 && < 0.8,+ async >= 2.0 && < 2.1,+ bytestring >= 0.10 && < 0.11,+ conduit >= 1.1 && < 1.2,+ conduit-extra >= 1.1 && < 1.2,+ deepseq >= 1.3 && < 1.4,+ hashable >= 1.2 && < 1.3,+ mtl >= 2.1 && < 2.2,+ stm >= 2.4 && < 2.5,+ stm-conduit >= 2.4 && < 2.5,+ text >= 1.1 && < 1.2,+ unordered-containers >= 0.2 && < 0.3+ default-language: Haskell2010+ ghc-options: -Wall++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.5 && < 0.8,+ async >= 2.0 && < 2.1,+ bytestring >= 0.10 && < 0.11,+ conduit >= 1.1 && < 1.2,+ conduit-extra >= 1.1 && < 1.2,+ deepseq >= 1.3 && < 1.4,+ hashable >= 1.2 && < 1.3,+ json-rpc >= 0.1 && < 0.2,+ mtl >= 2.1 && < 2.2,+ stm >= 2.4 && < 2.5,+ stm-conduit >= 2.4 && < 2.5,+ text >= 1.1 && < 1.2,+ unordered-containers >= 0.2 && < 0.3,+ QuickCheck >= 2.6 && < 2.7,+ test-framework >= 0.8 && < 0.9,+ test-framework-quickcheck2 >= 0.3 && < 0.4+ default-language: Haskell2010+ ghc-options: -Wall
+ test/Network/JsonRpc/Arbitrary.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Arbitrary instances and data types for use in test suites.+module Network.JsonRpc.Arbitrary+( -- * Arbitrary Data+ ReqRes(..)+) where++import Control.Applicative+import Data.Aeson.Types hiding (Error)+import qualified Data.HashMap.Strict as M+import Data.Text (Text)+import qualified Data.Text as T+import Network.JsonRpc+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen++-- | A pair of a request and its corresponding response.+-- Id and version should match.+data ReqRes q r = ReqRes !(Request q) !(Response r)+ deriving (Show, Eq)++instance Arbitrary (ReqRes Value Value) where+ arbitrary = do+ rq <- arbitrary+ rs <- arbitrary+ let rs' = rs { getResId = getReqId rq, getResVer = getReqVer rq }+ return $ ReqRes rq rs'++instance Arbitrary Text where+ arbitrary = T.pack <$> arbitrary++instance Arbitrary Ver where+ arbitrary = elements [V1, V2]++instance (Arbitrary q, ToRequest q) => Arbitrary (Request q) where+ arbitrary = do+ q <- arbitrary+ v <- arbitrary+ let m = requestMethod q+ Request v m q <$> arbitrary++instance (Arbitrary n, ToNotif n) => Arbitrary (Notif n) where+ arbitrary = do+ n <- arbitrary+ v <- arbitrary+ let m = notifMethod n+ return $ Notif v m n++instance Arbitrary r => Arbitrary (Response r) where+ arbitrary = Response <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ErrorObj where+ arbitrary = ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary+ <*> arbitrary <*> arbitrary++instance ( Arbitrary q, Arbitrary n, Arbitrary r+ , ToRequest q, ToNotif n, ToJSON r )+ => Arbitrary (Message q n r)+ where+ arbitrary = oneof [ MsgRequest <$> arbitrary+ , MsgNotif <$> arbitrary+ , MsgResponse <$> arbitrary+ , MsgError <$> arbitrary ]++instance Arbitrary Id where+ arbitrary = oneof [IdInt <$> arbitrary, IdTxt <$> arbitrary]++instance Arbitrary Value where+ arbitrary = resize 10 $ oneof [val, lsn, objn] where+ val = oneof [ toJSON <$> (arbitrary :: Gen String)+ , toJSON <$> (arbitrary :: Gen Int)+ , toJSON <$> (arbitrary :: Gen Double)+ , toJSON <$> (arbitrary :: Gen Bool) ]+ ls = toJSON <$> listOf val+ obj = toJSON . M.fromList <$> listOf ps+ ps = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls]+ lsn = toJSON <$> listOf (oneof [ls, obj, val])+ objn = toJSON . M.fromList <$> listOf psn+ psn = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls, obj]+
+ test/Network/JsonRpc/Tests.hs view
@@ -0,0 +1,392 @@+{-# 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.Monad+import Data.Aeson.Types hiding (Error)+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.List+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+ ]+ ]++--+-- 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 $ fromMaybe True $ fmap (== ("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 $ fromMaybe True $ fmap (== ("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 $ fromMaybe True $ fmap (== ("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 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 qs+ $= encodeConduit+ $= decodeConduit ver True qs'+ $$ CL.consume+ assert $ null $ filter 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 qs+ $= encodeConduit+ $= decodeConduit ver True qs'+ $= CL.map respond+ $= encodeConduit+ $= decodeConduit ver True qs+ $$ CL.consume+ assert $ null $ filter 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 qs+ $= encodeConduit+ $= decodeConduit ver True qs'+ $= CL.map respond+ $= encodeConduit+ $= decodeConduit ver True qs+ $$ CL.consume+ assert $ null $ filter 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
+ test/main.hs view
@@ -0,0 +1,6 @@+import Test.Framework+import Network.JsonRpc.Tests++main :: IO ()+main = defaultMain (tests)+