Async nameservice interact

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: