diff --git a/Network/JsonRpc/Arbitrary.hs b/Network/JsonRpc/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/Network/JsonRpc/Arbitrary.hs @@ -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] + diff --git a/Network/JsonRpc/Data.hs b/Network/JsonRpc/Data.hs --- a/Network/JsonRpc/Data.hs +++ b/Network/JsonRpc/Data.hs @@ -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 diff --git a/Network/JsonRpc/Interface.hs b/Network/JsonRpc/Interface.hs --- a/Network/JsonRpc/Interface.hs +++ b/Network/JsonRpc/Interface.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) ``` diff --git a/json-rpc.cabal b/json-rpc.cabal --- a/json-rpc.cabal +++ b/json-rpc.cabal @@ -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, diff --git a/test/Network/JsonRpc/Arbitrary.hs b/test/Network/JsonRpc/Arbitrary.hs deleted file mode 100644 --- a/test/Network/JsonRpc/Arbitrary.hs +++ /dev/null @@ -1,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] - diff --git a/test/Network/JsonRpc/Tests.hs b/test/Network/JsonRpc/Tests.hs --- a/test/Network/JsonRpc/Tests.hs +++ b/test/Network/JsonRpc/Tests.hs @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -2,5 +2,5 @@ import Network.JsonRpc.Tests main :: IO () -main = defaultMain (tests) +main = defaultMain tests