json-rpc 0.2.1.6 → 0.3.0.0

raw patch · 8 files changed

+655/−1017 lines, 8 filesdep ~json-rpcPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: json-rpc

API changes (from Hackage documentation)

Files

• Network/JsonRpc.hs +33/−64
• Network/JsonRpc/Conduit.hs +0/−304
• Network/JsonRpc/Data.hs +196/−170
• Network/JsonRpc/Interface.hs +255/−0
• README.md +34/−62
• json-rpc.cabal +11/−15
• test/Network/JsonRpc/Arbitrary.hs +24/−27
• test/Network/JsonRpc/Tests.hs +102/−375

@@ -8,54 +8,33 @@   -- ** Client Example   -- $client -  module Network.JsonRpc.Conduit+  module Network.JsonRpc.Interface , module Network.JsonRpc.Data ) where -import Network.JsonRpc.Conduit+import Network.JsonRpc.Interface 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.+-- 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.------ 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.+-- This JSON-RPC server returns the current time. -- -- >{-# LANGUAGE OverloadedStrings #-}--- >import Data.Aeson.Types--- >import Data.Conduit--- >import qualified Data.Conduit.List as CL+-- >import Control.Applicative+-- >import Data.Aeson.Types hiding (Error) -- >import Data.Conduit.Network -- >import Data.Time.Clock -- >import Data.Time.Format@@ -63,40 +42,34 @@ -- >import System.Locale -- > -- >data TimeReq = TimeReq--- >data TimeRes = TimeRes UTCTime+-- >data TimeRes = TimeRes { timeRes :: UTCTime } -- > -- >instance FromRequest TimeReq where--- >    paramsParser "time" = Just $ const $ return TimeReq --- >    paramsParser _ = Nothing+-- >    parseParams "time" = Just $ const $ return TimeReq +-- >    parseParams _ = 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+-- >respond :: Respond TimeReq IO TimeRes+-- >respond TimeReq = Right . TimeRes <$> getCurrentTime -- > -- >main :: IO ()--- >main = tcpServer V2 (serverSettings 31337 "127.0.0.1") srv+-- >main = jsonRpcTcpServer V2 (serverSettings 31337 "::1") respond dummySrv  + -- $client -- -- Corresponding TCP client to get time from server. -- -- >{-# LANGUAGE OverloadedStrings #-}+-- >import Control.Concurrent+-- >import Control.Concurrent.STM+-- >import Control.Monad+-- >import Control.Monad.Trans+-- >import Data.Aeson -- >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@@ -105,7 +78,7 @@ -- >import System.Locale -- > -- >data TimeReq = TimeReq--- >data TimeRes = TimeRes UTCTime+-- >data TimeRes = TimeRes { timeRes :: UTCTime } -- > -- >instance ToRequest TimeReq where -- >    requestMethod TimeReq = "time"@@ -114,23 +87,19 @@ -- >    toJSON TimeReq = emptyArray -- > -- >instance FromResponse TimeRes where--- >    parseResult "time" = withText "time" $ \t -> case f t of--- >        Nothing -> fail "Could not parse time"+-- >    parseResult "time" = Just $ withText "time" $ \t -> case f t of -- >        Just t' -> return $ TimeRes t'+-- >        Nothing -> mzero -- >      where -- >        f t = parseTime defaultTimeLocale "%c" (T.unpack t)+-- >    parseResult _ = Nothing -- >--- >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+-- >req :: JsonRpcT IO UTCTime+-- >req = sendRequest TimeReq >>= liftIO . atomically >>= \ts -> case ts of+-- >    Left e -> error $ fromError e+-- >    Right (Just (TimeRes r)) -> return r+-- >    _ -> error "Could not parse response" -- > -- >main :: IO ()--- >main = tcpClient V2 True (clientSettings 31337 "127.0.0.1") cli >>= print+-- >main = jsonRpcTcpClient V2 (clientSettings 31337 "::1") dummyRespond .+-- >    replicateM_ 4 $ req >>= liftIO . print >> liftIO (threadDelay 1000000)

@@ -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')

@@ -6,7 +6,7 @@   Request(..)   -- ** Parsing , FromRequest(..)-, parseRequest+, fromRequest   -- ** Encoding , ToRequest(..) , buildRequest@@ -15,19 +15,24 @@ , Response(..)   -- ** Parsing , FromResponse(..)-, parseResponse+, fromResponse+  -- ** Encoding+, Respond+, buildResponse    -- * Notifications , Notif(..)   -- ** Parsing , FromNotif(..)-, parseNotif+, fromNotif   -- ** Encoding , ToNotif(..) , buildNotif    -- * Errors+, RpcError(..) , ErrorObj(..)+, fromError   -- ** Error Messages , errorParse , errorInvalid@@ -43,12 +48,16 @@  ) where -import Control.Applicative ((<$>), (<*>), (<|>))-import Control.DeepSeq (NFData, rnf)-import Control.Monad (when, guard, mzero)+import Control.Applicative+import qualified Data.ByteString.Lazy as L+import Control.DeepSeq+import Control.Monad+import Data.Aeson (encode) import Data.Aeson.Types import Data.Hashable (Hashable) import Data.Text (Text)+import Data.Text.Encoding+import qualified Data.Text as T import GHC.Generics (Generic)  @@ -57,67 +66,58 @@ -- Requests -- --- Request data type.-data Request q = Request { getReqVer      :: !Ver       -- Version-                         , getReqMethod   :: !Method    -- Method-                         , getReqParams   :: !q         -- Params-                         , getReqId       :: !Id        -- Id-                         } deriving (Eq, Show, Read)+data Request = Request { getReqVer      :: !Ver+                       , getReqMethod   :: !Method+                       , getReqParams   :: !Value+                       , getReqId       :: !Id+                       } deriving (Eq, Show) -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 NFData Request where+    rnf (Request v m p i) = rnf v `seq` rnf m `seq` rnf p `seq` rnf i -instance ToJSON q => ToJSON (Request q) where-    toJSON (Request V2 m p i) = object $ case toJSON p of+instance ToJSON Request where+    toJSON (Request V2 m p i) = object $ case 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+        _    -> [jr2, "method" .= m, "id" .= i, "params" .= p]+    toJSON (Request V1 m p i) = object $ case p of         Null -> ["method" .= m, "params" .= emptyArray, "id" .= i]-        v    -> ["method" .= m, "params" .= v, "id" .= i]+        _    -> ["method" .= m, "params" .= p, "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)+    -- | Parser for params Value in JSON-RPC request.+    parseParams :: Method -> Maybe (Value -> Parser q) +fromRequest :: FromRequest q => Request -> Maybe q+fromRequest (Request _ m p _) = parseParams m >>= flip parseMaybe p+ instance FromRequest Value where-    paramsParser _ = Just return+    parseParams = const $ Just return  instance FromRequest () where-    paramsParser _ = Nothing+    parseParams = const . Just . const $ return () --- | 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+instance FromJSON Request where+    parseJSON = withObject "request" $ \o -> do+        (v, i, m, p) <- parseVerIdMethParams o+        guard $ i /= IdNull+        return $ Request v m p i --- | Class for data that can be sent as JSON-RPC requests.--- Define a method name for each request. class ToRequest q where+    -- | Method associated with request data to build a request object.     requestMethod :: q -> Method  instance ToRequest Value where-    requestMethod _ = ""+    requestMethod = const "json"  instance ToRequest () where-    requestMethod _ = undefined+    requestMethod = const "json" --- Build JSON-RPC request.-buildRequest :: ToRequest q+buildRequest :: (ToJSON q, ToRequest q)              => Ver             -- ^ JSON-RPC version              -> q               -- ^ Request data-             -> Request q-buildRequest ver q = Request ver (requestMethod q) q IdNull+             -> Id+             -> Request+buildRequest ver q = Request ver (requestMethod q) (toJSON q)   @@ -125,115 +125,110 @@ -- Responses -- --- | JSON-RPC response data type-data Response r = Response  { getResVer :: !Ver             -- ^ Version-                            , getResult :: !r               -- ^ Result-                            , getResId  :: !Id              -- ^ Id-                            } deriving (Eq, Show, Read)+data Response = Response { getResVer :: !Ver+                         , getResult :: !Value+                         , getResId  :: !Id+                         } deriving (Eq, Show) -instance NFData r => NFData (Response r) where+instance NFData Response where     rnf (Response v r i) = rnf v `seq` rnf r `seq` rnf i -instance ToJSON r => ToJSON (Response r) where+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] --- | 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+    -- | Parser for result Value in JSON-RPC response.+    -- Method corresponds to request to which this response answers.+    parseResult :: Method -> Maybe (Value -> Parser r) +fromResponse :: FromResponse r => Method -> Response -> Maybe r+fromResponse m (Response _ r _) = parseResult m >>= flip parseMaybe r+ instance FromResponse Value where-    parseResult _ = return+    parseResult = const $ Just return  instance FromResponse () where-    parseResult _ _ = return ()+    parseResult = const . Just . const $ 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+instance FromJSON Response where+    parseJSON = withObject "response" $ \o -> do+        i <- o .: "id"+        guard $ i /= IdNull+        r <- o .: "result"+        guard $ r /= Null+        v <- parseVer o+        return $ Response v r i +buildResponse :: (Monad m, FromRequest q, ToJSON r)+              => Respond q m r+              -> Request+              -> m (Either RpcError Response)+buildResponse f req@(Request v _ p i) = case fromRequest req of+    Nothing -> return . Left $ RpcError v (errorInvalid p) i+    Just q -> do+        rE <- f q+        return $ either (\e -> Left $ RpcError v e i)+                        (\r -> Right $ Response v (toJSON r) i) rE +type Respond q m r = q -> m (Either ErrorObj r) + -- -- Notifications -- --- | Class for JSON-RPC notifications.-data Notif n = Notif  { getNotifVer    :: !Ver          -- ^ Version-                      , getNotifMethod :: !Method       -- ^ Method-                      , getNotifParams :: !n            -- ^ Params-                      } deriving (Eq, Show, Read)+data Notif = Notif  { getNotifVer    :: !Ver+                    , getNotifMethod :: !Method+                    , getNotifParams :: !Value+                    } deriving (Eq, Show) -instance NFData n => NFData (Notif n) where+instance NFData Notif 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+instance ToJSON Notif where+    toJSON (Notif V2 m p) = object $ case p of         Null -> [jr2, "method" .= m]-        v    -> [jr2, "method" .= m, "params" .= v]-    toJSON (Notif V1 m p) = object $ case toJSON p of+        _    -> [jr2, "method" .= m, "params" .= p]+    toJSON (Notif V1 m p) = object $ case p of         Null -> ["method" .= m, "params" .= emptyArray, "id" .= Null]-        v    -> ["method" .= m, "params" .=          v, "id" .= Null]+        _    -> ["method" .= m, "params" .= p, "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)+    -- | Parser for notification params Value.+    parseNotif :: Method -> Maybe (Value -> Parser n) +fromNotif :: FromNotif n => Notif -> Maybe n+fromNotif (Notif _ m n) = parseNotif m >>= flip parseMaybe n+ instance FromNotif Value where-    notifParamsParser _ = Just return+    parseNotif = const $ Just return  instance FromNotif () where-    notifParamsParser _ = Nothing+    parseNotif = const . Just . const $ return () --- | 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+instance FromJSON Notif where+    parseJSON = withObject "notification" $ \o -> do+        (v, i, m, p) <- parseVerIdMethParams o+        guard $ i == IdNull+        return $ Notif v m p  class ToNotif n where     notifMethod :: n -> Method  instance ToNotif Value where-    notifMethod _ = ""+    notifMethod = const "json"  instance ToNotif () where-    notifMethod _ = undefined+    notifMethod = const "json" --- | Build notifications.-buildNotif :: ToNotif n-           => Ver           -- ^ Version-           -> n             -- ^ Notification data-           -> Notif n-buildNotif ver n = Notif ver (notifMethod n) n+buildNotif :: (ToJSON n, ToNotif n)+           => Ver+           -> n+           -> Notif+buildNotif ver n = Notif ver (notifMethod n) (toJSON n)   @@ -241,96 +236,115 @@ -- 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)+-- 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)  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+    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++fromError :: ErrorObj -> String+fromError (ErrorObj m _ _) = m+fromError (ErrorVal v) = T.unpack $ decodeUtf8 $ L.toStrict $ encode v++data RpcError = RpcError { getErrVer  :: !Ver+                         , getErrObj  :: !ErrorObj+                         , getErrId   :: !Id+                         } deriving (Eq, Show)++instance NFData RpcError where+    rnf (RpcError v o i) = rnf v `seq` rnf o `seq` rnf i++instance FromJSON RpcError where     parseJSON = withObject "error" $ \o -> do+        v <- parseVer o+        e <- o .: "error"         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+        return $ RpcError v e 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]+instance ToJSON RpcError where+    toJSON (RpcError V1 o i) =+        object ["id" .= i, "result" .= Null, "error" .= o]+    toJSON (RpcError V2 o i) =+        object ["id" .= i, "error" .= o, jr2]  -- | Parse error.-errorParse :: Ver -> Value -> ErrorObj-errorParse ver v = ErrorObj ver "Parse error" (-32700) v IdNull+errorParse :: Value -> ErrorObj+errorParse = ErrorObj "Parse error" (-32700)  -- | Invalid request.-errorInvalid :: Ver -> Value -> ErrorObj-errorInvalid ver v = ErrorObj ver "Invalid request" (-32600) v IdNull+errorInvalid :: Value -> ErrorObj+errorInvalid = ErrorObj "Invalid request" (-32600)  -- | Invalid params.-errorParams :: Ver -> Value -> Id -> ErrorObj-errorParams ver v = ErrorObj ver "Invalid params" (-32602) v+errorParams :: Value -> ErrorObj+errorParams = ErrorObj "Invalid params" (-32602)  -- | Method not found.-errorMethod :: Ver -> Method -> Id -> ErrorObj-errorMethod ver m = ErrorObj ver "Method not found" (-32601) (toJSON m)+errorMethod :: Method -> ErrorObj+errorMethod = ErrorObj "Method not found" (-32601) . toJSON  -- | Id not recognized.-errorId :: Ver -> Id -> ErrorObj-errorId ver i = ErrorObj ver "Id not recognized" (-32000) (toJSON i) IdNull-+errorId :: Id -> ErrorObj+errorId = ErrorObj "Id not recognized" (-32000) . toJSON   -- -- 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     }+data Message+    = MsgRequest   { getMsgRequest  :: !Request  }+    | MsgResponse  { getMsgResponse :: !Response }+    | MsgNotif     { getMsgNotif    :: !Notif    }+    | MsgError     { getMsgError    :: !RpcError }     deriving (Eq, Show) -instance (NFData q, NFData n, NFData r) => NFData (Message q n r) where+instance NFData Message where     rnf (MsgRequest  q) = rnf q-    rnf (MsgNotif    n) = rnf n     rnf (MsgResponse r) = rnf r+    rnf (MsgNotif    n) = rnf n     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+instance ToJSON Message where+    toJSON (MsgRequest  q) = toJSON q+    toJSON (MsgResponse r) = toJSON r+    toJSON (MsgNotif    n) = toJSON n+    toJSON (MsgError    e) = toJSON e +instance FromJSON Message where+    parseJSON v = (MsgRequest  <$> parseJSON v)+              <|> (MsgResponse <$> parseJSON v)+              <|> (MsgNotif    <$> parseJSON v)+              <|> (MsgError    <$> parseJSON v)+ -- -- Types -- --- | JSON-RPC methods in requests and notifications. type Method = Text --- | JSON-RPC message id. data Id = IdInt { getIdInt :: !Int  }         | IdTxt { getIdTxt :: !Text }         | IdNull@@ -359,12 +373,12 @@     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+instance NFData Ver where+    rnf v = v `seq` ()   @@ -375,3 +389,15 @@ 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++parseVerIdMethParams :: Object -> Parser (Ver, Id, Method, Value)+parseVerIdMethParams o = do+    v <- parseVer o+    i <- o .:? "id" .!= IdNull+    m <- o .: "method"+    p <- o .:? "params" .!= Null+    return (v, i, m, p)

