From 3b13a569bcc77dcdec154552175f69bf4ea8b8ca Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 27 Jan 2020 22:04:35 -0500 Subject: [PATCH] Async nameservice interact (#179) * Init hs-abci-test-utils * import packages and use correct default extensions * use directory module hierarchy * update project files with new utils lib * nameservice tests passing * use utils in ss * use new user module in nameservice tests * delete special msg encoder * use user util module in simple storage tests * move response checkers to utils library * move request runners to new request module * Update readme * Add interact exe to nameservice * Add basic main for interact * add random name generator * Clean up action type signatures +Fix markdown-unlit issue * Async actionBlock * unused * unused from merge * kind of works * fix concurrency * WIP * Fix actions + lower default concurrency var value Some transactions are failing midway through the actionBlock due to an improper nonces. At this point, the entire actionBlock run should quit instead of continuing. Tx Cache errors are still possible. * Off by one error: allow transfer to 0 an account * Update script to generate random users for each thread * wip: compile with master changes * buyName * createName * deleteName * Works again --- Makefile | 5 + .../nameservice/interact/Interact.hs | 193 ++++++++++++++++++ hs-abci-examples/nameservice/interact/Main.hs | 17 ++ hs-abci-examples/nameservice/package.yaml | 24 +++ .../Nameservice/Modules/Nameservice/Types.hs | 3 + .../src/Nameservice/Modules/Token/Keeper.hs | 2 +- stack.yaml | 4 + stack.yaml.lock | 28 +++ 8 files changed, 275 insertions(+), 1 deletion(-) create mode 100644 hs-abci-examples/nameservice/interact/Interact.hs create mode 100644 hs-abci-examples/nameservice/interact/Main.hs diff --git a/Makefile b/Makefile index 9e757b0f..3a09ac83 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,5 @@ STATS_PORT ?= 9200 +INTERACT_THREAD_COUNT ?= 5 export @@ -84,6 +85,10 @@ test-simple-storage: install ## Run the test suite for the simple-storage exampl test-nameservice: install ## Run the test suite for the nameservice example application stack test nameservice:nameservice-test +interact-nameservice: install ## Run nameservice interaction script + INTERACT_THREAD_COUNT=$(INTERACT_THREAD_COUNT) \ + stack exec interact + test-tutorial: install ## Make sure the tutorial builds stack test nameservice:tutorial diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs new file mode 100644 index 00000000..7b590951 --- /dev/null +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -0,0 +1,193 @@ +module Interact + ( actionBlock + , makeRandomUsers + ) where + +import Control.Monad (replicateM, void) +import Control.Monad.Reader (ReaderT, runReaderT) +import Data.Char (isHexDigit) +import Data.Default.Class (def) +import Data.Proxy +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Faker.Lorem as Lorem +import qualified Faker.Name as Name +import qualified Faker.Utils as Utils +import Nameservice.Application +import qualified Nameservice.Modules.Nameservice as N +import qualified Nameservice.Modules.Token as T +import qualified Network.Tendermint.Client as RPC +import Servant.API ((:<|>) (..)) +import Tendermint.SDK.Application.Module (AppQueryRouter (QApi), + AppTxRouter (TApi)) +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import Tendermint.SDK.BaseApp.Query (QueryArgs (..), + QueryResult (..)) +import qualified Tendermint.SDK.Modules.Auth as Auth +import Tendermint.SDK.Types.Address (Address) +import Tendermint.Utils.Client (ClientConfig (..), + EmptyTxClient (..), + HasQueryClient (..), + HasTxClient (..), + QueryClientResponse (..), + Signer (..), + TxClientResponse (..), + TxOpts (..), + defaultClientTxOpts) +import Tendermint.Utils.ClientUtils (assertTx, rpcConfig) +import Tendermint.Utils.User (makeSignerFromUser, + makeUser) +import Test.RandomStrings (onlyWith, randomASCII, + randomString) + +-------------------------------------------------------------------------------- +-- Actions +-------------------------------------------------------------------------------- + +faucetAccount :: Signer -> T.Amount -> IO () +faucetAccount s@(Signer addr _) amount = + runAction_ s faucet $ T.FaucetAccount addr amount + +createName :: Signer -> N.Name -> Text -> IO () +createName s name val = buyName s name val 0 + +buyName :: Signer -> N.Name -> Text -> T.Amount -> IO () +buyName s@(Signer addr _) name newVal amount = + runAction_ s buy $ N.BuyName amount name newVal addr + +deleteName :: Signer -> N.Name -> IO () +deleteName s@(Signer addr _) name = + runAction_ s delete $ N.DeleteName addr name + +setName :: Signer -> N.Name -> Text -> IO () +setName s@(Signer addr _) name val = + runAction_ s set $ N.SetName name addr val + +runAction_ + :: Signer + -> (TxOpts -> msg -> TxClientM (TxClientResponse () ())) + -> msg + -> IO () +runAction_ s f = void . assertTx . runTxClientM . f (TxOpts 0 s) + +actionBlock :: (Signer, Signer) -> IO () +actionBlock (s1, s2) = do + name <- genName + genCVal <- genWords + genBVal <- genWords + genBAmt <- genAmount + genSVal <- genWords + faucetAccount s2 genBAmt + createName s1 name genCVal + buyName s2 name genBVal genBAmt + setName s2 name genSVal + deleteName s2 name + +-------------------------------------------------------------------------------- +-- Users +-------------------------------------------------------------------------------- + +makeRandomUsers :: IO (Signer, Signer) +makeRandomUsers = do + str1 <- randomString (onlyWith isHexDigit randomASCII) 64 + str2 <- randomString (onlyWith isHexDigit randomASCII) 64 + return $ (makeSignerFromUser . makeUser $ str1 + ,makeSignerFromUser . makeUser $ str2 + ) + +-------------------------------------------------------------------------------- +-- Query Client +-------------------------------------------------------------------------------- + +getAccount + :: QueryArgs Address + -> RPC.TendermintM (QueryClientResponse Auth.Account) + +_ :<|> _ :<|> getAccount = + genClientQ (Proxy :: Proxy m) queryApiP def + where + queryApiP :: Proxy (QApi NameserviceModules) + queryApiP = Proxy + + -------------------------------------------------------------------------------- +-- Tx Client +-------------------------------------------------------------------------------- + +txClientConfig :: ClientConfig +txClientConfig = + let getNonce addr = do + resp <- RPC.runTendermintM rpcConfig $ getAccount $ + QueryArgs + { queryArgsHeight = -1 + , queryArgsProve = False + , queryArgsData = addr + } + case resp of + QueryError e -> + if appErrorCode e == 2 + then pure 0 + else error $ "Unknown nonce error: " <> show (appErrorMessage e) + QueryResponse QueryResult {queryResultData} -> + pure $ Auth.accountNonce queryResultData + + in ClientConfig + { clientGetNonce = getNonce + , clientRPC = rpcConfig + } + +type TxClientM = ReaderT ClientConfig IO + +runTxClientM :: TxClientM a -> IO a +runTxClientM m = runReaderT m txClientConfig + +-- Nameservice Client +buy + :: TxOpts + -> N.BuyName + -> TxClientM (TxClientResponse () ()) + +set + :: TxOpts + -> N.SetName + -> TxClientM (TxClientResponse () ()) + +delete + :: TxOpts + -> N.DeleteName + -> TxClientM (TxClientResponse () ()) + +-- Token Client +faucet + :: TxOpts + -> T.FaucetAccount + -> TxClientM (TxClientResponse () ()) + +(buy :<|> set :<|> delete) :<|> + (_ :<|> _ :<|> faucet) :<|> + EmptyTxClient = + genClientT (Proxy @TxClientM) txApiP defaultClientTxOpts + where + txApiP :: Proxy (TApi NameserviceModules) + txApiP = Proxy + + +-------------------------------------------------------------------------------- +-- Generation +-------------------------------------------------------------------------------- + +genWords :: IO Text +genWords = do + numWords <- Utils.randomNum (1, 10) + ws <- replicateM numWords Lorem.word + return . cs . unwords $ ws + +genName :: IO N.Name +genName = do + name <- Name.name + return . fromString $ name + +genAmount :: IO T.Amount +genAmount = do + genAmt <- Utils.randomNum (1, 1000) + return . fromInteger . toInteger $ genAmt diff --git a/hs-abci-examples/nameservice/interact/Main.hs b/hs-abci-examples/nameservice/interact/Main.hs new file mode 100644 index 00000000..c0cb01e1 --- /dev/null +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -0,0 +1,17 @@ +module Main where + +import Control.Concurrent.Async (forConcurrently_) +import Control.Monad (forever, replicateM) +import Data.Maybe (maybe) +import Interact +import System.Environment (lookupEnv) +import Text.Read (read) + +main :: IO () +main = do + mThreads <- lookupEnv "INTERACT_THREAD_COUNT" + let threads = maybe 1 read mThreads :: Int + usersForThreads <- replicateM threads makeRandomUsers + putStrLn $ "Running nameservice interaction with #threads: " <> show threads + forever $ forConcurrently_ [0..(threads-1)] $ \i -> + actionBlock $ usersForThreads !! i diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index d1481d96..e57a0f25 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -128,6 +128,30 @@ executables: - proto3-suite - proto3-wire + interact: + main: Main.hs + source-dirs: interact + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Werror + - -Wall + dependencies: + - async + - base + - data-default-class + - faker + - mtl + - nameservice + - hs-abci-sdk + - hs-abci-test-utils + - hs-tendermint-client + - random-strings + - servant + - string-conversions + - text + tests: tutorial: main: README.lhs diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Types.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Types.hs index 90ac46bc..5c510eed 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Types.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Types.hs @@ -3,6 +3,7 @@ module Nameservice.Modules.Nameservice.Types where import Control.Lens (iso) import Data.Aeson as A import Data.Bifunctor (first) +import Data.String (IsString (..)) import Data.String.Conversions (cs) import Data.Text (Text) import qualified Data.Text.Lazy as TL @@ -33,6 +34,8 @@ instance Primitive Name where primType _ = DotProto.String instance HasDefault Name instance MessageField Name +instance IsString Name where + fromString = Name . fromString instance BaseApp.FromQueryData Name diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Keeper.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Keeper.hs index 258c2641..379d6b24 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Keeper.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Keeper.hs @@ -75,7 +75,7 @@ transfer transfer addr1 amount addr2 = do -- check if addr1 has amt addr1Bal <- getBalance addr1 - if addr1Bal > amount + if addr1Bal >= amount then do addr2Bal <- getBalance addr2 let newBalance1 = addr1Bal - amount diff --git a/stack.yaml b/stack.yaml index f32754da..ebd00ff3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,6 +17,10 @@ packages: - ./hs-iavl-client extra-deps: + - async-2.2.2 + - faker-0.0.0.2 + - gimlh-0.1.3.0 + - random-strings-0.1.1.0 - proto-lens-runtime-0.5.0.0 - proto-lens-setup-0.4.0.2 - lens-labels-0.3.0.1 diff --git a/stack.yaml.lock b/stack.yaml.lock index beccf8ec..4146e7a1 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,6 +4,34 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: +- completed: + hackage: async-2.2.2@sha256:ed46f0f5be36cf8a3e3aebc6827d015e1f3bf9615c245e057b9e9bd35faddd21,2895 + pantry-tree: + size: 501 + sha256: dab5a4c2126fbce3f4a7c15ccf66e60de61d3eccae071f4bfbad036087399f32 + original: + hackage: async-2.2.2 +- completed: + hackage: faker-0.0.0.2@sha256:e181a9dba8022098d2cca9822b6a616a28d3013ee978076b7c7cd18b6e15c8eb,980 + pantry-tree: + size: 792 + sha256: d1fd5fcf4175f259b84f9036ab8d53d23457eb1ab9eab163dce83e8a8d7fca65 + original: + hackage: faker-0.0.0.2 +- completed: + hackage: gimlh-0.1.3.0@sha256:0cb3513ec36b7f935956b68875de40a05e934cf75499918e1db533b7d32dfc46,747 + pantry-tree: + size: 201 + sha256: 106e63ee076f0339ae5e15c599f5eb15d1e663f1f2303417000f26c9514f24c6 + original: + hackage: gimlh-0.1.3.0 +- completed: + hackage: random-strings-0.1.1.0@sha256:935a7a23dab45411960df77636a29b44ce42b89eeb15f2b1e809d771491fa677,2517 + pantry-tree: + size: 663 + sha256: 5a382966fdd8d5220b5791f3bff6db00d2ea29235e2716dadd52461b8a8beb97 + original: + hackage: random-strings-0.1.1.0 - completed: hackage: proto-lens-runtime-0.5.0.0@sha256:cb39cf13ce4f7dac5414f94a7afe0adc9b831312e6b60588a23bd816accc385f,3132 pantry-tree: