From 836d528fde5dbf59c82d8ebf9e148b7e00227192 Mon Sep 17 00:00:00 2001 From: martyall Date: Mon, 9 Mar 2020 19:59:26 -0700 Subject: [PATCH 1/7] wip --- Makefile | 2 +- .../kv-test/KVStore/Test/KVSpec.hs | 31 ++++----- hs-tendermint-client/package.yaml | 10 ++- .../src/Network/Tendermint/Client.hs | 63 +++++++++++++++++-- .../Tendermint/Client/Internal/RPCClient.hs | 8 ++- 5 files changed, 85 insertions(+), 29 deletions(-) diff --git a/Makefile b/Makefile index 876ac36e..defa9c1d 100644 --- a/Makefile +++ b/Makefile @@ -93,7 +93,7 @@ deploy-nameservice-test: install ## run the nameservice docker network for testi # Tests ##################### -test-kv-store: install ## Run the test suite for the client interface +test-kv-store: ## Run the test suite for the client interface stack test hs-tendermint-client test-simple-storage: install ## Run the test suite for the simple-storage example application diff --git a/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs b/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs index 69f09091..e581760c 100644 --- a/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs +++ b/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs @@ -4,12 +4,10 @@ import Control.Concurrent (forkIO) import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar) import Control.Lens (to, (^.)) -import Control.Lens.Fold ((^?)) import Control.Monad (void) import Control.Monad.Catch (try) import qualified Data.Aeson as A import Data.Aeson.Encode.Pretty (encodePretty) -import qualified Data.Aeson.Lens as A import Data.ByteArray.Base64String (Base64String) import qualified Data.ByteArray.Base64String as Base64 import qualified Data.ByteArray.HexString as Hex @@ -17,6 +15,9 @@ import Data.ByteString (ByteString) import Data.Default.Class (def) import Data.Either (isRight) --import Data.HashSet (difference, fromList) +import Control.Monad.IO.Class (liftIO) +import Data.Conduit (awaitForever, runConduit, + (.|)) import Data.String.Conversions (cs) import Data.Text (Text) import GHC.Generics (Generic) @@ -141,28 +142,18 @@ testInit = do pure $ TestEnv expectedEventsMVar resultEventsMVar [] addEventToCheck :: ToEvent a => TestEnv -> a -> IO () -addEventToCheck (TestEnv mvexpected mvres ses) ev = do +addEventToCheck (TestEnv mvexpected _ ses) ev = do modifyMVar_ mvexpected $ \es -> pure $ es <> [A.toJSON . toEvent $ ev] let evType = eventType (toEvent ev) if evType`elem` ses then pure () - else startNewListener evType + else void $ startNewListener evType where startNewListener evType = let subReq = RPC.RequestSubscribe ("tm.event = 'Tx' AND " <> evType <> " EXISTS") - forkTendermintM = void . forkIO . void . runRPC - in forkTendermintM $ RPC.subscribe subReq (handler evType) - handler evType res = case res ^? txEvents of - Nothing -> pure () - Just v -> case A.fromJSON v of - A.Error _ -> error ("Failed to parse\n" <> cs (A.encode v) ) - A.Success evs -> - let filterFn v' = evType == eventType v' - filteredEvs = filter filterFn evs - in modifyMVar_ mvres $ \es -> pure $ es <> map A.toJSON filteredEvs - txEvents = A.key "result" - . A.key "data" - . A.key "value" - . A.key "TxResult" - . A.key "result" - . A.key "events" + eventPrinter = awaitForever $ \a -> + let msg = cs . A.encode $ a + prefix = "Printing in Conduit: " + in liftIO . putStrLn $ prefix <> msg + forkTendermintM = forkIO . runRPC . runConduit + in forkTendermintM $ RPC.subscribe subReq .| eventPrinter diff --git a/hs-tendermint-client/package.yaml b/hs-tendermint-client/package.yaml index b1548aab..1ef57582 100644 --- a/hs-tendermint-client/package.yaml +++ b/hs-tendermint-client/package.yaml @@ -32,16 +32,24 @@ dependencies: - exceptions - data-default-class + library: source-dirs: src dependencies: - aeson-casing + - conduit - hs-abci-types - http-client - http-conduit + - lens + - lens-aeson - mtl - random + - stm + - stm-conduit + - string-conversions - text + - transformers - websockets - wuss ghc-options: @@ -69,10 +77,10 @@ tests: - -with-rtsopts=-N dependencies: - aeson-pretty + - conduit - hs-abci-types - hs-tendermint-client - hspec - - lens-aeson - lens - text - string-conversions diff --git a/hs-tendermint-client/src/Network/Tendermint/Client.hs b/hs-tendermint-client/src/Network/Tendermint/Client.hs index 8df188bd..d411d458 100644 --- a/hs-tendermint-client/src/Network/Tendermint/Client.hs +++ b/hs-tendermint-client/src/Network/Tendermint/Client.hs @@ -8,8 +8,15 @@ module Network.Tendermint.Client ) where +import Control.Concurrent.STM.TQueue (newTQueueIO, + writeTQueue) +import Control.Lens ((^?)) +import Control.Monad.Catch (throwM) +import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ReaderT, runReaderT) +import Control.Monad.STM (atomically) +import Control.Monad.Trans (lift) import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, @@ -17,11 +24,15 @@ import Data.Aeson (FromJSON (..), import qualified Data.Aeson as Aeson import Data.Aeson.Casing (aesonDrop, snakeCase) +import qualified Data.Aeson.Lens as AL import qualified Data.ByteArray.Base64String as Base64 import Data.ByteArray.HexString (HexString) import Data.ByteString (ByteString) +import Data.Conduit (ConduitT) +import Data.Conduit.TQueue (sourceTQueue) import Data.Default.Class (Default (..)) import Data.Int (Int64) +import Data.String.Conversions (cs) import Data.Text (Text) import Data.Word (Word32) import GHC.Generics (Generic) @@ -242,13 +253,55 @@ instance FromJSON ResultABCIInfo where -- Subscribe -------------------------------------------------------------------------------- +data TxResultEvent a = TxEvent + { txEventBlockHeight :: FieldTypes.WrappedVal Int64 + , txEventTxIndex :: Int64 + , txEventEvents :: a + } deriving (Generic) + +instance ToJSON a => ToJSON (TxResultEvent a) where + toJSON = genericToJSON $ defaultRPCOptions "txEvent" + +instance FromJSON (TxResultEvent [FieldTypes.Event]) where + parseJSON val = do + let mtxRes = val ^? AL.key "result" + . AL.key "data" + . AL.key "value" + . AL.key "TxResult" + . AL._Object + txRes <- maybe (fail "key not found: result.data.value.TxResult") pure mtxRes + height <- txRes Aeson..: "height" + idx <- txRes Aeson..: "index" + res' <- txRes Aeson..: "result" + es <- res' Aeson..: "events" + pure TxEvent + { txEventBlockHeight = height + , txEventTxIndex = idx + , txEventEvents = es + } + -- | invokes [/subscribe](https://tendermint.com/rpc/#subscribe) rpc call -- https://github.com/tendermint/tendermint/blob/master/rpc/core/events.go#L17 -subscribe :: RequestSubscribe -> (Aeson.Value -> IO ()) -> TendermintM ResultSubscribe -subscribe req handler = do - RPC.remoteWS (RPC.MethodName "subscribe") req handler - pure ResultSubscribe - +subscribe + :: RequestSubscribe + -> ConduitT () (TxResultEvent [FieldTypes.Event]) TendermintM () +subscribe req = do + queue <- liftIO newTQueueIO + let handler (val :: Aeson.Value) = + let isEmptyResult = val ^? AL.key "result" == Just (Aeson.Object mempty) + in if isEmptyResult + then do + putStrLn "Got Empty Result" + pure () + else case Aeson.eitherDecode . Aeson.encode $ val of + Left err -> do + putStrLn . cs . Aeson.encode $ val + throwM (RPC.ParsingException err) + Right a -> do + putStrLn "Got NonEmpty Result" + atomically $ writeTQueue queue a + lift $ RPC.remoteWS (RPC.MethodName "subscribe") req handler + sourceTQueue queue newtype RequestSubscribe = RequestSubscribe { requestSubscribeQuery :: Text diff --git a/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs b/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs index 19a91b77..54e6a91b 100644 --- a/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs +++ b/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs @@ -136,10 +136,14 @@ remoteWS method input handler = do msg = WS.Binary $ Aeson.encode rpcRequest WS.sendDataMessage c msg void . forever $ do - message <- WS.receiveData c >>= decodeRPCResponse + bs <- WS.receiveData c + message <- decodeRPCResponse bs handler message decodeRPCResponse bs = case Aeson.eitherDecodeStrict bs of - Left err -> throwM $ ParsingException err + Left err -> do + print bs + throwM $ ParsingException err + Right response -> pure response From 7f3c5e5846c7284250b7d1bfde8826e7d419b8af Mon Sep 17 00:00:00 2001 From: martyall Date: Mon, 9 Mar 2020 22:40:22 -0700 Subject: [PATCH 2/7] appears to be working --- .../kv-test/KVStore/Test/KVSpec.hs | 27 ++++++++++--------- hs-tendermint-client/package.yaml | 1 + .../src/Network/Tendermint/Client.hs | 13 +++------ .../Tendermint/Client/Internal/RPCClient.hs | 13 +++++---- 4 files changed, 25 insertions(+), 29 deletions(-) diff --git a/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs b/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs index e581760c..c34a08e7 100644 --- a/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs +++ b/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs @@ -4,25 +4,25 @@ import Control.Concurrent (forkIO) import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar) import Control.Lens (to, (^.)) -import Control.Monad (void) +import Control.Monad (replicateM, void) import Control.Monad.Catch (try) +import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteArray.Base64String (Base64String) import qualified Data.ByteArray.Base64String as Base64 import qualified Data.ByteArray.HexString as Hex import Data.ByteString (ByteString) -import Data.Default.Class (def) -import Data.Either (isRight) ---import Data.HashSet (difference, fromList) -import Control.Monad.IO.Class (liftIO) import Data.Conduit (awaitForever, runConduit, (.|)) +import Data.Default.Class (def) +import Data.Either (isRight) import Data.String.Conversions (cs) import Data.Text (Text) import GHC.Generics (Generic) import qualified Network.ABCI.Types.Messages.Response as Response import qualified Network.Tendermint.Client as RPC +import System.Random (randomIO) import Tendermint.SDK.BaseApp.Events (Event (..), ToEvent (..)) import Test.Hspec @@ -46,15 +46,17 @@ spec = do result `shouldSatisfy` isRight it "Can submit a async tx and the response code is 0 (success)" $ \tenv -> do - let asyncTxReq = RPC.RequestBroadcastTxAsync { RPC.requestBroadcastTxAsyncTx = encodeTx "abcd" } - addEventToCheck tenv $ mkAppEvent "abcd" + a <- fmap cs . replicateM 10 $ randomIO @Char + let asyncTxReq = RPC.RequestBroadcastTxAsync { RPC.requestBroadcastTxAsyncTx = encodeTx a } + addEventToCheck tenv $ mkAppEvent (cs a) -- async returns nothing resp <- runRPC $ RPC.broadcastTxAsync asyncTxReq RPC.resultBroadcastTxCode resp `shouldBe` 0 it "Can submit a sync tx and the response code is 0 (success)" $ \tenv -> do - let txReq = RPC.RequestBroadcastTxSync { RPC.requestBroadcastTxSyncTx = encodeTx "efgh" } - addEventToCheck tenv $ mkAppEvent "efgh" + a <- fmap cs . replicateM 10 $ randomIO @Char + let txReq = RPC.RequestBroadcastTxSync { RPC.requestBroadcastTxSyncTx = encodeTx a } + addEventToCheck tenv $ mkAppEvent (cs a) -- sync only returns a CheckTx resp <- runRPC $ RPC.broadcastTxSync txReq RPC.resultBroadcastTxCode resp `shouldBe` 0 @@ -62,8 +64,9 @@ spec = do it "Can submit a commit tx, make sure the response code is 0 (success), and get the result(s)" $ \tenv -> do -- /broadcast_tx_commit -- set name key - let broadcastTxReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeTx "name=satoshi" } + a <- fmap cs . replicateM 10 $ randomIO @Char addEventToCheck tenv $ mkAppEvent "name" + let broadcastTxReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeTx $ "name=" <> a } broadcastResp <- runRPC $ RPC.broadcastTxCommit broadcastTxReq let deliverResp = RPC.resultBroadcastTxCommitDeliverTx broadcastResp deliverRespCode = deliverResp ^. Response._deliverTxCode @@ -81,8 +84,8 @@ spec = do RPC.abciQuery queryReqWProof let foundName = queryResp ^. Response._queryValue . to decodeName foundNameWProof = queryRespWProof ^. Response._queryValue . to decodeName - foundName `shouldBe` "satoshi" - foundNameWProof `shouldBe` "satoshi" + foundName `shouldBe` a + foundNameWProof `shouldBe` a -- check with /tx endpoint (w+w/o proof) let hash = RPC.resultBroadcastTxCommitHash $ broadcastResp -- convert hex to base64 diff --git a/hs-tendermint-client/package.yaml b/hs-tendermint-client/package.yaml index 1ef57582..ecf907fe 100644 --- a/hs-tendermint-client/package.yaml +++ b/hs-tendermint-client/package.yaml @@ -83,5 +83,6 @@ tests: - hspec - lens - text + - random - string-conversions - hs-abci-sdk diff --git a/hs-tendermint-client/src/Network/Tendermint/Client.hs b/hs-tendermint-client/src/Network/Tendermint/Client.hs index d411d458..b4996451 100644 --- a/hs-tendermint-client/src/Network/Tendermint/Client.hs +++ b/hs-tendermint-client/src/Network/Tendermint/Client.hs @@ -32,7 +32,6 @@ import Data.Conduit (ConduitT) import Data.Conduit.TQueue (sourceTQueue) import Data.Default.Class (Default (..)) import Data.Int (Int64) -import Data.String.Conversions (cs) import Data.Text (Text) import Data.Word (Word32) import GHC.Generics (Generic) @@ -290,16 +289,10 @@ subscribe req = do let handler (val :: Aeson.Value) = let isEmptyResult = val ^? AL.key "result" == Just (Aeson.Object mempty) in if isEmptyResult - then do - putStrLn "Got Empty Result" - pure () + then pure () else case Aeson.eitherDecode . Aeson.encode $ val of - Left err -> do - putStrLn . cs . Aeson.encode $ val - throwM (RPC.ParsingException err) - Right a -> do - putStrLn "Got NonEmpty Result" - atomically $ writeTQueue queue a + Left err -> throwM (RPC.ParsingException err) + Right a -> atomically $ writeTQueue queue a lift $ RPC.remoteWS (RPC.MethodName "subscribe") req handler sourceTQueue queue diff --git a/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs b/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs index 54e6a91b..96c39e51 100644 --- a/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs +++ b/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs @@ -1,6 +1,7 @@ module Network.Tendermint.Client.Internal.RPCClient where import Control.Applicative ((<|>)) +import Control.Concurrent (forkIO) import Control.Exception (Exception) import Control.Monad (forever, void) import Control.Monad.Catch (throwM) @@ -125,9 +126,9 @@ remoteWS method input handler = do port = fromInteger $ toInteger cPort tlsPort = fromInteger $ toInteger port path = "/websocket" - if tlsEnabled - then void . liftIO $ runSecureClient host tlsPort path ws - else void . liftIO $ WS.runClient host port path ws + void . liftIO . forkIO $ if tlsEnabled + then runSecureClient host tlsPort path ws + else WS.runClient host port path ws where ws c = do rid <- abs <$> liftIO randomIO @@ -135,14 +136,12 @@ remoteWS method input handler = do rpcRequest = Request method rid rpcParams msg = WS.Binary $ Aeson.encode rpcRequest WS.sendDataMessage c msg - void . forever $ do + forever $ do bs <- WS.receiveData c message <- decodeRPCResponse bs handler message decodeRPCResponse bs = case Aeson.eitherDecodeStrict bs of - Left err -> do - print bs - throwM $ ParsingException err + Left err -> throwM $ ParsingException err Right response -> pure response From 17ccc2bfd1b99bc21bc5106df8c285d0a2edf060 Mon Sep 17 00:00:00 2001 From: martyall Date: Tue, 10 Mar 2020 10:29:29 -0700 Subject: [PATCH 3/7] tests pass --- .../kv-test/KVStore/Test/KVSpec.hs | 142 +++++++++--------- hs-tendermint-client/package.yaml | 3 +- 2 files changed, 73 insertions(+), 72 deletions(-) diff --git a/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs b/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs index c34a08e7..4dce1f38 100644 --- a/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs +++ b/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs @@ -1,29 +1,29 @@ module KVStore.Test.KVSpec (spec) where -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar (MVar, modifyMVar_, - newMVar) -import Control.Lens (to, (^.)) -import Control.Monad (replicateM, void) -import Control.Monad.Catch (try) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Aeson as A -import Data.Aeson.Encode.Pretty (encodePretty) -import Data.ByteArray.Base64String (Base64String) -import qualified Data.ByteArray.Base64String as Base64 -import qualified Data.ByteArray.HexString as Hex -import Data.ByteString (ByteString) -import Data.Conduit (awaitForever, runConduit, - (.|)) -import Data.Default.Class (def) -import Data.Either (isRight) -import Data.String.Conversions (cs) -import Data.Text (Text) -import GHC.Generics (Generic) -import qualified Network.ABCI.Types.Messages.Response as Response -import qualified Network.Tendermint.Client as RPC -import System.Random (randomIO) -import Tendermint.SDK.BaseApp.Events (Event (..), ToEvent (..)) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, modifyMVar_, + newMVar, readMVar) +import Control.Lens ((^.)) +import Control.Monad (replicateM) +import Control.Monad.Catch (try) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteArray.Base64String (Base64String) +import qualified Data.ByteArray.Base64String as Base64 +import qualified Data.ByteArray.HexString as Hex +import Data.ByteString (ByteString) +import Data.Conduit (awaitForever, + runConduit, (.|)) +import Data.Default.Class (def) +import Data.Either (isRight) +import Data.HashSet (fromList) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Network.ABCI.Types.Messages.FieldTypes as FieldTypes +import qualified Network.ABCI.Types.Messages.Response as Response +import qualified Network.Tendermint.Client as RPC +import System.Random (randomIO) import Test.Hspec @@ -46,17 +46,17 @@ spec = do result `shouldSatisfy` isRight it "Can submit a async tx and the response code is 0 (success)" $ \tenv -> do - a <- fmap cs . replicateM 10 $ randomIO @Char - let asyncTxReq = RPC.RequestBroadcastTxAsync { RPC.requestBroadcastTxAsyncTx = encodeTx a } - addEventToCheck tenv $ mkAppEvent (cs a) + a <- replicateM 10 $ randomIO @Char + addEventToCheck tenv "name" + let asyncTxReq = RPC.RequestBroadcastTxAsync { RPC.requestBroadcastTxAsyncTx = encodeTx $ "name=" <> a } -- async returns nothing resp <- runRPC $ RPC.broadcastTxAsync asyncTxReq RPC.resultBroadcastTxCode resp `shouldBe` 0 it "Can submit a sync tx and the response code is 0 (success)" $ \tenv -> do - a <- fmap cs . replicateM 10 $ randomIO @Char - let txReq = RPC.RequestBroadcastTxSync { RPC.requestBroadcastTxSyncTx = encodeTx a } - addEventToCheck tenv $ mkAppEvent (cs a) + a <- replicateM 10 $ randomIO @Char + addEventToCheck tenv "name" + let txReq = RPC.RequestBroadcastTxSync { RPC.requestBroadcastTxSyncTx = encodeTx $ "name=" <> a } -- sync only returns a CheckTx resp <- runRPC $ RPC.broadcastTxSync txReq RPC.resultBroadcastTxCode resp `shouldBe` 0 @@ -64,9 +64,9 @@ spec = do it "Can submit a commit tx, make sure the response code is 0 (success), and get the result(s)" $ \tenv -> do -- /broadcast_tx_commit -- set name key - a <- fmap cs . replicateM 10 $ randomIO @Char - addEventToCheck tenv $ mkAppEvent "name" - let broadcastTxReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeTx $ "name=" <> a } + addEventToCheck tenv "name" + a <- replicateM 10 $ randomIO @Char + let broadcastTxReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeTx $ "name=" <> a } broadcastResp <- runRPC $ RPC.broadcastTxCommit broadcastTxReq let deliverResp = RPC.resultBroadcastTxCommitDeliverTx broadcastResp deliverRespCode = deliverResp ^. Response._deliverTxCode @@ -82,10 +82,10 @@ spec = do RPC.abciQuery queryReq queryRespWProof <- fmap RPC.resultABCIQueryResponse . runRPC $ RPC.abciQuery queryReqWProof - let foundName = queryResp ^. Response._queryValue . to decodeName - foundNameWProof = queryRespWProof ^. Response._queryValue . to decodeName - foundName `shouldBe` a - foundNameWProof `shouldBe` a + let foundName = queryResp ^. Response._queryValue + foundNameWProof = queryRespWProof ^. Response._queryValue + decodeQuery foundName `shouldBe` a + decodeQuery foundNameWProof `shouldBe` a -- check with /tx endpoint (w+w/o proof) let hash = RPC.resultBroadcastTxCommitHash $ broadcastResp -- convert hex to base64 @@ -101,17 +101,11 @@ spec = do txResultWPHash `shouldBe` hash - it "Can monitor all events" $ const pending - --it "Can monitor all events" $ \(TestEnv mvex mvres _) -> do - -- expected <- readMVar mvex - -- res <- readMVar mvres - -- (fromList expected `difference` fromList res) `shouldBe` fromList [] + it "Can monitor all events" $ \(TestEnv mvex mvres _) -> do + expected <- readMVar mvex + res <- readMVar mvres + fromList (map A.toJSON expected) `shouldBe` fromList (map A.toJSON res) -encodeTx :: String -> Base64String -encodeTx = Base64.fromBytes . cs @String @ByteString - -decodeName :: Base64String -> String -decodeName = cs @ByteString @String . Base64.toBytes runRPC :: forall a. RPC.TendermintM a -> IO a runRPC = RPC.runTendermintM rpcConfig @@ -124,39 +118,45 @@ runRPC = RPC.runTendermintM rpcConfig in RPC.Config baseReq (prettyPrint "RPC Request") (prettyPrint "RPC Response") host port tls -- See https://github.com/tendermint/tendermint/blob/master/abci/example/kvstore/kvstore.go#L101 -mkAppEvent :: Text -> App -mkAppEvent k = App "Cosmoshi Netowoko" k - -data App = App - { creator :: Text - , key :: Text - } deriving (Show, Eq, Generic) +mkAppEvent :: String -> FieldTypes.Event +mkAppEvent k = FieldTypes.Event + { eventType = "app" + , eventAttributes = + [ FieldTypes.KVPair (encode "creator") (encode "Cosmoshi Netowoko") + , FieldTypes.KVPair (encode "key") (encode k) + ] + } + where + encode = Base64.fromBytes . cs @String @ByteString -instance ToEvent App +encodeTx :: String -> Base64String +encodeTx = Base64.fromBytes . cs @_ @ByteString +decodeQuery :: Base64String -> String +decodeQuery = cs @ByteString . Base64.toBytes -- Test Init -data TestEnv = TestEnv (MVar [A.Value]) (MVar [A.Value]) [Text] +data TestEnv = TestEnv (MVar [FieldTypes.Event]) (MVar [FieldTypes.Event]) (MVar [Text]) testInit :: IO TestEnv -testInit = do - expectedEventsMVar <- newMVar [] - resultEventsMVar <- newMVar [] - pure $ TestEnv expectedEventsMVar resultEventsMVar [] - -addEventToCheck :: ToEvent a => TestEnv -> a -> IO () -addEventToCheck (TestEnv mvexpected _ ses) ev = do - modifyMVar_ mvexpected $ \es -> pure $ es <> [A.toJSON . toEvent $ ev] - let evType = eventType (toEvent ev) +testInit = TestEnv <$> newMVar [] <*> newMVar [] <*> newMVar [] + +addEventToCheck :: TestEnv -> String -> IO () +addEventToCheck (TestEnv mvexpected mvseen mveventTypes) ev = do + let appEv = mkAppEvent ev + modifyMVar_ mvexpected $ pure . (appEv :) + ses <- readMVar mveventTypes + let evType = FieldTypes.eventType appEv if evType`elem` ses then pure () - else void $ startNewListener evType + else do + _ <- startNewListener evType + modifyMVar_ mveventTypes $ pure . (evType :) where startNewListener evType = let subReq = RPC.RequestSubscribe ("tm.event = 'Tx' AND " <> evType <> " EXISTS") - eventPrinter = awaitForever $ \a -> - let msg = cs . A.encode $ a - prefix = "Printing in Conduit: " - in liftIO . putStrLn $ prefix <> msg + eventStorer = awaitForever $ \as -> + liftIO $ modifyMVar_ mvseen $ \es -> pure $ + RPC.txEventEvents as <> es forkTendermintM = forkIO . runRPC . runConduit - in forkTendermintM $ RPC.subscribe subReq .| eventPrinter + in forkTendermintM $ RPC.subscribe subReq .| eventStorer diff --git a/hs-tendermint-client/package.yaml b/hs-tendermint-client/package.yaml index ecf907fe..cf6bfc81 100644 --- a/hs-tendermint-client/package.yaml +++ b/hs-tendermint-client/package.yaml @@ -82,7 +82,8 @@ tests: - hs-tendermint-client - hspec - lens + - lens-aeson - text - random - string-conversions - - hs-abci-sdk + - unordered-containers From df52bc39f50d8bfb09e1ca427f74824fd08fdd71 Mon Sep 17 00:00:00 2001 From: martyall Date: Tue, 10 Mar 2020 10:31:31 -0700 Subject: [PATCH 4/7] remove bad toJSON --- hs-tendermint-client/src/Network/Tendermint/Client.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/hs-tendermint-client/src/Network/Tendermint/Client.hs b/hs-tendermint-client/src/Network/Tendermint/Client.hs index b4996451..ae578f8c 100644 --- a/hs-tendermint-client/src/Network/Tendermint/Client.hs +++ b/hs-tendermint-client/src/Network/Tendermint/Client.hs @@ -258,9 +258,6 @@ data TxResultEvent a = TxEvent , txEventEvents :: a } deriving (Generic) -instance ToJSON a => ToJSON (TxResultEvent a) where - toJSON = genericToJSON $ defaultRPCOptions "txEvent" - instance FromJSON (TxResultEvent [FieldTypes.Event]) where parseJSON val = do let mtxRes = val ^? AL.key "result" From e3c8c5c406b5fb0bb91af8ba502f7de242996485 Mon Sep 17 00:00:00 2001 From: martyall Date: Tue, 10 Mar 2020 16:33:00 -0700 Subject: [PATCH 5/7] update nameservice tests --- hs-abci-docs/nameservice/package.yaml | 5 +- .../test/Nameservice/Test/E2ESpec.hs | 127 +++++++++--------- hs-tendermint-client/package.yaml | 2 - 3 files changed, 62 insertions(+), 72 deletions(-) diff --git a/hs-abci-docs/nameservice/package.yaml b/hs-abci-docs/nameservice/package.yaml index 6652d8de..6b1be1f6 100644 --- a/hs-abci-docs/nameservice/package.yaml +++ b/hs-abci-docs/nameservice/package.yaml @@ -183,9 +183,11 @@ tests: - -with-rtsopts=-N dependencies: - base >= 4.7 && < 5 + - conduit - data-default-class - hs-abci-sdk - hs-abci-test-utils + - hs-abci-types - hs-tendermint-client - hspec - aeson @@ -194,6 +196,3 @@ tests: - servant - text - unordered-containers - - lens-aeson - - lens - - string-conversions diff --git a/hs-abci-docs/nameservice/test/Nameservice/Test/E2ESpec.hs b/hs-abci-docs/nameservice/test/Nameservice/Test/E2ESpec.hs index d1dc1f36..35b1eefe 100644 --- a/hs-abci-docs/nameservice/test/Nameservice/Test/E2ESpec.hs +++ b/hs-abci-docs/nameservice/test/Nameservice/Test/E2ESpec.hs @@ -1,49 +1,50 @@ module Nameservice.Test.E2ESpec (spec) where -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, - readMVar) -import Control.Lens ((^?)) -import Control.Monad (forM_, void) -import Control.Monad.Reader (ReaderT, runReaderT) -import qualified Data.Aeson as A -import Data.Aeson.Lens (key) -import Data.Default.Class (def) -import Data.HashSet (fromList) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, modifyMVar_, + newMVar, readMVar) +import Control.Monad (forM_, void) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ReaderT, runReaderT) +import qualified Data.Aeson as A +import Data.Conduit (awaitForever, + runConduit, (.|)) +import Data.Default.Class (def) +import Data.HashSet (fromList) import Data.Proxy -import Data.String.Conversions (cs) -import Data.Text (Text) +import Data.Text (Text) import Nameservice.Application -import qualified Nameservice.Modules.Nameservice as N -import Nameservice.Test.EventOrphans () -import qualified Network.Tendermint.Client as RPC -import Servant.API ((:<|>) (..)) -import qualified Tendermint.SDK.Application.Module as M -import Tendermint.SDK.BaseApp.Errors (AppError (..)) -import Tendermint.SDK.BaseApp.Events (Event (..), ToEvent (..)) -import Tendermint.SDK.BaseApp.Query (QueryArgs (..), - QueryResult (..), - defaultQueryArgs) -import qualified Tendermint.SDK.Modules.Auth as Auth -import qualified Tendermint.SDK.Modules.Bank as B -import Tendermint.SDK.Types.Address (Address) -import Tendermint.Utils.Client (ClientConfig (..), - EmptyTxClient (..), - HasQueryClient (..), - HasTxClient (..), - QueryClientResponse (..), - Signer (..), - TxClientResponse (..), - TxOpts (..), - defaultClientTxOpts) -import Tendermint.Utils.ClientUtils (assertQuery, assertTx, - deliverTxEvents, - ensureQueryResponseCode, - ensureResponseCodes, - rpcConfig) -import Tendermint.Utils.Events (FromEvent (..)) -import Tendermint.Utils.User (makeSignerFromUser, - makeUser) +import qualified Nameservice.Modules.Nameservice as N +import Nameservice.Test.EventOrphans () +import qualified Network.ABCI.Types.Messages.FieldTypes as FT +import qualified Network.Tendermint.Client as RPC +import Servant.API ((:<|>) (..)) +import qualified Tendermint.SDK.Application.Module as M +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import Tendermint.SDK.BaseApp.Events (ToEvent (..)) +import Tendermint.SDK.BaseApp.Query (QueryArgs (..), + QueryResult (..), + defaultQueryArgs) +import qualified Tendermint.SDK.Modules.Auth as Auth +import qualified Tendermint.SDK.Modules.Bank as B +import Tendermint.SDK.Types.Address (Address) +import Tendermint.Utils.Client (ClientConfig (..), + EmptyTxClient (..), + HasQueryClient (..), + HasTxClient (..), + QueryClientResponse (..), + Signer (..), + TxClientResponse (..), + TxOpts (..), + defaultClientTxOpts) +import Tendermint.Utils.ClientUtils (assertQuery, assertTx, + deliverTxEvents, + ensureQueryResponseCode, + ensureResponseCodes, + rpcConfig) +import Tendermint.Utils.Events (FromEvent (..)) +import Tendermint.Utils.User (makeSignerFromUser, + makeUser) import Test.Hspec @@ -358,7 +359,7 @@ spec = do it "Can monitor all events" $ \(TestEnv mvex mvres _) -> do expected <- readMVar mvex res <- readMVar mvres - fromList expected `shouldBe` fromList res + fromList (map A.toJSON expected) `shouldBe` fromList (map A.toJSON res) faucetUser @@ -486,38 +487,30 @@ faucet txApiDP = Proxy -- Test Init -data TestEnv = TestEnv (MVar [A.Value]) (MVar [A.Value]) [Text] +data TestEnv = TestEnv (MVar [FT.Event]) (MVar [FT.Event]) (MVar [Text]) testInit :: Auth.Amount -> IO TestEnv testInit faucetAmount = do forM_ [user1, user2] $ faucetUser faucetAmount - expectedEventsMVar <- newMVar [] - resultEventsMVar <- newMVar [] - pure $ TestEnv expectedEventsMVar resultEventsMVar [] + TestEnv <$> newMVar [] <*> newMVar [] <*> newMVar [] + addEventToCheck :: ToEvent a => TestEnv -> a -> IO () -addEventToCheck (TestEnv mvexpected mvres ses) ev = do - modifyMVar_ mvexpected $ \es -> pure $ es <> [A.toJSON . toEvent $ ev] - let evType = eventType (toEvent ev) +addEventToCheck (TestEnv mvexpected mvseen mveventTypes) ev = do + let appEv = toEvent ev + modifyMVar_ mvexpected $ pure . (appEv :) + ses <- readMVar mveventTypes + let evType = FT.eventType appEv if evType`elem` ses then pure () - else startNewListener evType + else do + _ <- startNewListener evType + modifyMVar_ mveventTypes $ pure . (evType :) where startNewListener evType = let subReq = RPC.RequestSubscribe ("tm.event = 'Tx' AND " <> evType <> " EXISTS") - forkTendermintM = void . forkIO . void . RPC.runTendermintM rpcConfig - in forkTendermintM $ RPC.subscribe subReq (handler evType) - handler evType res = case res ^? txEvents of - Nothing -> pure () - Just v -> case A.fromJSON v of - A.Error _ -> error ("Failed to parse\n" <> cs (A.encode v) ) - A.Success evs -> - let filterFn v' = evType == eventType v' - filteredEvs = filter filterFn evs - in modifyMVar_ mvres $ \es -> pure $ es <> map A.toJSON filteredEvs - txEvents = key "result" - . key "data" - . key "value" - . key "TxResult" - . key "result" - . key "events" + eventStorer = awaitForever $ \as -> + liftIO $ modifyMVar_ mvseen $ \es -> pure $ + RPC.txEventEvents as <> es + forkTendermintM = forkIO . RPC.runTendermintM rpcConfig . runConduit + in forkTendermintM $ RPC.subscribe subReq .| eventStorer diff --git a/hs-tendermint-client/package.yaml b/hs-tendermint-client/package.yaml index cf6bfc81..c5f3b9e9 100644 --- a/hs-tendermint-client/package.yaml +++ b/hs-tendermint-client/package.yaml @@ -47,7 +47,6 @@ library: - random - stm - stm-conduit - - string-conversions - text - transformers - websockets @@ -82,7 +81,6 @@ tests: - hs-tendermint-client - hspec - lens - - lens-aeson - text - random - string-conversions From de5d55642fedf8765cadf63a9c3bdae1b2608a35 Mon Sep 17 00:00:00 2001 From: martyall Date: Wed, 11 Mar 2020 10:05:13 -0700 Subject: [PATCH 6/7] use bracketP --- hs-abci-docs/nameservice/package.yaml | 1 + .../test/Nameservice/Test/E2ESpec.hs | 4 ++-- .../kv-test/KVStore/Test/KVSpec.hs | 3 ++- hs-tendermint-client/package.yaml | 3 ++- .../src/Network/Tendermint/Client.hs | 17 ++++++++++----- .../Tendermint/Client/Internal/RPCClient.hs | 21 +++++++------------ 6 files changed, 27 insertions(+), 22 deletions(-) diff --git a/hs-abci-docs/nameservice/package.yaml b/hs-abci-docs/nameservice/package.yaml index 6b1be1f6..2f4b224d 100644 --- a/hs-abci-docs/nameservice/package.yaml +++ b/hs-abci-docs/nameservice/package.yaml @@ -193,6 +193,7 @@ tests: - aeson - mtl - nameservice + - resourcet - servant - text - unordered-containers diff --git a/hs-abci-docs/nameservice/test/Nameservice/Test/E2ESpec.hs b/hs-abci-docs/nameservice/test/Nameservice/Test/E2ESpec.hs index 35b1eefe..95251666 100644 --- a/hs-abci-docs/nameservice/test/Nameservice/Test/E2ESpec.hs +++ b/hs-abci-docs/nameservice/test/Nameservice/Test/E2ESpec.hs @@ -6,6 +6,7 @@ import Control.Concurrent.MVar (MVar, modifyMVar_, import Control.Monad (forM_, void) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ReaderT, runReaderT) +import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Aeson as A import Data.Conduit (awaitForever, runConduit, (.|)) @@ -45,7 +46,6 @@ import Tendermint.Utils.ClientUtils (assertQuery, assertTx, import Tendermint.Utils.Events (FromEvent (..)) import Tendermint.Utils.User (makeSignerFromUser, makeUser) - import Test.Hspec @@ -512,5 +512,5 @@ addEventToCheck (TestEnv mvexpected mvseen mveventTypes) ev = do eventStorer = awaitForever $ \as -> liftIO $ modifyMVar_ mvseen $ \es -> pure $ RPC.txEventEvents as <> es - forkTendermintM = forkIO . RPC.runTendermintM rpcConfig . runConduit + forkTendermintM = forkIO . RPC.runTendermintM rpcConfig . runResourceT . runConduit in forkTendermintM $ RPC.subscribe subReq .| eventStorer diff --git a/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs b/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs index 4dce1f38..0009cdf6 100644 --- a/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs +++ b/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs @@ -7,6 +7,7 @@ import Control.Lens ((^.)) import Control.Monad (replicateM) import Control.Monad.Catch (try) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Aeson as A import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteArray.Base64String (Base64String) @@ -158,5 +159,5 @@ addEventToCheck (TestEnv mvexpected mvseen mveventTypes) ev = do eventStorer = awaitForever $ \as -> liftIO $ modifyMVar_ mvseen $ \es -> pure $ RPC.txEventEvents as <> es - forkTendermintM = forkIO . runRPC . runConduit + forkTendermintM = forkIO . runRPC . runResourceT . runConduit in forkTendermintM $ RPC.subscribe subReq .| eventStorer diff --git a/hs-tendermint-client/package.yaml b/hs-tendermint-client/package.yaml index c5f3b9e9..c6a25eb5 100644 --- a/hs-tendermint-client/package.yaml +++ b/hs-tendermint-client/package.yaml @@ -45,10 +45,10 @@ library: - lens-aeson - mtl - random + - resourcet - stm - stm-conduit - text - - transformers - websockets - wuss ghc-options: @@ -83,5 +83,6 @@ tests: - lens - text - random + - resourcet - string-conversions - unordered-containers diff --git a/hs-tendermint-client/src/Network/Tendermint/Client.hs b/hs-tendermint-client/src/Network/Tendermint/Client.hs index ae578f8c..0ec420ec 100644 --- a/hs-tendermint-client/src/Network/Tendermint/Client.hs +++ b/hs-tendermint-client/src/Network/Tendermint/Client.hs @@ -8,6 +8,8 @@ module Network.Tendermint.Client ) where +import Control.Concurrent (forkIO, + killThread) import Control.Concurrent.STM.TQueue (newTQueueIO, writeTQueue) import Control.Lens ((^?)) @@ -15,8 +17,9 @@ import Control.Monad.Catch (throwM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ReaderT, runReaderT) +import Control.Monad.Reader (ask) import Control.Monad.STM (atomically) -import Control.Monad.Trans (lift) +import Control.Monad.Trans.Resource (ResourceT) import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, @@ -28,7 +31,8 @@ import qualified Data.Aeson.Lens as AL import qualified Data.ByteArray.Base64String as Base64 import Data.ByteArray.HexString (HexString) import Data.ByteString (ByteString) -import Data.Conduit (ConduitT) +import Data.Conduit (ConduitT, + bracketP) import Data.Conduit.TQueue (sourceTQueue) import Data.Default.Class (Default (..)) import Data.Int (Int64) @@ -280,7 +284,7 @@ instance FromJSON (TxResultEvent [FieldTypes.Event]) where -- https://github.com/tendermint/tendermint/blob/master/rpc/core/events.go#L17 subscribe :: RequestSubscribe - -> ConduitT () (TxResultEvent [FieldTypes.Event]) TendermintM () + -> ConduitT () (TxResultEvent [FieldTypes.Event]) (ResourceT TendermintM) () subscribe req = do queue <- liftIO newTQueueIO let handler (val :: Aeson.Value) = @@ -290,8 +294,11 @@ subscribe req = do else case Aeson.eitherDecode . Aeson.encode $ val of Left err -> throwM (RPC.ParsingException err) Right a -> atomically $ writeTQueue queue a - lift $ RPC.remoteWS (RPC.MethodName "subscribe") req handler - sourceTQueue queue + cfg <- ask + bracketP + (forkIO $ RPC.remoteWS cfg (RPC.MethodName "subscribe") req handler) + killThread + (const $ sourceTQueue queue) newtype RequestSubscribe = RequestSubscribe { requestSubscribeQuery :: Text diff --git a/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs b/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs index 96c39e51..d2d2fec9 100644 --- a/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs +++ b/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs @@ -1,9 +1,8 @@ module Network.Tendermint.Client.Internal.RPCClient where import Control.Applicative ((<|>)) -import Control.Concurrent (forkIO) import Control.Exception (Exception) -import Control.Monad (forever, void) +import Control.Monad (forever) import Control.Monad.Catch (throwM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader, ask) @@ -110,28 +109,25 @@ data Config = Config } remoteWS :: - ( MonadIO m - , MonadReader Config m - , FromJSON output + ( FromJSON output , ToJSON input ) - => MethodName + => Config + -> MethodName -> input -> (output -> IO ()) - -> m () -{-# INLINE remoteWS #-} -remoteWS method input handler = do - Config {..} <- ask + -> IO () +remoteWS Config{..} method input handler = do let host = BS.unpack cHost port = fromInteger $ toInteger cPort tlsPort = fromInteger $ toInteger port path = "/websocket" - void . liftIO . forkIO $ if tlsEnabled + if tlsEnabled then runSecureClient host tlsPort path ws else WS.runClient host port path ws where ws c = do - rid <- abs <$> liftIO randomIO + rid <- abs <$> randomIO let rpcParams = Aeson.toJSON input rpcRequest = Request method rid rpcParams msg = WS.Binary $ Aeson.encode rpcRequest @@ -142,7 +138,6 @@ remoteWS method input handler = do handler message decodeRPCResponse bs = case Aeson.eitherDecodeStrict bs of Left err -> throwM $ ParsingException err - Right response -> pure response From 69cea51f93c9653eb675a635f4ae3bc1a68a0842 Mon Sep 17 00:00:00 2001 From: martyall Date: Wed, 11 Mar 2020 11:35:56 -0700 Subject: [PATCH 7/7] hlint --- hs-tendermint-client/src/Network/Tendermint/Client.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/hs-tendermint-client/src/Network/Tendermint/Client.hs b/hs-tendermint-client/src/Network/Tendermint/Client.hs index 0ec420ec..431210b0 100644 --- a/hs-tendermint-client/src/Network/Tendermint/Client.hs +++ b/hs-tendermint-client/src/Network/Tendermint/Client.hs @@ -15,9 +15,8 @@ import Control.Concurrent.STM.TQueue (newTQueueIO, import Control.Lens ((^?)) import Control.Monad.Catch (throwM) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (ReaderT, +import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Monad.Reader (ask) import Control.Monad.STM (atomically) import Control.Monad.Trans.Resource (ResourceT) import Data.Aeson (FromJSON (..),