@@ -0,0 +1,255 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Interface for JSON-RPC.+module Network.JsonRpc.Interface+( -- * Establish JSON-RPC context+  JsonRpcT+, runJsonRpcT++  -- * Communicate with remote party+, sendRequest+, sendNotif+, receiveNotif++  -- * Transports+  -- ** Client+, jsonRpcTcpClient+, dummyRespond+  -- ** Server+, jsonRpcTcpServer+, dummySrv+) where++import Control.Applicative+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Reader+import Control.Monad.Trans.State+import Data.Aeson+import Data.Aeson.Types (parseMaybe)+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 Network.JsonRpc.Data++type SentRequests = HashMap Id (TMVar (Either RpcError Response))++data Session = Session { inCh     :: TBMChan (Either RpcError Message)+                       , outCh    :: TBMChan Message+                       , notifCh  :: TBMChan (Either RpcError Notif)+                       , lastId   :: TVar Id+                       , sentReqs :: TVar SentRequests+                       , rpcVer   :: Ver+                       }++-- Context for JSON-RPC connection. Connection will remain active as long+-- as context is maintaned.+type JsonRpcT = ReaderT Session++initSession :: Ver -> STM Session+initSession v = Session <$> newTBMChan 16+                        <*> newTBMChan 16+                        <*> newTBMChan 16+                        <*> newTVar (IdInt 0)+                        <*> newTVar M.empty+                        <*> return v++encodeConduit :: (ToJSON a, Monad m) => Conduit a m ByteString+encodeConduit = CL.map $ L8.toStrict . encode++parseMessages :: Monad m+              => Ver -> Conduit ByteString m (Either RpcError Message)+parseMessages ver = evalStateT loop Nothing where+    loop = lift await >>= maybe flush process++    flush = get >>= \kM -> case kM of Nothing -> return ()+                                      Just k  -> handle (k B.empty)+    process = runParser >=> handle++    runParser ck = maybe (parse json' ck) ($ ck) <$> get <* put Nothing++    handle (Fail {}) = do+        lift . yield . Left $ RpcError ver (errorParse Null) IdNull+        loop+    handle (Partial k) = put (Just k) >> loop+    handle (Done rest v) = do+        let msg = decodeJsonRpc v+        lift $ yield msg+        if B.null rest then loop else process rest++    decodeJsonRpc v = case parseMaybe parseJSON v of+        Just msg -> Right msg+        Nothing -> Left $ RpcError ver (errorInvalid v) IdNull++processIncoming :: (FromRequest q, ToJSON r)+                => Respond q IO r -> JsonRpcT IO ()+processIncoming r = do+    i <- reader inCh+    o <- reader outCh+    n <- reader notifCh+    s <- reader sentReqs+    v <- reader rpcVer+    join . liftIO . atomically $ readTBMChan i >>= \inc -> case inc of+        Nothing -> return $ return ()+        Just (Left e) -> do+            writeTBMChan o (MsgError e)+            return $ processIncoming r+        Just (Right (MsgNotif t)) ->+            writeTBMChan n (Right t) >> return (processIncoming r)+        Just (Right (MsgRequest q)) -> return $ do+            msg <- either MsgError MsgResponse <$> liftIO (buildResponse r q)+            liftIO . atomically $ writeTBMChan o msg+            processIncoming r+        Just (Right (MsgResponse res@(Response _ _ x))) -> do+            m <- readTVar s+            case x `M.lookup` m of+                Nothing ->+                    writeTBMChan o . MsgError $ RpcError v (errorId x) IdNull+                Just p ->+                    writeTVar s (x `M.delete` m) >> putTMVar p (Right res)+            return $ processIncoming r+        Just (Right (MsgError err@(RpcError _ _ IdNull))) -> do+            writeTBMChan n $ Left err+            return $ processIncoming r+        Just (Right (MsgError err@(RpcError _ _ x))) -> do+            m <- readTVar s+            case x `M.lookup` m of+                Nothing ->+                    writeTBMChan o . MsgError $ RpcError v (errorId x) IdNull+                Just p ->+                    writeTVar s (x `M.delete` m) >> putTMVar p (Left err)+            return $ processIncoming r++-- | Returns Right Nothing if could not parse response. Run output in STM+-- monad. STM will block until response arrives.+sendRequest :: (ToJSON q, ToRequest q, FromResponse r, MonadIO m)+            => q -> JsonRpcT m (STM (Either ErrorObj (Maybe r)))+sendRequest q = do+    o <- reader outCh+    v <- reader rpcVer+    l <- reader lastId+    s <- reader sentReqs+    p <- liftIO . atomically $ do+        p <- newEmptyTMVar +        i <- succ <$> readTVar l+        m <- readTVar s+        let req = buildRequest v q i+        writeTVar s $ M.insert i p m+        writeTBMChan o $ MsgRequest req +        writeTVar l i+        return p+    return $ takeTMVar p >>= \pE -> case pE of+        Left e -> return . Left $ getErrObj e+        Right y@(Response ver r _) -> +            case fromResponse (requestMethod q) y of+                Nothing -> do+                    let err = MsgError $ RpcError ver (errorInvalid r) IdNull+                    writeTBMChan o err+                    return $ Right Nothing+                Just x -> return . Right $ Just x++-- | Send notification. Run output in STM monad. Will not block.+sendNotif :: (ToJSON no, ToNotif no, Monad m) => no -> JsonRpcT m (STM ())+sendNotif n = do+    o <- reader outCh+    v <- reader rpcVer+    let notif = buildNotif v n+    return $ writeTBMChan o (MsgNotif notif)++-- | Receive notifications from peer.+-- Returns Nothing if incoming channel is closed and empty.+-- Result is Right Nothing if it failed to parse notification.+-- Run output in STM monad. Will not block.+receiveNotif :: (Monad m, FromNotif n)+             => JsonRpcT m (STM (Maybe (Either ErrorObj (Maybe n))))+receiveNotif = do+    c <- reader notifCh+    o <- reader outCh+    return $ readTBMChan c >>= \nM -> case nM of+        Nothing -> return Nothing+        Just (Left e) -> return . Just . Left $ getErrObj e+        Just (Right n@(Notif v _ p)) -> case fromNotif n of+            Nothing -> do+                let err = MsgError $ RpcError v (errorParse p) IdNull+                writeTBMChan o err+                return . Just $ Right Nothing+            Just x -> return . Just . Right $ Just x++-- | Create JSON-RPC session around ByteString conduits from transport+-- layer. When context exits, session stops existing.+runJsonRpcT :: (FromRequest q, ToJSON r)+            => Ver                     -- ^ JSON-RPC version+            -> Respond q IO r          -- ^ Respond to incoming requests+            -> Sink ByteString IO ()   -- ^ Sink to send messages+            -> Source IO ByteString    -- ^ Source of incoming messages+            -> JsonRpcT IO a           -- ^ JSON-RPC action+            -> IO a                    -- ^ Output of action+runJsonRpcT ver r snk src f = do+    qs <- atomically $ initSession ver+    let inSnk  = sinkTBMChan (inCh qs) True+        outSrc = sourceTBMChan (outCh qs)+    withAsync (fromNet inSnk) $ const $+        withAsync (toNet outSrc) $ const $+            withAsync (runReaderT (processIncoming r) qs) $ const $+                runReaderT f qs+  where+    fromNet inSnk = src $= parseMessages ver $$ inSnk+    toNet outSrc = outSrc $= encodeConduit $$ snk+++cr :: Monad m => Conduit ByteString m ByteString+cr = CL.map (`B8.snoc` '\n')++ln :: Monad m => Conduit ByteString m ByteString+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  -> unless (B8.null l) $ 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+++-- | TCP client transport for JSON-RPC.+jsonRpcTcpClient+    :: (FromRequest q, ToJSON r)+    => Ver             -- ^ JSON-RPC version+    -> ClientSettings  -- ^ Connection settings+    -> Respond q IO r  -- ^ Respond to incoming requests+    -> JsonRpcT IO a   -- ^ JSON-RPC action+    -> IO a            -- ^ Output of action+jsonRpcTcpClient ver cs r f = runTCPClient cs $ \ad ->+    runJsonRpcT ver r (cr =$ appSink ad) (appSource ad $= ln) f++-- | TCP server transport for JSON-RPC.+jsonRpcTcpServer+    :: (FromRequest q, ToJSON r)+    => Ver             -- ^ JSON-RPC version+    -> ServerSettings  -- ^ Connection settings+    -> Respond q IO r  -- ^ Respond to incoming requests+    -> JsonRpcT IO ()  -- ^ Action to perform on connecting client thread+    -> IO ()+jsonRpcTcpServer ver ss r f = runTCPServer ss $ \cl ->+    runJsonRpcT ver r (cr =$ appSink cl) (appSource cl $= ln) f++-- | Dummy server for servers not expecting client to send notifications,+-- that is most cases.+dummySrv :: MonadIO m => JsonRpcT m ()+dummySrv = forever $ do+    n <- receiveNotif+    liftIO (atomically n :: IO (Maybe (Either ErrorObj (Maybe ()))))++-- | Respond function for systems that do not reply to requests, as usual+-- in clients.+dummyRespond :: Monad m => Respond () m ()+dummyRespond = const . return $ Right () 

@@ -3,44 +3,26 @@  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.+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. -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. +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.   Server Example -------------- -This server returns the current time.+This JSON-RPC server returns the current time.  ``` haskell {-# LANGUAGE OverloadedStrings #-}-import Data.Aeson.Types-import Data.Conduit-import qualified Data.Conduit.List as CL+import Control.Applicative+import Data.Aeson.Types hiding (Error) import Data.Conduit.Network import Data.Time.Clock import Data.Time.Format@@ -48,30 +30,21 @@ import System.Locale  data TimeReq = TimeReq-data TimeRes = TimeRes UTCTime+data TimeRes = TimeRes { timeRes :: UTCTime }  instance FromRequest TimeReq where-    paramsParser "time" = Just $ const $ return TimeReq -    paramsParser _ = Nothing+    parseParams "time" = Just $ const $ return TimeReq +    parseParams _ = 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+respond :: Respond TimeReq IO TimeRes+respond TimeReq = Right . TimeRes <$> getCurrentTime  main :: IO ()-main = tcpServer V2 (serverSettings 31337 "127.0.0.1") srv+main = jsonRpcTcpServer V2 (serverSettings 31337 "::1") respond dummySrv+ ```  Client Example@@ -81,9 +54,12 @@  ``` haskell {-# LANGUAGE OverloadedStrings #-}+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Trans+import Data.Aeson 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@@ -92,7 +68,7 @@ import System.Locale  data TimeReq = TimeReq-data TimeRes = TimeRes UTCTime+data TimeRes = TimeRes { timeRes :: UTCTime }  instance ToRequest TimeReq where     requestMethod TimeReq = "time"@@ -101,24 +77,20 @@     toJSON TimeReq = emptyArray  instance FromResponse TimeRes where-    parseResult "time" = withText "time" $ \t -> case f t of-        Nothing -> fail "Could not parse time"+    parseResult "time" = Just $ withText "time" $ \t -> case f t of         Just t' -> return $ TimeRes t'+        Nothing -> mzero       where         f t = parseTime defaultTimeLocale "%c" (T.unpack t)+    parseResult _ = Nothing -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+req :: JsonRpcT IO UTCTime+req = sendRequest TimeReq >>= liftIO . atomically >>= \ts -> case ts of+    Left e -> error $ fromError e+    Right (Just (TimeRes r)) -> return r+    _ -> error "Could not parse response"  main :: IO ()-main = tcpClient V2 True (clientSettings 31337 "127.0.0.1") cli >>= print+main = jsonRpcTcpClient V2 (clientSettings 31337 "::1") dummyRespond .+    replicateM_ 4 $ req >>= liftIO . print >> liftIO (threadDelay 1000000) ```

@@ -1,12 +1,12 @@ name:                   json-rpc-version:                0.2.1.6+version:                0.3.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.+  This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and 1.0. It+  provides an interface that combines a JSON-RPC client and server. It can set+  and keep track of request ids to parse responses. There is support for+  sending and receiving notifications.  You may use any underlying transport.+  Basic TCP client and server provided. homepage:               https://github.com/xenog/json-rpc license:                PublicDomain license-file:           UNLICENSE@@ -24,12 +24,12 @@ source-repository this   type:                 git   location:             https://github.com/xenog/json-rpc.git-  tag:                  0.2.1.5+  tag:                  0.3.0.0  library   exposed-modules:      Network.JsonRpc   other-modules:        Network.JsonRpc.Data,-                        Network.JsonRpc.Conduit+                        Network.JsonRpc.Interface   build-depends:        base                        >= 4.6      && < 5,                         aeson                       >= 0.7      && < 0.9,                         attoparsec                  >= 0.11,@@ -58,16 +58,12 @@                         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,+                        json-rpc,                         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,+                        stm                         >= 2.4      && < 2.5,+                        stm-conduit                 >= 2.5      && < 2.6,                         QuickCheck                  >= 2.6      && < 2.8,                         test-framework              >= 0.8      && < 0.9,                         test-framework-quickcheck2  >= 0.3      && < 0.4

@@ -7,7 +7,7 @@ ) where  import Control.Applicative-import Data.Aeson.Types hiding (Error)+import Data.Aeson.Types import qualified Data.HashMap.Strict as M import Data.Text (Text) import qualified Data.Text as T@@ -17,10 +17,10 @@  -- | A pair of a request and its corresponding response. -- Id and version should match.-data ReqRes q r = ReqRes !(Request q) !(Response r)+data ReqRes = ReqRes !Request !Response     deriving (Show, Eq) -instance Arbitrary (ReqRes Value Value) where+instance Arbitrary ReqRes where     arbitrary = do         rq <- arbitrary         rs <- arbitrary@@ -33,36 +33,32 @@ 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 Request where+    arbitrary = Request <$> arbitrary <*> arbitrary <*> arbitrary <*> 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 Notif where+    arbitrary = Notif <$> arbitrary <*> arbitrary <*> arbitrary -instance Arbitrary r => Arbitrary (Response r) where+instance Arbitrary Response where     arbitrary = Response <$> arbitrary <*> arbitrary <*> arbitrary  instance Arbitrary ErrorObj where-    arbitrary = ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary-                         <*> arbitrary <*> arbitrary+    arbitrary = oneof+        [ ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary+        , ErrorVal <$> 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 RpcError where+    arbitrary = RpcError <$> arbitrary <*> arbitrary <*> arbitrary +instance Arbitrary Message where+    arbitrary = oneof+        [ MsgRequest  <$> arbitrary+        , MsgNotif    <$> arbitrary+        , MsgResponse <$> arbitrary+        , MsgError    <$> arbitrary+        ]+ instance Arbitrary Id where     arbitrary = oneof [IdInt <$> arbitrary, IdTxt <$> arbitrary] @@ -71,7 +67,8 @@         val = oneof [ toJSON <$> (arbitrary :: Gen String)                     , toJSON <$> (arbitrary :: Gen Int)                     , toJSON <$> (arbitrary :: Gen Double)-                    , toJSON <$> (arbitrary :: Gen Bool) ]+                    , toJSON <$> (arbitrary :: Gen Bool)+                    ]         ls   = toJSON <$> listOf val         obj  = toJSON . M.fromList <$> listOf ps         ps   = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls]

