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: