Nameservice interact

hs-abci-examples/nameservice/interact/Interact.hs

@@ -0,0 +1,105 @@
+module Interact
+  ( genNames
+  , genVals
+  , createNames
+  , buyNames
+  , setNames
+  , deleteNames
+  , faucetAccount
+  , user1
+  , user2
+  ) where
+
+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           Nameservice.Modules.Nameservice  (BuyName (..),
+                                                   DeleteName (..), Name (..),
+                                                   SetName (..))
+import           Nameservice.Modules.Token        (Amount (..),
+                                                   FaucetAccount (..))
+import           Nameservice.Modules.TypedMessage (TypedMessage (..))
+import           Tendermint.SDK.Codec             (HasCodec (..))
+import           Tendermint.Utils.Request         (runTransaction_)
+import           Tendermint.Utils.User            (User (..), makeUser, mkSignedRawTransactionWithRoute)
+--------------------------------------------------------------------------------
+-- Users
+--------------------------------------------------------------------------------
+
+user1 :: User
+user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a"
+
+user2 :: User
+user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a"
+
+--------------------------------------------------------------------------------
+-- Actions
+--------------------------------------------------------------------------------
+
+genNames :: Int -> IO [Name]
+genNames 0 = return []
+genNames x = do
+  genName <- Name.name
+  let aName = fromString genName
+  names <- genNames (x - 1)
+  return (aName:names)
+
+genVals :: Int -> IO [Text]
+genVals 0 = return []
+genVals x = do
+  genVal <- Lorem.word
+  vals <- genVals (x - 1)
+  return (cs genVal:vals)
+
+createName :: User -> Name -> Text -> IO ()
+createName user name val = buyName user name val 0
+
+createNames :: User -> [(Name, Text)] -> IO ()
+createNames _ [] = return ()
+createNames user ((name, val):rst) = do
+  createName user name val
+  createNames user rst
+
+buyName :: User -> Name -> Text -> Amount -> IO ()
+buyName User{userAddress, userPrivKey} name newVal amount =
+  let msg = TypedMessage "BuyName" (encode $ BuyName amount name newVal userAddress)
+      rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg
+  in runTransaction_ rawTx
+
+buyNames :: User -> [(Name, Text, Amount)] -> IO ()
+buyNames _ [] = return ()
+buyNames user ((name, val, amt):rst) = do
+  buyName user name val amt
+  buyNames user rst
+
+deleteName :: User -> Name -> IO ()
+deleteName User{userAddress, userPrivKey} name =
+  let msg = TypedMessage "DeleteName" (encode $ DeleteName userAddress name)
+      rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg
+  in runTransaction_ rawTx
+
+deleteNames :: User -> [Name] -> IO ()
+deleteNames _ [] = return ()
+deleteNames user (name:names) = do
+  deleteName user name
+  deleteNames user names
+
+setName :: User -> Name -> Text -> IO ()
+setName User{userAddress, userPrivKey} name val =
+  let msg = TypedMessage "SetName" (encode $ SetName name userAddress val)
+      rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg
+  in runTransaction_ rawTx
+
+setNames :: User -> [(Name, Text)] -> IO ()
+setNames _ [] = return ()
+setNames user ((name, val):rst) = do
+  setName user name val
+  setNames user rst
+
+faucetAccount :: User -> Amount -> IO ()
+faucetAccount User{userAddress, userPrivKey} amount =
+  let msg = TypedMessage "FaucetAccount" (encode $ FaucetAccount userAddress amount)
+      rawTx = mkSignedRawTransactionWithRoute "token" userPrivKey msg
+  in runTransaction_ rawTx

hs-abci-examples/nameservice/interact/Main.hs

@@ -0,0 +1,25 @@
+module Main where
+
+import           Control.Monad      (forever)
+import           Data.Maybe         (maybe)
+import           Interact
+import           System.Environment (lookupEnv)
+import           Text.Read          (read)
+
+main :: IO ()
+main = do
+  mConc <- lookupEnv "TX_COUNT"
+  let conc = maybe 1 read mConc
+  putStrLn $ "Running nameservice interaction w/ TX_COUNT: " <> show conc
+  faucetAccount user1 10000
+  faucetAccount user2 10000
+  forever $ do
+    names <- genNames conc
+    vals <- genVals conc
+    buyVals <- genVals conc
+    let buyAmts = replicate conc 10
+    setVals <- genVals conc
+    createNames user1 (zip names vals)
+    buyNames user2 (zip3 names buyVals buyAmts)
+    setNames user2 (zip names setVals)
+    deleteNames user2 names

hs-abci-examples/nameservice/package.yaml

@@ -132,6 +132,24 @@ executables:
     - proto3-suite
     - proto3-wire
 
+  interact:
+    main:                Main.hs
+    source-dirs:         interact
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -Werror
+    - -Wall
+    dependencies:
+    - base
+    - faker
+    - nameservice
+    - hs-abci-sdk
+    - hs-abci-test-utils
+    - string-conversions
+    - text
+
 tests:
   tutorial:
     main:                README.lhs

hs-abci-examples/nameservice/src/Nameservice/Config.hs

@@ -51,7 +51,7 @@ makeAppConfig = do
     ddApiKey <- cs <$> MaybeT (lookupEnv "DD_API_KEY")
     pure $ P.MetricsScrapingConfig prometheusPort ddApiKey
   metricsMap <- newMVar empty
-  c <- BaseApp.makeContext (KL.InitialLogNamespace "dev" "simple-storage") prometheusEnv
+  c <- BaseApp.makeContext (KL.InitialLogNamespace "dev" "nameservice") prometheusEnv
   prometheusServer <- newIORef Nothing
   addScribesToLogEnv $
     AppConfig { _baseAppContext = c

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
@@ -34,6 +35,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/test/Nameservice/Test/E2ESpec.hs

@@ -182,6 +182,7 @@ spec = do
         senderAfterFoundAmount `shouldBe` Amount 1200
 
 --------------------------------------------------------------------------------
+
 user1 :: User
 user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a"
 

hs-abci-test-utils/src/Tendermint/Utils/Request.hs

@@ -1,6 +1,7 @@
 module Tendermint.Utils.Request where
 
 import           Control.Lens                         ((^.))
+import           Control.Monad                        (void)
 import           Data.Aeson                           (ToJSON)
 import           Data.Aeson.Encode.Pretty             (encodePretty)
 import qualified Data.ByteArray.Base64String          as Base64
@@ -24,6 +25,15 @@ runRPC = RPC.runTendermintM rpcConfig
           prettyPrint prefix a = putStrLn $ prefix <> "\n" <> (cs . encodePretty $ a)
       in RPC.Config baseReq (prettyPrint "RPC Request") (prettyPrint "RPC Response")
 
+runRPC_ :: RPC.TendermintM a -> IO ()
+runRPC_ = void . runRPC
+
+-- executes a transaction and throws away the result
+runTransaction_ :: RawTransaction -> IO ()
+runTransaction_ rawTx =
+  let txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeRawTx rawTx }
+  in runRPC_ $ RPC.broadcastTxCommit txReq
+
 -- executes a query and ensures a 0 response code
 getQueryResponseSuccess :: RPC.TendermintM (ClientResponse a) -> IO a
 getQueryResponseSuccess query = do

stack.yaml

@@ -17,30 +17,32 @@ packages:
 - ./hs-iavl-client
 
 extra-deps:
-  - proto-lens-runtime-0.5.0.0
-  - proto-lens-setup-0.4.0.2
+  - faker-0.0.0.2
+  - gimlh-0.1.3.0
+  - http2-client-0.9.0.0
+  - http2-grpc-types-0.4.0.0
+  - katip-datadog-0.1.0.0
   - lens-labels-0.3.0.1
+  - polysemy-1.2.3.0
+  - polysemy-zoo-0.6.0.0
+  - prometheus-2.1.3
   - proto-lens-0.5.0.0
   - proto-lens-protoc-0.5.0.0
-  - containers-0.5.11.0@sha256:28ad7337057442f75bc689315ab4ec7bdf5e6b2c39668f306672cecd82c02798,16685
-  - http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348
+  - proto-lens-runtime-0.5.0.0
+  - proto-lens-setup-0.4.0.2
   - binary-0.8.7.0@sha256:ae3e6cca723ac55c54bbb3fa771bcf18142bc727afd57818e66d6ee6c8044f12,7705
-  - text-1.2.4.0@sha256:8c24450feb8e3bbb7ea3e17af24ef57e85db077c4bf53e5bcc345b283d1b1d5b,10081
-  - katip-elasticsearch-0.6.0.0@sha256:be8513ce611db989c63c9f836af99699767d4fc3a9cb0fd81fcbae4d1f2ed7ee,2746
   - bloodhound-0.16.0.0@sha256:b7be3a83e7b914fbe80a9b9de29009ad60cff072f5f8d4af4ee64de8e6406d32,5508
+  - containers-0.5.11.0@sha256:28ad7337057442f75bc689315ab4ec7bdf5e6b2c39668f306672cecd82c02798,16685
   - hpc-0.6.0.3@sha256:de3f7982345d315f1d7713df38b4f2cf09bd274f7d64dffec0cf2a0d9c8aab19,1185
-  - katip-datadog-0.1.0.0
-  - prometheus-2.1.3
+  - http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348
+  - katip-elasticsearch-0.6.0.0@sha256:be8513ce611db989c63c9f836af99699767d4fc3a9cb0fd81fcbae4d1f2ed7ee,2746
+  - text-1.2.4.0@sha256:8c24450feb8e3bbb7ea3e17af24ef57e85db077c4bf53e5bcc345b283d1b1d5b,10081
   - git: https://github.com/oscoin/avl-auth
     commit: dfc468845a82cdd7d759943b20853999bc026505
   - git: https://github.com/awakesecurity/proto3-suite
     commit: 3f6dd6f612cf2eba3c05798926ff924b0d5ab4fa
   - git: https://github.com/awakesecurity/proto3-wire
     commit: 23015cf6363d1962fde6bdff0de111f7ec59ab75
-  - polysemy-1.2.3.0
-  - polysemy-zoo-0.6.0.0
-  - http2-client-0.9.0.0
-  - http2-grpc-types-0.4.0.0
   - git: https://github.com/lucasdicioccio/http2-client-grpc
     commit: 6a1aacfc18e312ef57552133f13dd1024c178706