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

@@ -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
 

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

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

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

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
 

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

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

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: