json-rpc 0.4.0.0 → 0.5.0.0

raw patch · 8 files changed

+274/−198 lines, 8 filesdep +lifted-asyncdep +monad-controldep +monad-loggerdep −asyncPVP ok

version bump matches the API change (PVP)

Dependencies added: lifted-async, monad-control, monad-logger

Dependencies removed: async

API changes (from Hackage documentation)

Files

• Network/JsonRpc/Arbitrary.hs +78/−0
• Network/JsonRpc/Data.hs +19/−13
• Network/JsonRpc/Interface.hs +129/−77
• README.md +11/−7
• json-rpc.cabal +13/−8
• test/Network/JsonRpc/Arbitrary.hs +0/−78
• test/Network/JsonRpc/Tests.hs +23/−14
• test/main.hs +1/−1

@@ -0,0 +1,78 @@+{-# 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+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 = ReqRes !Request !Response+    deriving (Show, Eq)++instance Arbitrary ReqRes 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 Request where+    arbitrary = Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary Notif where+    arbitrary = Notif <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary Response where+    arbitrary = Response <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ErrorObj where+    arbitrary = oneof+        [ ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary+        , ErrorVal <$> arbitrary+        ]++instance Arbitrary Err where+    arbitrary = Err <$> 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]++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]+

@@ -30,7 +30,7 @@ , buildNotif    -- * Errors-, RpcError(..)+, Err(..) , ErrorObj(..) , fromError   -- ** Error Messages@@ -44,6 +44,7 @@ , Message(..) , Method , Id(..)+, fromId , Ver(..)  ) where@@ -165,12 +166,12 @@ buildResponse :: (Monad m, FromRequest q, ToJSON r)               => Respond q m r               -> Request-              -> m (Either RpcError Response)+              -> m (Either Err Response) buildResponse f req@(Request v _ p i) = case fromRequest req of-    Nothing -> return . Left $ RpcError v (errorInvalid p) i+    Nothing -> return . Left $ Err v (errorInvalid p) i     Just q -> do         rE <- f q-        return $ either (\e -> Left $ RpcError v e i)+        return $ either (\e -> Left $ Err v e i)                         (\r -> Right $ Response v (toJSON r) i) rE  type Respond q m r = q -> m (Either ErrorObj r)@@ -268,25 +269,25 @@ fromError (ErrorObj m _ _) = m fromError (ErrorVal v) = T.unpack $ decodeUtf8 $ L.toStrict $ encode v -data RpcError = RpcError { getErrVer  :: !Ver+data Err = Err { 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 NFData Err where+    rnf (Err v o i) = rnf v `seq` rnf o `seq` rnf i -instance FromJSON RpcError where+instance FromJSON Err where     parseJSON = withObject "error" $ \o -> do         v <- parseVer o         e <- o .: "error"         i <- o .:? "id" .!= IdNull-        return $ RpcError v e i+        return $ Err v e i -instance ToJSON RpcError where-    toJSON (RpcError V1 o i) =+instance ToJSON Err where+    toJSON (Err V1 o i) =         object ["id" .= i, "result" .= Null, "error" .= o]-    toJSON (RpcError V2 o i) =+    toJSON (Err V2 o i) =         object ["id" .= i, "error" .= o, jr2]  -- | Parse error.@@ -318,7 +319,7 @@     = MsgRequest   { getMsgRequest  :: !Request  }     | MsgResponse  { getMsgResponse :: !Response }     | MsgNotif     { getMsgNotif    :: !Notif    }-    | MsgError     { getMsgError    :: !RpcError }+    | MsgError     { getMsgError    :: !Err }     deriving (Eq, Show)  instance NFData Message where@@ -372,6 +373,11 @@     toJSON (IdTxt s) = toJSON s     toJSON (IdInt n) = toJSON n     toJSON IdNull = Null++fromId :: Id -> String+fromId (IdInt i) = show i+fromId (IdTxt t) = T.unpack t+fromId IdNull = "null"  data Ver = V1 -- ^ JSON-RPC 1.0          | V2 -- ^ JSON-RPC 2.0

@@ -1,50 +1,60 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-} -- | Interface for JSON-RPC. module Network.JsonRpc.Interface ( -- * Establish JSON-RPC context   JsonRpcT , runJsonRpcT +  -- * Conduits for encoding/decoding+, decodeConduit+, encodeConduit+   -- * Communicate with remote party , sendRequest , sendNotif , receiveNotif+  -- ** Dummies+, dummyRespond+, dummySrv    -- * Transports   -- ** Client , jsonRpcTcpClient-, dummyRespond   -- ** Server , jsonRpcTcpServer-, dummySrv ) where  import Control.Applicative-import Control.Concurrent.Async+import Control.Concurrent.Async.Lifted import Control.Concurrent.STM import Control.Monad+import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.State+import Control.Monad.Trans.Control import Data.Aeson import Data.Aeson.Types (parseMaybe) import Data.Attoparsec.ByteString import Data.ByteString (ByteString)-import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8+import Data.Either import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.Conduit import qualified Data.Conduit.List as CL import Data.Conduit.Network import Data.Conduit.TMChan+import qualified Data.Text as T import Network.JsonRpc.Data -type SentRequests = HashMap Id (TMVar (Either RpcError Response))+type SentRequests = HashMap Id (TMVar (Either Err Response)) -data Session = Session { inCh     :: TBMChan (Either RpcError Message)+data Session = Session { inCh     :: TBMChan (Either Err Message)                        , outCh    :: TBMChan Message-                       , notifCh  :: TBMChan (Either RpcError Notif)+                       , notifCh  :: TBMChan (Either Err Notif)                        , lastId   :: TVar Id                        , sentReqs :: TVar SentRequests                        , rpcVer   :: Ver@@ -62,35 +72,43 @@                         <*> newTVar M.empty                         <*> return v -encodeConduit :: (ToJSON a, Monad m) => Conduit a m ByteString-encodeConduit = CL.map $ L8.toStrict . encode+encodeConduit :: MonadLogger m => Conduit Message m ByteString+encodeConduit = CL.mapM $ \m -> do+    $(logDebug) $ T.pack $ unwords $ case m of+        MsgError e -> [ "Sending error id:", fromId (getErrId e) ]+        MsgRequest q -> [ "Sending request id:", fromId (getReqId q) ]+        MsgNotif _ -> [ "Sending notification" ]+        MsgResponse r -> [ "Sending response id:", fromId (getResId r) ]+    return . L8.toStrict $ encode m -parseMessages :: Monad m-              => Ver -> Conduit ByteString m (Either RpcError Message)-parseMessages ver = evalStateT loop Nothing where+decodeConduit :: MonadLogger m+              => Ver -> Conduit ByteString m (Either Err Message)+decodeConduit 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)+                                      Just k  -> handle (k B8.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+        $(logWarn) "Error parsing incoming message"+        lift . yield . Left $ Err ver (errorParse Null) IdNull         loop     handle (Partial k) = put (Just k) >> loop     handle (Done rest v) = do-        let msg = decodeJsonRpc v+        let msg = decod v+        when (isLeft msg) $ $(logWarn) "Received invalid message"         lift $ yield msg-        if B.null rest then loop else process rest+        if B8.null rest then loop else process rest -    decodeJsonRpc v = case parseMaybe parseJSON v of+    decod v = case parseMaybe parseJSON v of         Just msg -> Right msg-        Nothing -> Left $ RpcError ver (errorInvalid v) IdNull+        Nothing -> Left $ Err ver (errorInvalid v) IdNull -processIncoming :: (FromRequest q, ToJSON r)-                => Respond q IO r -> JsonRpcT IO ()+processIncoming :: (Functor m, MonadLoggerIO m, FromRequest q, ToJSON r)+                => Respond q m r -> JsonRpcT m () processIncoming r = do     i <- reader inCh     o <- reader outCh@@ -98,38 +116,61 @@     s <- reader sentReqs     v <- reader rpcVer     join . liftIO . atomically $ readTBMChan i >>= \inc -> case inc of-        Nothing -> return $ return ()+        Nothing -> return $ do+            $(logDebug) "Closed incoming channel"+            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 (MsgNotif t)) -> do+            writeTBMChan n (Right t)+            return $ do+                $(logDebug) "Received notification"+                processIncoming r         Just (Right (MsgRequest q)) -> return $ do-            msg <- either MsgError MsgResponse <$> liftIO (buildResponse r q)+            $(logDebug) $ T.pack $ unwords+                [ "Received request id:", fromId (getReqId q) ]+            msg <- lift $ either MsgError MsgResponse <$> 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+            let pM = x `M.lookup` m+            case pM of                 Nothing ->-                    writeTBMChan o . MsgError $ RpcError v (errorId x) IdNull+                    writeTBMChan o . MsgError $ Err 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+            return $ do+                case pM of+                    Nothing -> $(logWarn) $ T.pack $ unwords+                        [ "Got response with unkwnown id:", fromId x ]+                    _ -> $(logDebug) $ T.pack $ unwords+                        [ "Received response id:", fromId x ]+                processIncoming r+        Just (Right (MsgError err@(Err _ _ IdNull))) -> do             writeTBMChan n $ Left err-            return $ processIncoming r-        Just (Right (MsgError err@(RpcError _ _ x))) -> do+            return $ do+                $(logWarn) "Got standalone error message"+                processIncoming r+        Just (Right (MsgError err@(Err _ _ x))) -> do             m <- readTVar s-            case x `M.lookup` m of+            let pM = x `M.lookup` m+            case pM of                 Nothing ->-                    writeTBMChan o . MsgError $ RpcError v (errorId x) IdNull+                    writeTBMChan o . MsgError $ Err v (errorId x) IdNull                 Just p ->                     writeTVar s (x `M.delete` m) >> putTMVar p (Left err)-            return $ processIncoming r+            return $ do+                case pM of+                    Nothing -> $(logWarn) $ T.pack $ unwords+                        [ "Got error with unknown id:", fromId x ]+                    _ -> $(logWarn) $ T.pack $ unwords+                        [ "Received error id:", fromId x ]+                processIncoming r  -- | Returns Right Nothing if could not parse response.-sendRequest :: (ToJSON q, ToRequest q, FromResponse r, MonadIO m)+sendRequest :: (MonadLoggerIO m, ToJSON q, ToRequest q, FromResponse r)             => q -> JsonRpcT m (Either ErrorObj (Maybe r)) sendRequest q = do     v <- reader rpcVer@@ -152,7 +193,7 @@             Just x -> return . Right $ Just x  -- | Send notification. Will not block.-sendNotif :: (ToJSON no, ToNotif no, MonadIO m) => no -> JsonRpcT m ()+sendNotif :: (ToJSON no, ToNotif no, MonadLoggerIO m) => no -> JsonRpcT m () sendNotif n = do     o <- reader outCh     v <- reader rpcVer@@ -162,7 +203,7 @@ -- | Receive notifications from peer. Will not block. -- Returns Nothing if incoming channel is closed and empty. -- Result is Right Nothing if it failed to parse notification.-receiveNotif :: (MonadIO m, FromNotif n)+receiveNotif :: (MonadLoggerIO m, FromNotif n)              => JsonRpcT m (Maybe (Either ErrorObj (Maybe n))) receiveNotif = do     c <- reader notifCh@@ -173,26 +214,26 @@             Nothing -> 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+-- | Create JSON-RPC session around conduits from transport+-- layer. When context exits session disappears.+runJsonRpcT :: ( MonadLoggerIO m, MonadBaseControl IO m+               , FromRequest q, ToJSON r+               )+            => Ver                    -- ^ JSON-RPC version+            -> Respond q m r          -- ^ Respond to incoming requests+            -> Sink Message m ()      -- ^ Sink to send messages+            -> Source m (Either Err Message)+            -- ^ Source of incoming messages+            -> JsonRpcT m a           -- ^ JSON-RPC action+            -> m a                    -- ^ Output of action runJsonRpcT ver r snk src f = do-    qs <- atomically $ initSession ver+    qs <- liftIO . atomically $ initSession ver     let inSnk  = sinkTBMChan (inCh qs) True         outSrc = sourceTBMChan (outCh qs)-    withAsync (fromNet inSnk) $ const $-        withAsync (toNet outSrc) $ const $+    withAsync (src $$ inSnk) $ const $+        withAsync (outSrc $$ snk) $ 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@@ -210,36 +251,47 @@             _  -> 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 true in most cases.-dummySrv :: MonadIO m => JsonRpcT m ()+-- | Dummy action for servers not expecting clients to send notifications,+-- which is true in most cases.+dummySrv :: MonadLoggerIO m => JsonRpcT m () dummySrv = receiveNotif >>= \nM -> case nM of         Just n -> (n :: Either ErrorObj (Maybe ())) `seq` dummySrv         Nothing -> return ()  -- | Respond function for systems that do not reply to requests, as usual -- in clients.-dummyRespond :: Monad m => Respond () m ()+dummyRespond :: MonadLoggerIO m => Respond () m () dummyRespond = const . return $ Right () ++--+-- Transports+--++-- | TCP client transport for JSON-RPC.+jsonRpcTcpClient+    :: ( MonadLoggerIO m, MonadBaseControl IO m+       , FromRequest q, ToJSON r+       )+    => Ver            -- ^ JSON-RPC version+    -> ClientSettings -- ^ Connection settings+    -> Respond q m r  -- ^ Respond to incoming requests+    -> JsonRpcT m a   -- ^ JSON-RPC action+    -> m a            -- ^ Output of action+jsonRpcTcpClient ver cs r f = runGeneralTCPClient cs $ \ad ->+    runJsonRpcT ver r+        (encodeConduit =$ cr =$ appSink ad)+        (appSource ad $= ln $= decodeConduit ver) f++-- | TCP server transport for JSON-RPC.+jsonRpcTcpServer+    :: ( MonadLoggerIO m, MonadBaseControl IO m+       , FromRequest q, ToJSON r)+    => Ver             -- ^ JSON-RPC version+    -> ServerSettings  -- ^ Connection settings+    -> Respond q m r   -- ^ Respond to incoming requests+    -> JsonRpcT m ()   -- ^ Action to perform on connecting client thread+    -> m a+jsonRpcTcpServer ver ss r f = runGeneralTCPServer ss $ \cl ->+    runJsonRpcT ver r+        (encodeConduit =$ cr =$ appSink cl)+        (appSource cl $= ln $= decodeConduit ver) f

@@ -24,6 +24,8 @@ ``` haskell {-# LANGUAGE OverloadedStrings #-} import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Logger import Data.Aeson.Types hiding (Error) import Data.Conduit.Network import Data.Time.Clock@@ -41,12 +43,12 @@ instance ToJSON TimeRes where     toJSON (TimeRes t) = toJSON $ formatTime defaultTimeLocale "%c" t -respond :: Respond TimeReq IO TimeRes-respond TimeReq = Right . TimeRes <$> getCurrentTime+respond :: (Functor m, MonadLoggerIO m) => Respond TimeReq m TimeRes+respond TimeReq = Right . TimeRes <$> liftIO getCurrentTime  main :: IO ()-main = jsonRpcTcpServer V2 (serverSettings 31337 "::1") respond dummySrv-+main = runStderrLoggingT $+    jsonRpcTcpServer V2 (serverSettings 31337 "::1") respond dummySrv ```  Client Example@@ -59,6 +61,7 @@ import Control.Concurrent import Control.Monad import Control.Monad.Trans+import Control.Monad.Logger import Data.Aeson import Data.Aeson.Types hiding (Error) import Data.Conduit.Network@@ -85,13 +88,14 @@         f t = parseTime defaultTimeLocale "%c" (T.unpack t)     parseResult _ = Nothing -req :: JsonRpcT IO UTCTime+req :: MonadLoggerIO m => JsonRpcT m UTCTime req = sendRequest TimeReq >>= \ts -> case ts of     Left e -> error $ fromError e     Right (Just (TimeRes r)) -> return r     _ -> error "Could not parse response"  main :: IO ()-main = jsonRpcTcpClient V2 (clientSettings 31337 "::1") dummyRespond .-    replicateM_ 4 $ req >>= liftIO . print >> liftIO (threadDelay 1000000)+main = runStderrLoggingT $+    jsonRpcTcpClient V2 (clientSettings 31337 "::1") dummyRespond .+        replicateM_ 4 $ req >>= liftIO . print >> liftIO (threadDelay 1000000) ```

@@ -1,5 +1,5 @@ name:                   json-rpc-version:                0.4.0.0+version:                0.5.0.0 synopsis:               Fully-featured JSON-RPC 2.0 library description:   This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and 1.0. It@@ -24,27 +24,31 @@ source-repository this   type:                 git   location:             https://github.com/xenog/json-rpc.git-  tag:                  0.4.0.0+  tag:                  0.5.0.0  library-  exposed-modules:      Network.JsonRpc+  exposed-modules:      Network.JsonRpc,+                        Network.JsonRpc.Arbitrary   other-modules:        Network.JsonRpc.Data,                         Network.JsonRpc.Interface   build-depends:        base                        >= 4.6      && < 5,                         aeson                       >= 0.7      && < 0.10,                         attoparsec                  >= 0.11,-                        async                       >= 2.0      && < 2.1,                         bytestring                  >= 0.10     && < 0.11,                         conduit                     >= 1.2      && < 1.3,                         conduit-extra               >= 1.1      && < 1.2,                         deepseq                     >= 1.3      && < 1.5,                         hashable                    >= 1.1      && < 1.3,+                        lifted-async                >= 0.7      && < 0.8,+                        monad-control               >= 0.3      && < 1.1,+                        monad-logger                >= 0.3      && < 0.4,                         mtl                         >= 2.1      && < 2.3,                         stm                         >= 2.4      && < 2.5,                         stm-conduit                 >= 2.5      && < 2.7,                         text                        >= 0.11     && < 1.3,                         transformers                >= 0.3,-                        unordered-containers        >= 0.2      && < 0.3+                        unordered-containers        >= 0.2      && < 0.3,+                        QuickCheck                  >= 2.6      && < 2.9   default-language:     Haskell2010   ghc-options:          -Wall @@ -52,13 +56,14 @@   hs-source-dirs:       test   type:                 exitcode-stdio-1.0    main-is:              main.hs-  other-modules:        Network.JsonRpc.Tests,-                        Network.JsonRpc.Arbitrary+  other-modules:        Network.JsonRpc.Tests   build-depends:        base                        >= 4.6      && < 5,                         aeson                       >= 0.7      && < 0.10,-                        async                       >= 2.0      && < 2.1,                         bytestring                  >= 0.10     && < 0.11,+                        conduit                     >= 1.2      && < 1.3,                         json-rpc,+                        lifted-async                >= 0.7      && < 0.8,+                        monad-logger                >= 0.3      && < 0.4,                         mtl                         >= 2.1      && < 2.3,                         text                        >= 0.11     && < 1.3,                         unordered-containers        >= 0.2      && < 0.3,

@@ -1,78 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | Arbitrary instances and data types for use in test suites.-module Network.JsonRpc.Arbitrary-( -- * Arbitrary Data-  ReqRes(..)-) where--import Control.Applicative-import Data.Aeson.Types-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 = ReqRes !Request !Response-    deriving (Show, Eq)--instance Arbitrary ReqRes 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 Request where-    arbitrary = Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary--instance Arbitrary Notif where-    arbitrary = Notif <$> arbitrary <*> arbitrary <*> arbitrary--instance Arbitrary Response where-    arbitrary = Response <$> arbitrary <*> arbitrary <*> arbitrary--instance Arbitrary ErrorObj where-    arbitrary = oneof-        [ ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary-        , ErrorVal <$> 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]--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]-

@@ -4,11 +4,14 @@ module Network.JsonRpc.Tests (tests) where  import Control.Applicative-import Control.Concurrent.Async+import Control.Concurrent.Async.Lifted import Control.Concurrent.STM import qualified Data.ByteString.Lazy as L+import Data.Conduit+import qualified Data.Conduit.List as CL import Data.Conduit.TMChan import Control.Monad+import Control.Monad.Logger import Control.Monad.Trans import Data.Aeson import Data.Aeson.Types@@ -43,9 +46,9 @@         ]     , testGroup "JSON-RPC Errors"         [ testProperty "Check fields"-            (errFields :: RpcError -> Bool)+            (errFields :: Err -> Bool)         , testProperty "Encode/decode"-            (testEncodeDecode :: RpcError -> Bool)+            (testEncodeDecode :: Err -> Bool)         ]     , testGroup "Network"         [ testProperty "Test server" serverTest@@ -79,8 +82,8 @@     o .: "result" >>= guard . (==v)     return True -checkFieldsErr :: RpcError -> Object -> Parser Bool-checkFieldsErr (RpcError ver e i) o = do+checkFieldsErr :: Err -> Object -> Parser Bool+checkFieldsErr (Err ver e i) o = do     checkVerId ver i o >>= guard     o .: "error" >>= guard . (==e)     return True@@ -101,24 +104,27 @@ resFields :: Response -> Bool resFields rs = testFields (checkFieldsRes rs) rs -errFields :: RpcError -> Bool+errFields :: Err -> Bool errFields er = testFields (checkFieldsErr er) er  serverTest :: ([Request], Ver) -> Property serverTest (reqs, ver) = monadicIO $ do-    rt <- run $ do-        (bso, bsi) <- atomically $ (,) <$> newTBMChan 16 <*> newTBMChan 16+    rt <- run $ runNoLoggingT $ do+        (bso, bsi) <- liftIO . atomically $ (,) <$> newTBMChan 16+                                                <*> newTBMChan 16         let snk = sinkTBMChan bso False             src = sourceTBMChan bsi         withAsync (srv snk src) $ const $-            withAsync (sender bsi) $ const $ receiver bso []+            withAsync (sender bsi) $ const $+                receiver bso []     assert $ length rt == length reqs     assert $ null rt || all isJust rt     assert $ params == reverse (results rt)   where     r q = return $ Right (q :: Value)-    srv snk src = runJsonRpcT ver r snk src dummySrv-    sender bsi = forM_ reqs $ atomically .+    srv snk src = runJsonRpcT ver r+        (encodeConduit =$ snk) (src =$ decodeConduit ver) dummySrv+    sender bsi = forM_ reqs $ liftIO . atomically .         writeTBMChan bsi . L.toStrict . encode . MsgRequest     receiver bso xs = if length xs == length reqs         then return xs@@ -132,13 +138,16 @@  clientTest :: ([Value], Ver) -> Property clientTest (qs, ver) = monadicIO $ do-    rt <- run $ do-        (bso, bsi) <- atomically $ (,) <$> newTBMChan 16 <*> newTBMChan 16+    rt <- run $ runNoLoggingT $ do+        (bso, bsi) <- liftIO . 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+        withAsync (srv snk src) $ const $ cli+            (CL.map Right =$ csnk)+            (csrc $= CL.map Right)     assert $ length rt == length qs     assert $ null rt || all correct rt     assert $ qs == results rt

@@ -2,5 +2,5 @@ import Network.JsonRpc.Tests  main :: IO ()-main = defaultMain (tests)+main = defaultMain tests