@@ -3,22 +3,19 @@ {-# LANGUAGE Rank2Types #-} module Network.JsonRpc.Tests (tests) where -import Control.Concurrent+import Control.Applicative import Control.Concurrent.Async import Control.Concurrent.STM-import Control.Exception hiding (assert)+import qualified Data.ByteString.Lazy as L+import Data.Conduit.TMChan import Control.Monad+import Control.Monad.Trans+import Data.Aeson 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.Either import Data.Maybe-import Data.Text (Text) import Network.JsonRpc-import Network.JsonRpc.Arbitrary+import Network.JsonRpc.Arbitrary() import Test.QuickCheck import Test.QuickCheck.Monadic import Test.Framework@@ -28,398 +25,128 @@ tests =     [ testGroup "JSON-RPC Requests"         [ testProperty "Check fields"-            (reqFields :: Request Value -> Bool)+            (reqFields :: Request -> Bool)         , testProperty "Encode/decode"-            (reqDecode :: Request Value -> Bool)+            (testEncodeDecode :: Request -> Bool)         ]     , testGroup "JSON-RPC Notifications"         [ testProperty "Check fields"-            (notifFields :: Notif Value -> Bool)+            (notifFields :: Notif -> Bool)         , testProperty "Encode/decode"-            (notifDecode :: Notif Value -> Bool)+            (testEncodeDecode :: Notif -> Bool)         ]     , testGroup "JSON-RPC Responses"         [ testProperty "Check fields"-            (resFields :: Response Value -> Bool)+            (resFields :: Response -> 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)+            (testEncodeDecode :: Response -> 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+    , testGroup "JSON-RPC Errors"+        [ testProperty "Check fields"+            (errFields :: RpcError -> Bool)+        , testProperty "Encode/decode"+            (testEncodeDecode :: RpcError -> Bool)         ]+    , testGroup "Network"+        [ testProperty "Test server" serverTest+        , testProperty "Test client" clientTest+        ]     ] ------ 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+checkVerId :: Ver -> 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" .!= IdNull >>= guard . (==i)+    return True -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 () ()+checkFieldsReqNotif :: Ver -> Method -> Value -> 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 -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+checkFieldsReq :: Request -> Object -> Parser Bool+checkFieldsReq (Request ver m v i) = checkFieldsReqNotif ver m v i -    match rq (IncomingMsg (MsgResponse rs) (Just rq')) =-        rq { getReqId = getReqId rq' } == rq'-            && rs == g rq'-    match _ _ = False+checkFieldsNotif :: Notif -> Object -> Parser Bool+checkFieldsNotif (Notif ver m v) = checkFieldsReqNotif ver m v IdNull -    respond :: IncomingMsg () q () () -> Response r-    respond (IncomingMsg (MsgRequest rq) Nothing) = g rq-    respond _ = undefined+checkFieldsRes :: Response -> Object -> Parser Bool+checkFieldsRes (Response ver v i) o = do+    checkVerId ver i o >>= guard+    o .: "result" >>= guard . (==v)+    return True -    f rq = MsgRequest $ rq { getReqId = IdNull } :: Message q () ()-    vs = map (\(ReqRes rq _) -> rq) rr+checkFieldsErr :: RpcError -> Object -> Parser Bool+checkFieldsErr (RpcError ver e i) o = do+    checkVerId ver i o >>= guard+    o .: "error" >>= guard . (==e)+    return True -    g rq = let (ReqRes _ rs) = fromJust $ find h rr-               h (ReqRes rq' _) = getReqParams rq == getReqParams rq'-           in  rs { getResId = getReqId rq }+testFields :: ToJSON r => (Object -> Parser Bool) -> r -> Bool+testFields ck r = fromMaybe False . parseMaybe f $ toJSON r where+    f = withObject "json" ck -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+testEncodeDecode :: (Eq r, ToJSON r, FromJSON r) => r -> Bool+testEncodeDecode r = maybe False (==r) $ parseMaybe parseJSON (toJSON r) -    match (ReqRes rq _) (IncomingMsg (MsgError _) (Just rq')) =-        rq' { getReqId = getReqId rq } == rq-    match _ _ = False+reqFields :: Request -> Bool+reqFields rq = testFields (checkFieldsReq rq) rq -    respond :: IncomingMsg () q () () -> ErrorObj-    respond (IncomingMsg (MsgRequest (Request ver' _ _ i)) Nothing) =-        ErrorObj ver' "test" (getIdInt i) Null i-    respond _ = undefined+notifFields :: Notif -> Bool+notifFields nt = testFields (checkFieldsNotif nt) nt -    f (ReqRes rq _) = MsgRequest $ rq { getReqId = IdNull } :: Message q () ()+resFields :: Response -> Bool+resFields rs = testFields (checkFieldsRes rs) rs -type ClientAppConduits = AppConduits Value Value Value () () () IO-type ServerAppConduits = AppConduits () () () Value Value Value IO+errFields :: RpcError -> Bool+errFields er = testFields (checkFieldsErr er) er -sendMsgNet :: ([Message Value Value Value], Ver) -> Property-sendMsgNet (rs, ver) = monadicIO $ do+serverTest :: ([Request], Ver) -> Property+serverTest (reqs, 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)+        (bso, bsi) <- atomically $ (,) <$> newTBMChan 16 <*> newTBMChan 16+        let snk = sinkTBMChan bso False+            src = sourceTBMChan bsi+        withAsync (srv snk src) $ const $+            withAsync (sender bsi) $ const $ receiver bso []+    assert $ length rt == length reqs+    assert $ null rt || all isJust rt+    assert $ params == reverse (results 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+    r q = return $ Right (q :: Value)+    srv snk src = runJsonRpcT ver r snk src dummySrv+    sender bsi = forM_ reqs $ atomically .+        writeTBMChan bsi . L.toStrict . encode . MsgRequest+    receiver bso xs = if length xs == length reqs+        then return xs+        else liftIO (atomically $ readTBMChan bso) >>= \b -> case b of+            Just x -> do+                let res = decodeStrict' x :: Maybe Response+                receiver bso (res:xs)+            Nothing -> undefined+    params = map getReqParams reqs+    results = map $ getResult . fromJust -twoWayNet :: ([Message Value Value Value], Ver) -> Property-twoWayNet (rr, ver) = monadicIO $ do+clientTest :: ([Value], Ver) -> Property+clientTest (qs, 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+        (bso, bsi) <- atomically $ (,) <$> newTBMChan 16 <*> newTBMChan 16+        let snk = sinkTBMChan bso False+            src = sourceTBMChan bsi+            csnk = sinkTBMChan bsi False+            csrc = sourceTBMChan bso+        withAsync (srv snk src) $ const $ cli csnk csrc+    assert $ length rt == length qs+    assert $ null rt || all correct rt+    assert $ qs == results rt   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+    r q = return $ Right (q :: Value)+    srv snk src = runJsonRpcT ver r snk src dummySrv+    cli snk src = runJsonRpcT ver r snk src $+        forM qs $ sendRequest >=> liftIO . atomically+    results = map fromJust . rights+    correct (Right (Just _)) = True+    correct _ = False