From 243d62154a0af690e2f9d3f539e04c5bfd6a9d79 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 12 Dec 2019 15:13:02 -0500 Subject: [PATCH 01/30] Init hs-abci-test-utils --- hs-abci-test-utils/README.md | 1 + hs-abci-test-utils/package.yaml | 45 ++++++++++++++++++++++ hs-abci-test-utils/stack.yaml | 66 +++++++++++++++++++++++++++++++++ hs-abci-test-utils/test/Spec.hs | 2 + stack.yaml | 1 + 5 files changed, 115 insertions(+) create mode 100644 hs-abci-test-utils/README.md create mode 100644 hs-abci-test-utils/package.yaml create mode 100644 hs-abci-test-utils/stack.yaml create mode 100644 hs-abci-test-utils/test/Spec.hs diff --git a/hs-abci-test-utils/README.md b/hs-abci-test-utils/README.md new file mode 100644 index 00000000..d7493276 --- /dev/null +++ b/hs-abci-test-utils/README.md @@ -0,0 +1 @@ +# hs-abci-test-utils diff --git a/hs-abci-test-utils/package.yaml b/hs-abci-test-utils/package.yaml new file mode 100644 index 00000000..de39b39c --- /dev/null +++ b/hs-abci-test-utils/package.yaml @@ -0,0 +1,45 @@ +name: hs-abci-test-utils +version: 0.1.0.0 +github: "f-o-a-m/hs-abci/hs-abci-test-utils" +license: BSD3 +author: "Author name here" +maintainer: "example@example.com" +copyright: "2019 Author name here" + +extra-source-files: +- README.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 + +library: + source-dirs: src + ghc-options: + - -Werror + - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-uni-patterns + - -Wredundant-constraints + +tests: + hs-abci-test-utils-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -Werror + - -Wall + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - hs-abci-test-utils diff --git a/hs-abci-test-utils/stack.yaml b/hs-abci-test-utils/stack.yaml new file mode 100644 index 00000000..29f85393 --- /dev/null +++ b/hs-abci-test-utils/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-14.17 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/hs-abci-test-utils/test/Spec.hs b/hs-abci-test-utils/test/Spec.hs new file mode 100644 index 00000000..fcb16768 --- /dev/null +++ b/hs-abci-test-utils/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} diff --git a/stack.yaml b/stack.yaml index 44c480b0..6451ca9b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,6 +11,7 @@ packages: - ./hs-abci-server - ./hs-abci-extra - ./hs-abci-sdk +- ./hs-abci-test-utils - ./hs-abci-examples/simple-storage - ./hs-abci-examples/nameservice From 2b4f8f2d121c1740cc3583bfbfe98f07707b361f Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 12 Dec 2019 15:57:41 -0500 Subject: [PATCH 02/30] import packages and use correct default extensions --- hs-abci-test-utils/package.yaml | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/hs-abci-test-utils/package.yaml b/hs-abci-test-utils/package.yaml index de39b39c..12fc6a59 100644 --- a/hs-abci-test-utils/package.yaml +++ b/hs-abci-test-utils/package.yaml @@ -19,7 +19,35 @@ extra-source-files: description: Please see the README on GitHub at dependencies: +- aeson - base >= 4.7 && < 5 +- bytestring +- errors +- lens +- mtl +- polysemy +- servant +- string-conversions +- text +- hs-abci-types +- hs-abci-sdk +- hs-tendermint-client + +default-extensions: + - DataKinds + - DefaultSignatures + - DeriveGeneric + - FlexibleContexts + - FlexibleInstances + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - TypeApplications + - TypeFamilies + - RecordWildCards + - ScopedTypeVariables + - TypeOperators library: source-dirs: src From f66e856f8e981ce8a24bd0dc37514a01bda16800 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 12 Dec 2019 16:01:28 -0500 Subject: [PATCH 03/30] use directory module hierarchy --- hs-abci-test-utils/package.yaml | 3 + .../src/Tendermint/Utils/Client.hs | 79 +++++++++++ .../src/Tendermint/Utils/Events.hs | 127 ++++++++++++++++++ .../test/Tendermint/Utils/Test/EventSpec.hs | 31 +++++ 4 files changed, 240 insertions(+) create mode 100644 hs-abci-test-utils/src/Tendermint/Utils/Client.hs create mode 100644 hs-abci-test-utils/src/Tendermint/Utils/Events.hs create mode 100644 hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs diff --git a/hs-abci-test-utils/package.yaml b/hs-abci-test-utils/package.yaml index 12fc6a59..d51dd24b 100644 --- a/hs-abci-test-utils/package.yaml +++ b/hs-abci-test-utils/package.yaml @@ -71,3 +71,6 @@ tests: - -with-rtsopts=-N dependencies: - hs-abci-test-utils + - hspec + - hspec-core + - hspec-discover diff --git a/hs-abci-test-utils/src/Tendermint/Utils/Client.hs b/hs-abci-test-utils/src/Tendermint/Utils/Client.hs new file mode 100644 index 00000000..d076a9fd --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/Client.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Tendermint.Utils.Client + ( RunClient(..) + , HasClient(..) + , ClientResponse(..) + ) where + +import Control.Lens (to, (^.)) +import Control.Monad.Reader (ReaderT) +import qualified Data.ByteArray.Base64String as Base64 +import qualified Data.ByteArray.HexString as Hex +import Data.ByteString (ByteString) +import Data.Proxy +import Data.String.Conversions (cs) +import GHC.TypeLits (KnownSymbol, symbolVal) +import qualified Network.ABCI.Types.Messages.Request as Req +import qualified Network.ABCI.Types.Messages.Response as Resp +import qualified Network.Tendermint.Client as RPC +import Servant.API ((:<|>) (..), (:>)) +import Tendermint.SDK.BaseApp.Query.Types (Leaf, QA, QueryArgs (..), + Queryable (..)) +import Tendermint.SDK.BaseApp.Store (RawKey (..)) + +class Monad m => RunClient m where + -- | How to make a request. + runQuery :: Req.Query -> m Resp.Query + +instance RunClient (ReaderT RPC.Config IO) where + runQuery Req.Query{..} = + let rpcQ = RPC.RequestABCIQuery + { RPC.requestABCIQueryPath = Just queryPath + , RPC.requestABCIQueryData = Hex.fromBytes @ByteString . Base64.toBytes $ queryData + , RPC.requestABCIQueryHeight = Just $ queryHeight + , RPC.requestABCIQueryProve = queryProve + } + in RPC.resultABCIQueryResponse <$> RPC.abciQuery rpcQ + +class HasClient m layout where + + type ClientT (m :: * -> *) layout :: * + genClient :: Proxy m -> Proxy layout -> Req.Query -> ClientT m layout + +instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where + type ClientT m (a :<|> b) = ClientT m a :<|> ClientT m b + genClient pm _ q = genClient pm (Proxy @a) q :<|> genClient pm (Proxy @b) q + +instance (KnownSymbol path, HasClient m a) => HasClient m (path :> a) where + type ClientT m (path :> a) = ClientT m a + genClient pm _ q = genClient pm (Proxy @a) + q {Req.queryPath = Req.queryPath q <> "/" <> cs (symbolVal (Proxy @path))} + +instance (RawKey k, HasClient m a) => HasClient m (QA k :> a) where + type ClientT m (QA k :> a) = QueryArgs k -> ClientT m a + genClient pm _ q QueryArgs{..} = genClient pm (Proxy @a) + q { Req.queryData = queryArgsData ^. rawKey . to Base64.fromBytes + , Req.queryHeight = queryArgsHeight + , Req.queryProve = queryArgsProve + } + +-- | Data is Nothing iff Raw includes a non-0 response value +data ClientResponse a = ClientResponse + { clientResponseData :: Maybe a + , clientResponseRaw :: Resp.Query + } + +instance (RunClient m, Queryable a, name ~ Name a, KnownSymbol name ) => HasClient m (Leaf a) where + type ClientT m (Leaf a) = m (ClientResponse a) + genClient _ _ q = + let leaf = symbolVal (Proxy @(Name a)) + in do + r@Resp.Query{..} <- runQuery q { Req.queryPath = Req.queryPath q <> "/" <> cs leaf } + -- anything other than 0 code is a failure: https://tendermint.readthedocs.io/en/latest/abci-spec.html + -- and will result in queryValue decoding to a "empty/default" object + return $ case queryCode of + 0 -> case decodeQueryResult queryValue of + Left err -> error $ "Impossible parse error: " <> cs err + Right a -> ClientResponse (Just a) r + _ -> ClientResponse Nothing r diff --git a/hs-abci-test-utils/src/Tendermint/Utils/Events.hs b/hs-abci-test-utils/src/Tendermint/Utils/Events.hs new file mode 100644 index 00000000..991a2919 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/Events.hs @@ -0,0 +1,127 @@ +module Tendermint.Utils.Events + ( Event(..) + , ToEvent(..) + , FromEvent(..) + , emit + , makeEvent + , EventBuffer + , newEventBuffer + , withEventBuffer + , evalWithBuffer + ) where + +import qualified Control.Concurrent.MVar as MVar +import Control.Error (fmapL) +import Control.Monad (void) +import Control.Monad.IO.Class +import qualified Data.Aeson as A +import Data.Bifunctor (bimap) +import qualified Data.ByteArray.Base64String as Base64 +import qualified Data.ByteString as BS +import qualified Data.List as L +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Text (Text) +import GHC.Exts (fromList, toList) +import Network.ABCI.Types.Messages.FieldTypes (Event (..), + KVPair (..)) +import Polysemy (Embed, Member, Sem, + interpret) +import Polysemy.Output (Output (..), output) +import Polysemy.Reader (Reader (..), ask) +import Polysemy.Resource (Resource, onException) + +{- +TODO : These JSON instances are fragile but convenient. We +should come up with a custom solution. +-} + +-- | A class representing a type that can be emitted as an event in the +-- | event logs for the deliverTx response. +class ToEvent e where + makeEventType :: Proxy e -> String + makeEventData :: e -> [(BS.ByteString, BS.ByteString)] + + default makeEventData :: A.ToJSON e => e -> [(BS.ByteString, BS.ByteString)] + makeEventData e = case A.toJSON e of + A.Object obj -> bimap cs (cs . A.encode) <$> toList obj + _ -> mempty + +-- | A class that can parse event log items in the deliverTx response. Primarily +-- | useful for client applications and testing. +class ToEvent e => FromEvent e where + fromEvent :: Event -> Either Text e + + default fromEvent :: A.FromJSON e => Event -> Either Text e + fromEvent Event{eventType, eventAttributes} = + let expectedType = makeEventType (Proxy @e) + in if cs eventType /= expectedType + then fail ("Couldn't match expected event type " <> expectedType <> + " with found type " <> cs eventType) + else + let fromKVPair :: KVPair -> Either String (Text, A.Value) + fromKVPair (KVPair k v) = do + value <- A.eitherDecode . cs @BS.ByteString . Base64.toBytes $ v + return (cs @BS.ByteString . Base64.toBytes $ k, value) + in fmapL cs $ do + kvPairs <- traverse fromKVPair eventAttributes + A.eitherDecode . A.encode . A.Object . fromList $ kvPairs + +-- This is the internal implementation of the interpreter for event +-- logging. We allocate a buffer that can queue events as they are thrown, +-- then flush the buffer at the end of transaction execution. It will +-- also flush in the event that exceptions are thrown. + +data EventBuffer = EventBuffer (MVar.MVar [Event]) + +newEventBuffer :: IO EventBuffer +newEventBuffer = EventBuffer <$> MVar.newMVar [] + +appendEvent + :: MonadIO (Sem r) + => Event + -> EventBuffer + -> Sem r () +appendEvent e (EventBuffer b) = do + liftIO (MVar.modifyMVar_ b (pure . (e :))) + +flushEventBuffer + :: MonadIO (Sem r) + => EventBuffer + -> Sem r [Event] +flushEventBuffer (EventBuffer b) = do + liftIO (L.reverse <$> MVar.swapMVar b []) + +withEventBuffer + :: Member Resource r + => Member (Reader EventBuffer) r + => MonadIO (Sem r) + => Sem r () + -> Sem r [Event] +withEventBuffer action = do + buffer <- ask + onException (action *> flushEventBuffer buffer) (void $ flushEventBuffer buffer) + +makeEvent + :: ToEvent e + => e + -> Event +makeEvent (e :: e) = Event + { eventType = cs $ makeEventType (Proxy :: Proxy e) + , eventAttributes = (\(k, v) -> KVPair (Base64.fromBytes k) (Base64.fromBytes v)) <$> makeEventData e + } + +emit + :: ToEvent e + => Member (Output Event) r + => e + -> Sem r () +emit e = output $ makeEvent e + +evalWithBuffer + :: Member (Embed IO) r + => Member (Reader EventBuffer) r + => (forall a. Sem (Output Event ': r) a -> Sem r a) +evalWithBuffer action = interpret (\case + Output e -> ask >>= appendEvent e + ) action diff --git a/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs b/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs new file mode 100644 index 00000000..267dce58 --- /dev/null +++ b/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs @@ -0,0 +1,31 @@ +module Tendermint.Utils.Test.EventSpec where + +import qualified Data.Aeson as A +import GHC.Generics (Generic) +import Tendermint.SDK.BaseApp.Events (FromEvent (..), ToEvent (..), + makeEvent) +import Test.Hspec + +spec :: Spec +spec = describe "Event Tests" $ do + it "Can serialize and deserialize and event" $ do + let transferEv = Transfer + { to = "me" + , from = "you" + , amount = 1 + } + fromEvent (makeEvent transferEv) `shouldBe` Right transferEv + +data Transfer = Transfer + { to :: String + , from :: String + , amount :: Int + } deriving (Eq, Show, Generic) + +instance A.ToJSON Transfer + +instance ToEvent Transfer where + makeEventType _ = "transfer" + +instance A.FromJSON Transfer +instance FromEvent Transfer From 2a6b3c3953a4eb97e042bc66b6237bb0fc4c051e Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 12 Dec 2019 16:47:15 -0500 Subject: [PATCH 04/30] update project files with new utils lib --- Makefile | 4 +- hs-abci-examples/nameservice/package.yaml | 1 + .../Nameservice/Modules/Nameservice/Types.hs | 7 +- .../src/Nameservice/Modules/Token/Types.hs | 5 +- .../test/Nameservice/Test/E2ESpec.hs | 2 +- hs-abci-sdk/package.yaml | 2 - hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs | 1 - .../src/Tendermint/SDK/BaseApp/Events.hs | 25 +---- .../Tendermint/SDK/BaseApp/Query/Client.hs | 79 -------------- .../test/Tendermint/SDK/Test/EventSpec.hs | 31 ------ hs-abci-test-utils/package.yaml | 4 - .../src/Tendermint/Utils/Events.hs | 100 +----------------- hs-abci-test-utils/stack.yaml | 66 ------------ .../test/Tendermint/Utils/Test/EventSpec.hs | 3 +- 14 files changed, 18 insertions(+), 312 deletions(-) delete mode 100644 hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Client.hs delete mode 100644 hs-abci-sdk/test/Tendermint/SDK/Test/EventSpec.hs delete mode 100644 hs-abci-test-utils/stack.yaml diff --git a/Makefile b/Makefile index d9cc6098..bd16d9fc 100644 --- a/Makefile +++ b/Makefile @@ -15,6 +15,7 @@ hlint: ## Run hlint on all haskell projects hs-tendermint-client \ hs-abci-extra \ hs-abci-sdk \ + hs-abci-test-utils \ hs-abci-examples/simple-storage \ hs-abci-examples/nameservice @@ -24,6 +25,7 @@ stylish: ## Run stylish-haskell over all haskell projects ./hs-tendermint-client \ ./hs-abci-examples \ ./hs-abci-sdk \ + ./hs-abci-test-utils \ ./hs-abci-server \ -name "*.hs" | xargs stack exec stylish-haskell -- -c ./.stylish_haskell.yaml -i @@ -42,7 +44,7 @@ install: ## Runs stack install to compile library and counter example app stack install test-libraries: install ## Run the haskell test suite for all haskell libraries - stack test hs-abci-types hs-abci-server hs-abci-sdk + stack test hs-abci-types hs-abci-server hs-abci-sdk hs-abci-test-utils ##################### diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index a7fea215..bbce5db3 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -57,6 +57,7 @@ dependencies: - hs-abci-extra - hs-abci-sdk - hs-abci-server +- hs-abci-test-utils - hs-abci-types - lens - polysemy 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 b8c9d3ea..38ff9e62 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Types.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Types.hs @@ -19,6 +19,7 @@ import qualified Proto3.Wire.Encode as Encode import qualified Tendermint.SDK.BaseApp as BaseApp import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Types.Address (Address) +import qualified Tendermint.Utils.Events as Event -------------------------------------------------------------------------------- @@ -106,7 +107,7 @@ instance FromJSON NameClaimed where parseJSON = A.genericParseJSON nameClaimedAesonOptions instance BaseApp.ToEvent NameClaimed where makeEventType _ = "NameClaimed" -instance BaseApp.FromEvent NameClaimed +instance Event.FromEvent NameClaimed data NameRemapped = NameRemapped { nameRemappedName :: Name @@ -123,7 +124,7 @@ instance FromJSON NameRemapped where parseJSON = A.genericParseJSON nameRemappedAesonOptions instance BaseApp.ToEvent NameRemapped where makeEventType _ = "NameRemapped" -instance BaseApp.FromEvent NameRemapped +instance Event.FromEvent NameRemapped data NameDeleted = NameDeleted { nameDeletedName :: Name @@ -138,4 +139,4 @@ instance FromJSON NameDeleted where parseJSON = A.genericParseJSON nameDeletedAesonOptions instance BaseApp.ToEvent NameDeleted where makeEventType _ = "NameDeleted" -instance BaseApp.FromEvent NameDeleted +instance Event.FromEvent NameDeleted diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs index a575cb5a..2e8c4446 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs @@ -20,6 +20,7 @@ import qualified Tendermint.SDK.BaseApp as BaseApp import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Types.Address (Address, addressFromBytes, addressToBytes) +import qualified Tendermint.Utils.Events as Event -------------------------------------------------------------------------------- @@ -96,7 +97,7 @@ instance FromJSON Faucetted where parseJSON = A.genericParseJSON faucettedAesonOptions instance BaseApp.ToEvent Faucetted where makeEventType _ = "Faucetted" -instance BaseApp.FromEvent Faucetted +instance Event.FromEvent Faucetted data TransferEvent = TransferEvent { transferEventAmount :: Amount @@ -116,4 +117,4 @@ instance A.FromJSON TransferEvent where instance BaseApp.ToEvent TransferEvent where makeEventType _ = "TransferEvent" -instance BaseApp.FromEvent TransferEvent +instance Event.FromEvent TransferEvent diff --git a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs index f24f16cd..83ce9ec0 100644 --- a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs +++ b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs @@ -47,7 +47,7 @@ import Tendermint.SDK.BaseApp (FromEvent (..), QueryApi) import Tendermint.SDK.BaseApp.Query (QueryArgs (..), defaultQueryWithData) -import Tendermint.SDK.BaseApp.Query.Client (ClientResponse (..), +import Tendermint.Utils.Client (ClientResponse (..), HasClient (..), RunClient (..)) import Tendermint.SDK.Codec (HasCodec (..)) diff --git a/hs-abci-sdk/package.yaml b/hs-abci-sdk/package.yaml index ca25d8a2..fbe9aa25 100644 --- a/hs-abci-sdk/package.yaml +++ b/hs-abci-sdk/package.yaml @@ -108,7 +108,6 @@ library: - Tendermint.SDK.BaseApp.Logger.Katip - Tendermint.SDK.BaseApp.Query - Tendermint.SDK.BaseApp.Query.Class - - Tendermint.SDK.BaseApp.Query.Client - Tendermint.SDK.BaseApp.Query.Delayed - Tendermint.SDK.BaseApp.Query.Router - Tendermint.SDK.BaseApp.Query.Store @@ -138,7 +137,6 @@ tests: other-modules: - Tendermint.SDK.Test.AuthTreeStoreSpec - Tendermint.SDK.Test.CryptoSpec - - Tendermint.SDK.Test.EventSpec - Tendermint.SDK.Test.GasSpec ghc-options: diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs index c5497aa4..5db8fa78 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs @@ -30,7 +30,6 @@ module Tendermint.SDK.BaseApp -- * Events , Event(..) - , FromEvent(..) , ToEvent(..) , emit diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Events.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Events.hs index 80b9de94..1c54f3c1 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Events.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Events.hs @@ -1,7 +1,6 @@ module Tendermint.SDK.BaseApp.Events ( Event(..) , ToEvent(..) - , FromEvent(..) , emit , makeEvent , EventBuffer @@ -11,7 +10,6 @@ module Tendermint.SDK.BaseApp.Events ) where import qualified Control.Concurrent.MVar as MVar -import Control.Error (fmapL) import Control.Monad (void) import Control.Monad.IO.Class import qualified Data.Aeson as A @@ -21,8 +19,7 @@ import qualified Data.ByteString as BS import qualified Data.List as L import Data.Proxy import Data.String.Conversions (cs) -import Data.Text (Text) -import GHC.Exts (fromList, toList) +import GHC.Exts (toList) import Network.ABCI.Types.Messages.FieldTypes (Event (..), KVPair (..)) import Polysemy (Embed, Member, Sem, @@ -47,26 +44,6 @@ class ToEvent e where A.Object obj -> bimap cs (cs . A.encode) <$> toList obj _ -> mempty --- | A class that can parse event log items in the deliverTx response. Primarily --- | useful for client applications and testing. -class ToEvent e => FromEvent e where - fromEvent :: Event -> Either Text e - - default fromEvent :: A.FromJSON e => Event -> Either Text e - fromEvent Event{eventType, eventAttributes} = - let expectedType = makeEventType (Proxy @e) - in if cs eventType /= expectedType - then fail ("Couldn't match expected event type " <> expectedType <> - " with found type " <> cs eventType) - else - let fromKVPair :: KVPair -> Either String (Text, A.Value) - fromKVPair (KVPair k v) = do - value <- A.eitherDecode . cs @BS.ByteString . Base64.toBytes $ v - return (cs @BS.ByteString . Base64.toBytes $ k, value) - in fmapL cs $ do - kvPairs <- traverse fromKVPair eventAttributes - A.eitherDecode . A.encode . A.Object . fromList $ kvPairs - -- This is the internal implementation of the interpreter for event -- logging. We allocate a buffer that can queue events as they are thrown, -- then flush the buffer at the end of transaction execution. It will diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Client.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Client.hs deleted file mode 100644 index 466e84b9..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Client.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -module Tendermint.SDK.BaseApp.Query.Client - ( RunClient(..) - , HasClient(..) - , ClientResponse(..) - ) where - -import Control.Lens (to, (^.)) -import Control.Monad.Reader (ReaderT) -import qualified Data.ByteArray.Base64String as Base64 -import qualified Data.ByteArray.HexString as Hex -import Data.ByteString (ByteString) -import Data.Proxy -import Data.String.Conversions (cs) -import GHC.TypeLits (KnownSymbol, symbolVal) -import qualified Network.ABCI.Types.Messages.Request as Req -import qualified Network.ABCI.Types.Messages.Response as Resp -import qualified Network.Tendermint.Client as RPC -import Servant.API ((:<|>) (..), (:>)) -import Tendermint.SDK.BaseApp.Query.Types (Leaf, QA, QueryArgs (..), - Queryable (..)) -import Tendermint.SDK.BaseApp.Store (RawKey (..)) - -class Monad m => RunClient m where - -- | How to make a request. - runQuery :: Req.Query -> m Resp.Query - -instance RunClient (ReaderT RPC.Config IO) where - runQuery Req.Query{..} = - let rpcQ = RPC.RequestABCIQuery - { RPC.requestABCIQueryPath = Just queryPath - , RPC.requestABCIQueryData = Hex.fromBytes @ByteString . Base64.toBytes $ queryData - , RPC.requestABCIQueryHeight = Just $ queryHeight - , RPC.requestABCIQueryProve = queryProve - } - in RPC.resultABCIQueryResponse <$> RPC.abciQuery rpcQ - -class HasClient m layout where - - type ClientT (m :: * -> *) layout :: * - genClient :: Proxy m -> Proxy layout -> Req.Query -> ClientT m layout - -instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where - type ClientT m (a :<|> b) = ClientT m a :<|> ClientT m b - genClient pm _ q = genClient pm (Proxy @a) q :<|> genClient pm (Proxy @b) q - -instance (KnownSymbol path, HasClient m a) => HasClient m (path :> a) where - type ClientT m (path :> a) = ClientT m a - genClient pm _ q = genClient pm (Proxy @a) - q {Req.queryPath = Req.queryPath q <> "/" <> cs (symbolVal (Proxy @path))} - -instance (RawKey k, HasClient m a) => HasClient m (QA k :> a) where - type ClientT m (QA k :> a) = QueryArgs k -> ClientT m a - genClient pm _ q QueryArgs{..} = genClient pm (Proxy @a) - q { Req.queryData = queryArgsData ^. rawKey . to Base64.fromBytes - , Req.queryHeight = queryArgsHeight - , Req.queryProve = queryArgsProve - } - --- | Data is Nothing iff Raw includes a non-0 response value -data ClientResponse a = ClientResponse - { clientResponseData :: Maybe a - , clientResponseRaw :: Resp.Query - } - -instance (RunClient m, Queryable a, name ~ Name a, KnownSymbol name ) => HasClient m (Leaf a) where - type ClientT m (Leaf a) = m (ClientResponse a) - genClient _ _ q = - let leaf = symbolVal (Proxy @(Name a)) - in do - r@Resp.Query{..} <- runQuery q { Req.queryPath = Req.queryPath q <> "/" <> cs leaf } - -- anything other than 0 code is a failure: https://tendermint.readthedocs.io/en/latest/abci-spec.html - -- and will result in queryValue decoding to a "empty/default" object - return $ case queryCode of - 0 -> case decodeQueryResult queryValue of - Left err -> error $ "Impossible parse error: " <> cs err - Right a -> ClientResponse (Just a) r - _ -> ClientResponse Nothing r diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/EventSpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/EventSpec.hs deleted file mode 100644 index b4f1f77d..00000000 --- a/hs-abci-sdk/test/Tendermint/SDK/Test/EventSpec.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Tendermint.SDK.Test.EventSpec where - -import qualified Data.Aeson as A -import GHC.Generics (Generic) -import Tendermint.SDK.BaseApp.Events (FromEvent (..), ToEvent (..), - makeEvent) -import Test.Hspec - -spec :: Spec -spec = describe "Event Tests" $ do - it "Can serialize and deserialize and event" $ do - let transferEv = Transfer - { to = "me" - , from = "you" - , amount = 1 - } - fromEvent (makeEvent transferEv) `shouldBe` Right transferEv - -data Transfer = Transfer - { to :: String - , from :: String - , amount :: Int - } deriving (Eq, Show, Generic) - -instance A.ToJSON Transfer - -instance ToEvent Transfer where - makeEventType _ = "transfer" - -instance A.FromJSON Transfer -instance FromEvent Transfer diff --git a/hs-abci-test-utils/package.yaml b/hs-abci-test-utils/package.yaml index d51dd24b..0159eac1 100644 --- a/hs-abci-test-utils/package.yaml +++ b/hs-abci-test-utils/package.yaml @@ -25,7 +25,6 @@ dependencies: - errors - lens - mtl -- polysemy - servant - string-conversions - text @@ -34,12 +33,9 @@ dependencies: - hs-tendermint-client default-extensions: - - DataKinds - DefaultSignatures - DeriveGeneric - - FlexibleContexts - FlexibleInstances - - LambdaCase - MultiParamTypeClasses - NamedFieldPuns - OverloadedStrings diff --git a/hs-abci-test-utils/src/Tendermint/Utils/Events.hs b/hs-abci-test-utils/src/Tendermint/Utils/Events.hs index 991a2919..4f4e9cd3 100644 --- a/hs-abci-test-utils/src/Tendermint/Utils/Events.hs +++ b/hs-abci-test-utils/src/Tendermint/Utils/Events.hs @@ -1,51 +1,16 @@ -module Tendermint.Utils.Events - ( Event(..) - , ToEvent(..) - , FromEvent(..) - , emit - , makeEvent - , EventBuffer - , newEventBuffer - , withEventBuffer - , evalWithBuffer - ) where +module Tendermint.Utils.Events where -import qualified Control.Concurrent.MVar as MVar import Control.Error (fmapL) -import Control.Monad (void) -import Control.Monad.IO.Class import qualified Data.Aeson as A -import Data.Bifunctor (bimap) import qualified Data.ByteArray.Base64String as Base64 import qualified Data.ByteString as BS -import qualified Data.List as L import Data.Proxy import Data.String.Conversions (cs) import Data.Text (Text) -import GHC.Exts (fromList, toList) +import GHC.Exts (fromList) import Network.ABCI.Types.Messages.FieldTypes (Event (..), KVPair (..)) -import Polysemy (Embed, Member, Sem, - interpret) -import Polysemy.Output (Output (..), output) -import Polysemy.Reader (Reader (..), ask) -import Polysemy.Resource (Resource, onException) - -{- -TODO : These JSON instances are fragile but convenient. We -should come up with a custom solution. --} - --- | A class representing a type that can be emitted as an event in the --- | event logs for the deliverTx response. -class ToEvent e where - makeEventType :: Proxy e -> String - makeEventData :: e -> [(BS.ByteString, BS.ByteString)] - - default makeEventData :: A.ToJSON e => e -> [(BS.ByteString, BS.ByteString)] - makeEventData e = case A.toJSON e of - A.Object obj -> bimap cs (cs . A.encode) <$> toList obj - _ -> mempty +import Tendermint.SDK.BaseApp.Events (ToEvent, makeEventType) -- | A class that can parse event log items in the deliverTx response. Primarily -- | useful for client applications and testing. @@ -66,62 +31,3 @@ class ToEvent e => FromEvent e where in fmapL cs $ do kvPairs <- traverse fromKVPair eventAttributes A.eitherDecode . A.encode . A.Object . fromList $ kvPairs - --- This is the internal implementation of the interpreter for event --- logging. We allocate a buffer that can queue events as they are thrown, --- then flush the buffer at the end of transaction execution. It will --- also flush in the event that exceptions are thrown. - -data EventBuffer = EventBuffer (MVar.MVar [Event]) - -newEventBuffer :: IO EventBuffer -newEventBuffer = EventBuffer <$> MVar.newMVar [] - -appendEvent - :: MonadIO (Sem r) - => Event - -> EventBuffer - -> Sem r () -appendEvent e (EventBuffer b) = do - liftIO (MVar.modifyMVar_ b (pure . (e :))) - -flushEventBuffer - :: MonadIO (Sem r) - => EventBuffer - -> Sem r [Event] -flushEventBuffer (EventBuffer b) = do - liftIO (L.reverse <$> MVar.swapMVar b []) - -withEventBuffer - :: Member Resource r - => Member (Reader EventBuffer) r - => MonadIO (Sem r) - => Sem r () - -> Sem r [Event] -withEventBuffer action = do - buffer <- ask - onException (action *> flushEventBuffer buffer) (void $ flushEventBuffer buffer) - -makeEvent - :: ToEvent e - => e - -> Event -makeEvent (e :: e) = Event - { eventType = cs $ makeEventType (Proxy :: Proxy e) - , eventAttributes = (\(k, v) -> KVPair (Base64.fromBytes k) (Base64.fromBytes v)) <$> makeEventData e - } - -emit - :: ToEvent e - => Member (Output Event) r - => e - -> Sem r () -emit e = output $ makeEvent e - -evalWithBuffer - :: Member (Embed IO) r - => Member (Reader EventBuffer) r - => (forall a. Sem (Output Event ': r) a -> Sem r a) -evalWithBuffer action = interpret (\case - Output e -> ask >>= appendEvent e - ) action diff --git a/hs-abci-test-utils/stack.yaml b/hs-abci-test-utils/stack.yaml deleted file mode 100644 index 29f85393..00000000 --- a/hs-abci-test-utils/stack.yaml +++ /dev/null @@ -1,66 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-14.17 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.1" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs b/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs index 267dce58..5c1b247a 100644 --- a/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs +++ b/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs @@ -2,8 +2,9 @@ module Tendermint.Utils.Test.EventSpec where import qualified Data.Aeson as A import GHC.Generics (Generic) -import Tendermint.SDK.BaseApp.Events (FromEvent (..), ToEvent (..), +import Tendermint.SDK.BaseApp.Events (ToEvent (..), makeEvent) +import Tendermint.Utils.Events (FromEvent(..)) import Test.Hspec spec :: Spec From 5eca2071c1c366e542f73d92edc7457b663513cf Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 12 Dec 2019 17:00:42 -0500 Subject: [PATCH 05/30] nameservice tests passing --- Makefile | 4 ++-- .../src/Nameservice/Modules/Nameservice/Types.hs | 2 +- .../nameservice/src/Nameservice/Modules/Token/Types.hs | 2 +- .../nameservice/test/Nameservice/Test/E2ESpec.hs | 10 +++++----- .../test/Tendermint/Utils/Test/EventSpec.hs | 5 ++--- 5 files changed, 11 insertions(+), 12 deletions(-) diff --git a/Makefile b/Makefile index bd16d9fc..b9b06a71 100644 --- a/Makefile +++ b/Makefile @@ -15,7 +15,7 @@ hlint: ## Run hlint on all haskell projects hs-tendermint-client \ hs-abci-extra \ hs-abci-sdk \ - hs-abci-test-utils \ + hs-abci-test-utils \ hs-abci-examples/simple-storage \ hs-abci-examples/nameservice @@ -25,7 +25,7 @@ stylish: ## Run stylish-haskell over all haskell projects ./hs-tendermint-client \ ./hs-abci-examples \ ./hs-abci-sdk \ - ./hs-abci-test-utils \ + ./hs-abci-test-utils \ ./hs-abci-server \ -name "*.hs" | xargs stack exec stylish-haskell -- -c ./.stylish_haskell.yaml -i 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 38ff9e62..de3e9df7 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Types.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Types.hs @@ -19,7 +19,7 @@ import qualified Proto3.Wire.Encode as Encode import qualified Tendermint.SDK.BaseApp as BaseApp import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Types.Address (Address) -import qualified Tendermint.Utils.Events as Event +import qualified Tendermint.Utils.Events as Event -------------------------------------------------------------------------------- diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs index 2e8c4446..786cbde7 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs @@ -20,7 +20,7 @@ import qualified Tendermint.SDK.BaseApp as BaseApp import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Types.Address (Address, addressFromBytes, addressToBytes) -import qualified Tendermint.Utils.Events as Event +import qualified Tendermint.Utils.Events as Event -------------------------------------------------------------------------------- diff --git a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs index 83ce9ec0..b409086d 100644 --- a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs +++ b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs @@ -43,19 +43,19 @@ import qualified Network.Tendermint.Client as RPC import Proto3.Suite (Message, toLazyByteString) import Servant.API ((:<|>) (..), (:>)) -import Tendermint.SDK.BaseApp (FromEvent (..), - QueryApi) +import Tendermint.SDK.BaseApp (QueryApi) import Tendermint.SDK.BaseApp.Query (QueryArgs (..), defaultQueryWithData) -import Tendermint.Utils.Client (ClientResponse (..), - HasClient (..), - RunClient (..)) import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Crypto (Secp256k1, addressFromPubKey) import Tendermint.SDK.Types.Address (Address (..)) import Tendermint.SDK.Types.Transaction (RawTransaction (..), signRawTransaction) +import Tendermint.Utils.Client (ClientResponse (..), + HasClient (..), + RunClient (..)) +import Tendermint.Utils.Events (FromEvent (..)) import Test.Hspec spec :: Spec diff --git a/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs b/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs index 5c1b247a..926a6692 100644 --- a/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs +++ b/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs @@ -2,9 +2,8 @@ module Tendermint.Utils.Test.EventSpec where import qualified Data.Aeson as A import GHC.Generics (Generic) -import Tendermint.SDK.BaseApp.Events (ToEvent (..), - makeEvent) -import Tendermint.Utils.Events (FromEvent(..)) +import Tendermint.SDK.BaseApp.Events (ToEvent (..), makeEvent) +import Tendermint.Utils.Events (FromEvent (..)) import Test.Hspec spec :: Spec From b1e76808395a56e29d1a70f718e455b47ff6883b Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 12 Dec 2019 17:29:42 -0500 Subject: [PATCH 06/30] use utils in ss --- hs-abci-examples/simple-storage/package.yaml | 1 + .../simple-storage/test/SimpleStorage/Test/E2ESpec.hs | 6 +++--- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/hs-abci-examples/simple-storage/package.yaml b/hs-abci-examples/simple-storage/package.yaml index 817aeb6b..162bbfdd 100644 --- a/hs-abci-examples/simple-storage/package.yaml +++ b/hs-abci-examples/simple-storage/package.yaml @@ -126,6 +126,7 @@ tests: - data-default-class - simple-storage - hs-abci-types + - hs-abci-test-utils - hs-tendermint-client - hspec - QuickCheck diff --git a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs b/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs index 91c9244f..326cea07 100644 --- a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs +++ b/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs @@ -24,15 +24,15 @@ import qualified Network.Tendermint.Client as RPC import Servant.API ((:>)) import qualified SimpleStorage.Modules.SimpleStorage as SS import Tendermint.SDK.BaseApp.Query (QueryArgs (..)) -import Tendermint.SDK.BaseApp.Query.Client (ClientResponse (..), - HasClient (..), - RunClient (..)) import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Crypto (Secp256k1, addressFromPubKey) import Tendermint.SDK.Types.Address (Address (..)) import Tendermint.SDK.Types.Transaction (RawTransaction (..), signRawTransaction) +import Tendermint.Utils.Client (ClientResponse (..), + HasClient (..), + RunClient (..)) import Test.Hspec From ffa8c9ac94a614c5383abf2bcc1edca1de1c5cda Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 12 Dec 2019 17:55:18 -0500 Subject: [PATCH 07/30] use new user module in nameservice tests --- .../test/Nameservice/Test/E2ESpec.hs | 29 +----------- hs-abci-sdk/package.yaml | 1 - hs-abci-test-utils/package.yaml | 1 + .../src/Tendermint/Utils/User.hs | 46 +++++++++++++++++++ 4 files changed, 48 insertions(+), 29 deletions(-) create mode 100644 hs-abci-test-utils/src/Tendermint/Utils/User.hs diff --git a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs index b409086d..cb649443 100644 --- a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs +++ b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs @@ -56,6 +56,7 @@ import Tendermint.Utils.Client (ClientResponse (..), HasClient (..), RunClient (..)) import Tendermint.Utils.Events (FromEvent (..)) +import Tendermint.Utils.User (User (..), makeUser, mkSignedRawTransactionWithRoute) import Test.Hspec spec :: Spec @@ -291,37 +292,12 @@ encodeRawTx = Base64.fromBytes . encode encodeMsgData :: Message a => a -> BS.ByteString encodeMsgData = BL.toStrict . toLazyByteString --- sign a trx with a user's private key -mkSignedRawTransactionWithRoute :: Message a => BS.ByteString -> SecKey -> a -> RawTransaction -mkSignedRawTransactionWithRoute route privateKey msg = sign unsigned - where unsigned = RawTransaction { rawTransactionData = encodeMsgData msg - , rawTransactionRoute = cs route - , rawTransactionSignature = "" - } - sig = signRawTransaction algProxy privateKey unsigned - sign rt = rt { rawTransactionSignature = encodeCompactRecSig $ exportCompactRecSig sig } - -data User = User - { userPrivKey :: SecKey - , userAddress :: Address - } - user1 :: User user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" user2 :: User user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" -makeUser :: String -> User -makeUser privKeyStr = - let privateKey = fromJust . secKey . Hex.toBytes . fromString $ privKeyStr - pubKey = derivePubKey privateKey - address = addressFromPubKey (Proxy @Secp256k1) pubKey - in User privateKey address - -algProxy :: Proxy Secp256k1 -algProxy = Proxy - -------------------------------------------------------------------------------- getWhois :: QueryArgs Name -> RPC.TendermintM (ClientResponse Whois) @@ -332,6 +308,3 @@ apiP = Proxy (getBalance :<|> getWhois) = genClient (Proxy :: Proxy RPC.TendermintM) apiP def - -encodeCompactRecSig :: CompactRecSig -> ByteString -encodeCompactRecSig (CompactRecSig r s v) = snoc (fromShort r <> fromShort s) v diff --git a/hs-abci-sdk/package.yaml b/hs-abci-sdk/package.yaml index fbe9aa25..331f7519 100644 --- a/hs-abci-sdk/package.yaml +++ b/hs-abci-sdk/package.yaml @@ -59,7 +59,6 @@ dependencies: - exceptions - hs-abci-types - hs-abci-server -- hs-tendermint-client - http-types - katip - lens diff --git a/hs-abci-test-utils/package.yaml b/hs-abci-test-utils/package.yaml index 0159eac1..b94f0455 100644 --- a/hs-abci-test-utils/package.yaml +++ b/hs-abci-test-utils/package.yaml @@ -25,6 +25,7 @@ dependencies: - errors - lens - mtl +- secp256k1-haskell - servant - string-conversions - text diff --git a/hs-abci-test-utils/src/Tendermint/Utils/User.hs b/hs-abci-test-utils/src/Tendermint/Utils/User.hs new file mode 100644 index 00000000..4564fdff --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/User.hs @@ -0,0 +1,46 @@ +module Tendermint.Utils.User where + +import Crypto.Secp256k1 (CompactRecSig (..), SecKey, + derivePubKey, + exportCompactRecSig, secKey) +import qualified Data.ByteArray.HexString as Hex +import Data.ByteString (ByteString, snoc) +import qualified Data.ByteString as BS +import Data.ByteString.Short (fromShort) +import Data.Maybe (fromJust) +import Data.Proxy +import Data.String (fromString) +import Data.String.Conversions (cs) +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Crypto (Secp256k1, addressFromPubKey) +import Tendermint.SDK.Types.Address (Address (..)) +import Tendermint.SDK.Types.Transaction (RawTransaction (..), + signRawTransaction) + +data User = User + { userPrivKey :: SecKey + , userAddress :: Address + } + +makeUser :: String -> User +makeUser privKeyStr = + let privateKey = fromJust . secKey . Hex.toBytes . fromString $ privKeyStr + pubKey = derivePubKey privateKey + address = addressFromPubKey (Proxy @Secp256k1) pubKey + in User privateKey address + +algProxy :: Proxy Secp256k1 +algProxy = Proxy + +-- sign a trx with a user's private key +mkSignedRawTransactionWithRoute :: HasCodec a => BS.ByteString -> SecKey -> a -> RawTransaction +mkSignedRawTransactionWithRoute route privateKey msg = sign unsigned + where unsigned = RawTransaction { rawTransactionData = encode msg + , rawTransactionRoute = cs route + , rawTransactionSignature = "" + } + sig = signRawTransaction algProxy privateKey unsigned + sign rt = rt { rawTransactionSignature = encodeCompactRecSig $ exportCompactRecSig sig } + +encodeCompactRecSig :: CompactRecSig -> ByteString +encodeCompactRecSig (CompactRecSig r s v) = snoc (fromShort r <> fromShort s) v From 7c007086b707fa148be3e85fa2b78a6287e625ab Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 12 Dec 2019 17:57:07 -0500 Subject: [PATCH 08/30] delete special msg encoder --- hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs index cb649443..dabc7816 100644 --- a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs +++ b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs @@ -289,9 +289,6 @@ decodeValue = (\(Right a) -> a) . decode . Base64.toBytes encodeRawTx :: RawTransaction -> Base64.Base64String encodeRawTx = Base64.fromBytes . encode -encodeMsgData :: Message a => a -> BS.ByteString -encodeMsgData = BL.toStrict . toLazyByteString - user1 :: User user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" From 12d2319b459ee51e973a7f391dd107e969d856d5 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Fri, 13 Dec 2019 12:43:04 -0500 Subject: [PATCH 09/30] use user util module in simple storage tests --- .../test/SimpleStorage/Test/E2ESpec.hs | 48 +------------------ 1 file changed, 2 insertions(+), 46 deletions(-) diff --git a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs b/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs index 326cea07..e0a5a7e3 100644 --- a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs +++ b/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs @@ -2,21 +2,13 @@ module SimpleStorage.Test.E2ESpec where import Control.Lens ((^.)) import Control.Monad.Reader (ReaderT) -import Crypto.Secp256k1 (SecKey, derivePubKey, - exportCompactRecSig, - secKey) import Data.Aeson (ToJSON) import Data.Aeson.Encode.Pretty (encodePretty) -import Data.ByteArray.Base64String (Base64String) import qualified Data.ByteArray.Base64String as Base64 import qualified Data.ByteArray.HexString as Hex import Data.ByteString (ByteString) import Data.Default.Class (def) -import Data.Int (Int32) -import Data.Maybe (fromJust) import Data.Proxy -import qualified Data.Serialize as Serial -import Data.String (fromString) import Data.String.Conversions (cs) import qualified Network.ABCI.Types.Messages.Request as Req import qualified Network.ABCI.Types.Messages.Response as Resp @@ -25,14 +17,10 @@ import Servant.API ((:>)) import qualified SimpleStorage.Modules.SimpleStorage as SS import Tendermint.SDK.BaseApp.Query (QueryArgs (..)) import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Crypto (Secp256k1, - addressFromPubKey) -import Tendermint.SDK.Types.Address (Address (..)) -import Tendermint.SDK.Types.Transaction (RawTransaction (..), - signRawTransaction) import Tendermint.Utils.Client (ClientResponse (..), HasClient (..), RunClient (..)) +import Tendermint.Utils.User (User (..), makeUser, mkSignedRawTransactionWithRoute) import Test.Hspec @@ -55,7 +43,7 @@ spec = do it "Can submit a tx synchronously and make sure that the response code is 0 (success)" $ do let txMsg = SS.UpdateCount $ SS.UpdateCountTx "irakli" 4 - tx = mkSignedRawTransaction (userPrivKey user1) txMsg + tx = mkSignedRawTransactionWithRoute "simple_storage" (userPrivKey user1) txMsg txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = Base64.fromBytes . encode $ tx } @@ -72,13 +60,6 @@ spec = do ClientResponse{clientResponseData = Just foundCount} <- runQueryRunner $ getCount queryReq foundCount `shouldBe` SS.Count 4 - -encodeCount :: Int32 -> Base64String -encodeCount = Base64.fromBytes . Serial.encode - -decodeCount :: Base64String -> Int32 -decodeCount = (\(Right a) -> a) . Serial.decode . Base64.toBytes - runRPC :: forall a. RPC.TendermintM a -> IO a runRPC = RPC.runTendermintM rpcConfig where @@ -113,30 +94,5 @@ getCount = let apiP = Proxy :: Proxy ("simple_storage" :> SS.Api) in genClient (Proxy :: Proxy QueryRunner) apiP def --- sign a tx with a user's private key -mkSignedRawTransaction :: SecKey -> SS.SimpleStorageMessage -> RawTransaction -mkSignedRawTransaction privateKey msg = sign unsigned - where unsigned = RawTransaction { rawTransactionData = encode msg - , rawTransactionRoute = "simple_storage" - , rawTransactionSignature = "" - } - sig = signRawTransaction algProxy privateKey unsigned - sign rt = rt { rawTransactionSignature = Serial.encode $ exportCompactRecSig sig } - -data User = User - { userPrivKey :: SecKey - , userAddress :: Address - } - user1 :: User user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" - -makeUser :: String -> User -makeUser privKeyStr = - let privateKey = fromJust . secKey . Hex.toBytes . fromString $ privKeyStr - pubKey = derivePubKey privateKey - address = addressFromPubKey (Proxy @Secp256k1) pubKey - in User privateKey address - -algProxy :: Proxy Secp256k1 -algProxy = Proxy From e17127dfd1ff7a72809c5667505743b715cae9ae Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Fri, 13 Dec 2019 12:59:38 -0500 Subject: [PATCH 10/30] move response checkers to utils library --- .../test/Nameservice/Test/E2ESpec.hs | 33 ++--------------- hs-abci-test-utils/package.yaml | 2 ++ .../src/Tendermint/Utils/Response.hs | 36 +++++++++++++++++++ 3 files changed, 41 insertions(+), 30 deletions(-) create mode 100644 hs-abci-test-utils/src/Tendermint/Utils/Response.hs diff --git a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs index dabc7816..d25d894b 100644 --- a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs +++ b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs @@ -56,6 +56,8 @@ import Tendermint.Utils.Client (ClientResponse (..), HasClient (..), RunClient (..)) import Tendermint.Utils.Events (FromEvent (..)) +import Tendermint.Utils.Response (ensureDeliverResponseCode, + ensureEventLogged) import Tendermint.Utils.User (User (..), makeUser, mkSignedRawTransactionWithRoute) import Test.Hspec @@ -246,6 +248,7 @@ getDeliverTxResponse rawTx = do fmap RPC.resultBroadcastTxCommitDeliverTx . runRPC $ RPC.broadcastTxCommit txReq +-- executes a request, check deliver and response codes ensureCheckAndDeliverResponseCodes :: (Word32, Word32) -> RawTransaction -> IO () ensureCheckAndDeliverResponseCodes codes rawTx = do let txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeRawTx rawTx } @@ -254,38 +257,8 @@ ensureCheckAndDeliverResponseCodes codes rawTx = do deliverResp = RPC.resultBroadcastTxCommitDeliverTx resp codes `shouldBe` (checkResp ^. Response._checkTxCode, deliverResp ^. Response._deliverTxCode) - --- get the logged events from a deliver response, -deliverTxEvents :: FromEvent e => Response.DeliverTx -> Text -> IO ([Text],[e]) -deliverTxEvents deliverResp eventName = do - let deliverEvents = deliverResp ^. Response._deliverTxEvents - filtered = filter ((== eventName) . eventType) deliverEvents - return . partitionEithers . map fromEvent $ filtered - --- ensures there are no errors when parsing event logs and contains the expectedEvent -ensureEventLogged :: (Eq e, Show e, FromEvent e) => Response.DeliverTx -> Text -> e -> IO () -ensureEventLogged deliverResp eventName expectedEvent = do - (errs, events) <- deliverTxEvents deliverResp eventName - errs `shouldBe` mempty - events `shouldSatisfy` elem expectedEvent - --- check for a specific check response code -ensureCheckResponseCode :: Response.CheckTx -> Word32 -> IO () -ensureCheckResponseCode checkResp code = do - let checkRespCode = checkResp ^. Response._checkTxCode - checkRespCode `shouldBe` code - --- check for a specific deliver response code -ensureDeliverResponseCode :: Response.DeliverTx -> Word32 -> IO () -ensureDeliverResponseCode deliverResp code = do - let deliverRespCode = deliverResp ^. Response._deliverTxCode - deliverRespCode `shouldBe` code - -------------------------------------------------------------------------------- -decodeValue :: HasCodec a => Base64.Base64String -> a -decodeValue = (\(Right a) -> a) . decode . Base64.toBytes - encodeRawTx :: RawTransaction -> Base64.Base64String encodeRawTx = Base64.fromBytes . encode diff --git a/hs-abci-test-utils/package.yaml b/hs-abci-test-utils/package.yaml index b94f0455..3703e303 100644 --- a/hs-abci-test-utils/package.yaml +++ b/hs-abci-test-utils/package.yaml @@ -23,6 +23,7 @@ dependencies: - base >= 4.7 && < 5 - bytestring - errors +- hspec - lens - mtl - secp256k1-haskell @@ -33,6 +34,7 @@ dependencies: - hs-abci-sdk - hs-tendermint-client + default-extensions: - DefaultSignatures - DeriveGeneric diff --git a/hs-abci-test-utils/src/Tendermint/Utils/Response.hs b/hs-abci-test-utils/src/Tendermint/Utils/Response.hs new file mode 100644 index 00000000..21aad542 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/Response.hs @@ -0,0 +1,36 @@ +module Tendermint.Utils.Response where + +import Control.Lens ((^.)) +import Data.Either (partitionEithers) +import Data.Text (Text) +import Data.Word (Word32) +import Network.ABCI.Types.Messages.FieldTypes (Event (..)) +import qualified Network.ABCI.Types.Messages.Response as Response +import Tendermint.Utils.Events (FromEvent (..)) +import Test.Hspec + +-- get the logged events from a deliver response, +deliverTxEvents :: FromEvent e => Response.DeliverTx -> Text -> IO ([Text],[e]) +deliverTxEvents deliverResp eventName = do + let deliverEvents = deliverResp ^. Response._deliverTxEvents + filtered = filter ((== eventName) . eventType) deliverEvents + return . partitionEithers . map fromEvent $ filtered + +-- ensures there are no errors when parsing event logs and contains the expectedEvent +ensureEventLogged :: (Eq e, Show e, FromEvent e) => Response.DeliverTx -> Text -> e -> IO () +ensureEventLogged deliverResp eventName expectedEvent = do + (errs, events) <- deliverTxEvents deliverResp eventName + errs `shouldBe` mempty + events `shouldSatisfy` elem expectedEvent + +-- check for a specific check response code +ensureCheckResponseCode :: Response.CheckTx -> Word32 -> IO () +ensureCheckResponseCode checkResp code = do + let checkRespCode = checkResp ^. Response._checkTxCode + checkRespCode `shouldBe` code + +-- check for a specific deliver response code +ensureDeliverResponseCode :: Response.DeliverTx -> Word32 -> IO () +ensureDeliverResponseCode deliverResp code = do + let deliverRespCode = deliverResp ^. Response._deliverTxCode + deliverRespCode `shouldBe` code From 05bfd1dc446df6a4a3ed3a974d1258e1f7fd7ad6 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Fri, 13 Dec 2019 13:27:02 -0500 Subject: [PATCH 11/30] move request runners to new request module --- hs-abci-examples/nameservice/package.yaml | 9 + .../test/Nameservice/Test/E2ESpec.hs | 155 +++++------------- hs-abci-examples/simple-storage/package.yaml | 5 + .../test/SimpleStorage/Test/E2ESpec.hs | 45 +---- hs-abci-test-utils/package.yaml | 1 + .../src/Tendermint/Utils/Request.hs | 59 +++++++ 6 files changed, 121 insertions(+), 153 deletions(-) create mode 100644 hs-abci-test-utils/src/Tendermint/Utils/Request.hs diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index bbce5db3..28d9c622 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -111,6 +111,13 @@ executables: - -rtsopts - -with-rtsopts=-N - -fplugin=Polysemy.Plugin + - -Werror + - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wredundant-constraints dependencies: - nameservice @@ -131,6 +138,8 @@ tests: other-modules: - Nameservice.Test.E2ESpec ghc-options: + - -Werror + - -Wall - -threaded - -rtsopts - -with-rtsopts=-N diff --git a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs index d25d894b..8b5b010c 100644 --- a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs +++ b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs @@ -1,64 +1,39 @@ module Nameservice.Test.E2ESpec where -import Control.Lens ((^.)) -import Crypto.Secp256k1 (CompactRecSig (..), - SecKey, derivePubKey, - exportCompactRecSig, - secKey) -import Data.Aeson (ToJSON) -import Data.Aeson.Encode.Pretty (encodePretty) -import qualified Data.ByteArray.Base64String as Base64 -import qualified Data.ByteArray.HexString as Hex -import Data.ByteString (ByteString, snoc) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import Data.ByteString.Short (fromShort) -import Data.Default.Class (def) -import Data.Either (partitionEithers) -import Data.Maybe (fromJust) +import Control.Lens ((^.)) +import Data.Default.Class (def) import Data.Proxy -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Word (Word32) -import Nameservice.Modules.Nameservice (BuyName (..), - DeleteName (..), - Name (..), - NameClaimed (..), - NameDeleted (..), - NameRemapped (..), - SetName (..), - Whois (..)) -import qualified Nameservice.Modules.Nameservice as N (Api) -import Nameservice.Modules.Token (Amount (..), - FaucetAccount (..), - Faucetted (..), - Transfer (..), - TransferEvent (..)) -import qualified Nameservice.Modules.Token as T (Api) -import Nameservice.Modules.TypedMessage (TypedMessage (..)) -import Network.ABCI.Types.Messages.FieldTypes (Event (..)) -import qualified Network.ABCI.Types.Messages.Response as Response -import qualified Network.Tendermint.Client as RPC -import Proto3.Suite (Message, - toLazyByteString) -import Servant.API ((:<|>) (..), (:>)) -import Tendermint.SDK.BaseApp (QueryApi) -import Tendermint.SDK.BaseApp.Query (QueryArgs (..), - defaultQueryWithData) -import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Crypto (Secp256k1, - addressFromPubKey) -import Tendermint.SDK.Types.Address (Address (..)) -import Tendermint.SDK.Types.Transaction (RawTransaction (..), - signRawTransaction) -import Tendermint.Utils.Client (ClientResponse (..), - HasClient (..), - RunClient (..)) -import Tendermint.Utils.Events (FromEvent (..)) -import Tendermint.Utils.Response (ensureDeliverResponseCode, - ensureEventLogged) -import Tendermint.Utils.User (User (..), makeUser, mkSignedRawTransactionWithRoute) +import Nameservice.Modules.Nameservice (BuyName (..), + DeleteName (..), + Name (..), + NameClaimed (..), + NameDeleted (..), + NameRemapped (..), + SetName (..), Whois (..)) +import qualified Nameservice.Modules.Nameservice as N (Api) +import Nameservice.Modules.Token (Amount (..), + FaucetAccount (..), + Faucetted (..), + Transfer (..), + TransferEvent (..)) +import qualified Nameservice.Modules.Token as T (Api) +import Nameservice.Modules.TypedMessage (TypedMessage (..)) +import qualified Network.ABCI.Types.Messages.Response as Response +import qualified Network.Tendermint.Client as RPC +import Servant.API ((:<|>) (..), (:>)) +import Tendermint.SDK.BaseApp.Query (QueryArgs (..), + defaultQueryWithData) +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Address (Address (..)) +import Tendermint.Utils.Client (ClientResponse (..), + HasClient (..)) +import Tendermint.Utils.Request (ensureCheckAndDeliverResponseCodes, + getDeliverTxResponse, + getQueryResponseSuccess, + runRPC) +import Tendermint.Utils.Response (ensureDeliverResponseCode, + ensureEventLogged) +import Tendermint.Utils.User (User (..), makeUser, mkSignedRawTransactionWithRoute) import Test.Hspec spec :: Spec @@ -124,8 +99,7 @@ spec = do ensureCheckAndDeliverResponseCodes (0,2) rawTx it "Can buy an existing name (success 0)" $ do - let oldVal = "goodbye to a world" - newVal = "hello (again) world" + let newVal = "hello (again) world" msg = TypedMessage "BuyName" (encode $ BuyName 300 satoshi newVal addr2) claimedLog = NameClaimed addr2 satoshi newVal 300 rawTx = mkSignedRawTransactionWithRoute "nameservice" privateKey2 msg @@ -207,15 +181,14 @@ spec = do senderAfterFoundAmount <- getQueryResponseSuccess $ getBalance senderAfterQueryReq senderAfterFoundAmount `shouldBe` Amount 1200 -runRPC :: forall a. RPC.TendermintM a -> IO a -runRPC = RPC.runTendermintM rpcConfig - where - rpcConfig :: RPC.Config - rpcConfig = - let RPC.Config baseReq _ _ = RPC.defaultConfig "localhost" 26657 - prettyPrint :: forall b. ToJSON b => String -> b -> IO () - prettyPrint prefix a = putStrLn $ prefix <> "\n" <> (cs . encodePretty $ a) - in RPC.Config baseReq (prettyPrint "RPC Request") (prettyPrint "RPC Response") +-------------------------------------------------------------------------------- +user1 :: User +user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" + +user2 :: User +user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" + +-------------------------------------------------------------------------------- faucetAccount :: User -> IO () faucetAccount User{userAddress, userPrivKey} = do @@ -226,50 +199,6 @@ faucetAccount User{userAddress, userPrivKey} = do ensureDeliverResponseCode deliverResp 0 ensureEventLogged deliverResp "Faucetted" faucetEvent --- executes a query and ensures a 0 response code -getQueryResponseSuccess :: RPC.TendermintM (ClientResponse a) -> IO a -getQueryResponseSuccess query = do - ClientResponse{clientResponseData,clientResponseRaw} <- runRPC query - let responseCode = clientResponseRaw ^. Response._queryCode - responseCode `shouldBe` 0 - return . fromJust $ clientResponseData - --- executes a request, then returns the checkTx response -getCheckTxResponse :: RawTransaction -> IO Response.CheckTx -getCheckTxResponse rawTx = do - let txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeRawTx rawTx } - fmap RPC.resultBroadcastTxCommitCheckTx . runRPC $ - RPC.broadcastTxCommit txReq - --- executes a request, then returns the deliverTx response -getDeliverTxResponse :: RawTransaction -> IO Response.DeliverTx -getDeliverTxResponse rawTx = do - let txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeRawTx rawTx } - fmap RPC.resultBroadcastTxCommitDeliverTx . runRPC $ - RPC.broadcastTxCommit txReq - --- executes a request, check deliver and response codes -ensureCheckAndDeliverResponseCodes :: (Word32, Word32) -> RawTransaction -> IO () -ensureCheckAndDeliverResponseCodes codes rawTx = do - let txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeRawTx rawTx } - resp <- runRPC $ RPC.broadcastTxCommit txReq - let checkResp = RPC.resultBroadcastTxCommitCheckTx resp - deliverResp = RPC.resultBroadcastTxCommitDeliverTx resp - codes `shouldBe` (checkResp ^. Response._checkTxCode, deliverResp ^. Response._deliverTxCode) - --------------------------------------------------------------------------------- - -encodeRawTx :: RawTransaction -> Base64.Base64String -encodeRawTx = Base64.fromBytes . encode - -user1 :: User -user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" - -user2 :: User -user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" - --------------------------------------------------------------------------------- - getWhois :: QueryArgs Name -> RPC.TendermintM (ClientResponse Whois) getBalance :: QueryArgs Address -> RPC.TendermintM (ClientResponse Amount) diff --git a/hs-abci-examples/simple-storage/package.yaml b/hs-abci-examples/simple-storage/package.yaml index 162bbfdd..f9866968 100644 --- a/hs-abci-examples/simple-storage/package.yaml +++ b/hs-abci-examples/simple-storage/package.yaml @@ -77,6 +77,11 @@ library: - -fplugin=Polysemy.Plugin - -Werror - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wredundant-constraints exposed-modules: - SimpleStorage.Server - SimpleStorage.Application diff --git a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs b/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs index e0a5a7e3..f8434666 100644 --- a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs +++ b/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs @@ -1,16 +1,9 @@ module SimpleStorage.Test.E2ESpec where import Control.Lens ((^.)) -import Control.Monad.Reader (ReaderT) -import Data.Aeson (ToJSON) -import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteArray.Base64String as Base64 -import qualified Data.ByteArray.HexString as Hex -import Data.ByteString (ByteString) import Data.Default.Class (def) import Data.Proxy -import Data.String.Conversions (cs) -import qualified Network.ABCI.Types.Messages.Request as Req import qualified Network.ABCI.Types.Messages.Response as Resp import qualified Network.Tendermint.Client as RPC import Servant.API ((:>)) @@ -18,12 +11,11 @@ import qualified SimpleStorage.Modules.SimpleStorage as SS import Tendermint.SDK.BaseApp.Query (QueryArgs (..)) import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.Utils.Client (ClientResponse (..), - HasClient (..), - RunClient (..)) + HasClient (..)) +import Tendermint.Utils.Request (runRPC) import Tendermint.Utils.User (User (..), makeUser, mkSignedRawTransactionWithRoute) import Test.Hspec - spec :: Spec spec = do describe "SimpleStorage E2E - via hs-tendermint-client" $ do @@ -57,42 +49,15 @@ spec = do , queryArgsHeight = 0 , queryArgsProve = False } - ClientResponse{clientResponseData = Just foundCount} <- runQueryRunner $ getCount queryReq + ClientResponse{clientResponseData = Just foundCount} <- runRPC $ getCount queryReq foundCount `shouldBe` SS.Count 4 -runRPC :: forall a. RPC.TendermintM a -> IO a -runRPC = RPC.runTendermintM rpcConfig - where - rpcConfig :: RPC.Config - rpcConfig = - let RPC.Config baseReq _ _ = RPC.defaultConfig "localhost" 26657 - prettyPrint :: forall b. ToJSON b => String -> b -> IO () - prettyPrint prefix a = putStrLn $ prefix <> "\n" <> (cs . encodePretty $ a) - in RPC.Config baseReq (prettyPrint "RPC Request") (prettyPrint "RPC Response") - -newtype QueryRunner a = QueryRunner - {_runQueryRunner :: ReaderT RPC.Config IO a} - deriving (Functor, Applicative, Monad) - -runQueryRunner :: QueryRunner a -> IO a -runQueryRunner = runRPC . _runQueryRunner - -instance RunClient QueryRunner where - runQuery Req.Query{..} = - let rpcQ = RPC.RequestABCIQuery - { RPC.requestABCIQueryPath = Just queryPath - , RPC.requestABCIQueryData = Hex.fromBytes @ByteString . Base64.toBytes $ queryData - , RPC.requestABCIQueryHeight = Just $ queryHeight - , RPC.requestABCIQueryProve = queryProve - } - in RPC.resultABCIQueryResponse <$> QueryRunner (RPC.abciQuery rpcQ) - -------------------------------------------------------------------------------- -getCount :: QueryArgs SS.CountKey -> QueryRunner (ClientResponse SS.Count) +getCount :: QueryArgs SS.CountKey -> RPC.TendermintM (ClientResponse SS.Count) getCount = let apiP = Proxy :: Proxy ("simple_storage" :> SS.Api) - in genClient (Proxy :: Proxy QueryRunner) apiP def + in genClient (Proxy :: Proxy RPC.TendermintM) apiP def user1 :: User user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" diff --git a/hs-abci-test-utils/package.yaml b/hs-abci-test-utils/package.yaml index 3703e303..f12a5592 100644 --- a/hs-abci-test-utils/package.yaml +++ b/hs-abci-test-utils/package.yaml @@ -20,6 +20,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 - bytestring - errors diff --git a/hs-abci-test-utils/src/Tendermint/Utils/Request.hs b/hs-abci-test-utils/src/Tendermint/Utils/Request.hs new file mode 100644 index 00000000..b2e61461 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/Request.hs @@ -0,0 +1,59 @@ +module Tendermint.Utils.Request where + +import Control.Lens ((^.)) +import Data.Aeson (ToJSON) +import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.ByteArray.Base64String as Base64 +import Data.Maybe (fromJust) +import Data.String.Conversions (cs) +import Data.Word (Word32) +import qualified Network.ABCI.Types.Messages.Response as Response +import qualified Network.Tendermint.Client as RPC +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Transaction (RawTransaction (..)) +import Tendermint.Utils.Client (ClientResponse (..)) +import Test.Hspec + +runRPC :: forall a. RPC.TendermintM a -> IO a +runRPC = RPC.runTendermintM rpcConfig + where + rpcConfig :: RPC.Config + rpcConfig = + let RPC.Config baseReq _ _ = RPC.defaultConfig "localhost" 26657 + prettyPrint :: forall b. ToJSON b => String -> b -> IO () + prettyPrint prefix a = putStrLn $ prefix <> "\n" <> (cs . encodePretty $ a) + in RPC.Config baseReq (prettyPrint "RPC Request") (prettyPrint "RPC Response") + +-- executes a query and ensures a 0 response code +getQueryResponseSuccess :: RPC.TendermintM (ClientResponse a) -> IO a +getQueryResponseSuccess query = do + ClientResponse{clientResponseData,clientResponseRaw} <- runRPC query + let responseCode = clientResponseRaw ^. Response._queryCode + responseCode `shouldBe` 0 + return . fromJust $ clientResponseData + +-- executes a request, then returns the checkTx response +getCheckTxResponse :: RawTransaction -> IO Response.CheckTx +getCheckTxResponse rawTx = do + let txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeRawTx rawTx } + fmap RPC.resultBroadcastTxCommitCheckTx . runRPC $ + RPC.broadcastTxCommit txReq + +-- executes a request, then returns the deliverTx response +getDeliverTxResponse :: RawTransaction -> IO Response.DeliverTx +getDeliverTxResponse rawTx = do + let txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeRawTx rawTx } + fmap RPC.resultBroadcastTxCommitDeliverTx . runRPC $ + RPC.broadcastTxCommit txReq + +-- executes a request, check deliver and response codes +ensureCheckAndDeliverResponseCodes :: (Word32, Word32) -> RawTransaction -> IO () +ensureCheckAndDeliverResponseCodes codes rawTx = do + let txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeRawTx rawTx } + resp <- runRPC $ RPC.broadcastTxCommit txReq + let checkResp = RPC.resultBroadcastTxCommitCheckTx resp + deliverResp = RPC.resultBroadcastTxCommitDeliverTx resp + codes `shouldBe` (checkResp ^. Response._checkTxCode, deliverResp ^. Response._deliverTxCode) + +encodeRawTx :: RawTransaction -> Base64.Base64String +encodeRawTx = Base64.fromBytes . encode From e04471e192fb16da624648b6e2f89d76e277cb64 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 16 Dec 2019 11:21:18 -0500 Subject: [PATCH 12/30] Update readme --- hs-abci-test-utils/README.md | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/hs-abci-test-utils/README.md b/hs-abci-test-utils/README.md index d7493276..4264d308 100644 --- a/hs-abci-test-utils/README.md +++ b/hs-abci-test-utils/README.md @@ -1 +1,11 @@ # hs-abci-test-utils + +Utils for apps and tests. + +Includes the following: + +* `Client.hs` - Client interface for parsing ABCI responses +* `Events.hs` - Interface for parsing loggable events +* `Request.hs` - Test utils for executing requests/queries +* `Response.hs` - Test utils for checking response codes and event logs +* `User.hs` - Test utils for creating users and signed transactions From 776d1edbeebf634e8eedc71a9cf02ffa9693043a Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 2 Jan 2020 15:49:29 -0500 Subject: [PATCH 13/30] Add interact exe to nameservice --- .../nameservice/interact/Interact.hs | 53 +++++++++++++++++++ hs-abci-examples/nameservice/interact/Main.hs | 4 ++ hs-abci-examples/nameservice/package.yaml | 17 ++++++ .../test/Nameservice/Test/E2ESpec.hs | 1 + 4 files changed, 75 insertions(+) create mode 100644 hs-abci-examples/nameservice/interact/Interact.hs create mode 100644 hs-abci-examples/nameservice/interact/Main.hs diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs new file mode 100644 index 00000000..372771be --- /dev/null +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -0,0 +1,53 @@ +module Interact where + +import Data.Text (Text) +import Nameservice.Modules.Nameservice (BuyName (..), + DeleteName (..), + Name (..), SetName (..)) +import Nameservice.Modules.Token (Amount (..), + FaucetAccount (..)) +import Nameservice.Modules.TypedMessage (TypedMessage (..)) +import qualified Network.ABCI.Types.Messages.Response as Response +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.Utils.Request (getDeliverTxResponse) +import Tendermint.Utils.User (User (..), makeUser, mkSignedRawTransactionWithRoute) +-------------------------------------------------------------------------------- +-- Users +-------------------------------------------------------------------------------- + +user1 :: User +user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" + +user2 :: User +user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" + +-------------------------------------------------------------------------------- +-- Actions +-------------------------------------------------------------------------------- + +createName :: User -> Text -> Text -> IO Response.DeliverTx +createName user strName val = buyName user (Name strName) val 0 + +buyName :: User -> Name -> Text -> Amount -> IO Response.DeliverTx +buyName User{userAddress, userPrivKey} name newVal amount = + let msg = TypedMessage "BuyName" (encode $ BuyName amount name newVal userAddress) + rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg + in getDeliverTxResponse rawTx + +deleteName :: User -> Name -> IO Response.DeliverTx +deleteName User{userAddress, userPrivKey} name = + let msg = TypedMessage "DeleteName" (encode $ DeleteName userAddress name) + rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg + in getDeliverTxResponse rawTx + +setNameValue :: User -> Name -> Text -> IO Response.DeliverTx +setNameValue User{userAddress, userPrivKey} name val = + let msg = TypedMessage "SetName" (encode $ SetName name userAddress val) + rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg + in getDeliverTxResponse rawTx + +faucetAccount :: User -> IO Response.DeliverTx +faucetAccount User{userAddress, userPrivKey} = + let msg = TypedMessage "FaucetAccount" (encode $ FaucetAccount userAddress 1000) + rawTx = mkSignedRawTransactionWithRoute "token" userPrivKey msg + in getDeliverTxResponse rawTx diff --git a/hs-abci-examples/nameservice/interact/Main.hs b/hs-abci-examples/nameservice/interact/Main.hs new file mode 100644 index 00000000..59570736 --- /dev/null +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "do some stuff" diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index 2cc09405..195152f7 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -132,6 +132,23 @@ executables: - proto3-suite - proto3-wire + interact: + main: Main.hs + source-dirs: interact + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Werror + - -Wall + dependencies: + - base + - nameservice + - hs-abci-sdk + - hs-abci-test-utils + - hs-abci-types + - text + tests: tutorial: main: README.lhs diff --git a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs index ad108060..0f9e5423 100644 --- a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs +++ b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs @@ -182,6 +182,7 @@ spec = do senderAfterFoundAmount `shouldBe` Amount 1200 -------------------------------------------------------------------------------- + user1 :: User user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" From 04270a79c800b52d1f79af99e036ecd779576301 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 2 Jan 2020 16:23:17 -0500 Subject: [PATCH 14/30] Add basic main for interact --- hs-abci-examples/nameservice/interact/Interact.hs | 14 +++++++------- hs-abci-examples/nameservice/interact/Main.hs | 12 +++++++++++- .../nameservice/src/Nameservice/Config.hs | 2 +- .../src/Nameservice/Modules/Nameservice/Types.hs | 4 +++- 4 files changed, 22 insertions(+), 10 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index 372771be..6a3086c0 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -25,8 +25,8 @@ user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e03 -- Actions -------------------------------------------------------------------------------- -createName :: User -> Text -> Text -> IO Response.DeliverTx -createName user strName val = buyName user (Name strName) val 0 +createName :: User -> Name -> Text -> IO Response.DeliverTx +createName user name val = buyName user name val 0 buyName :: User -> Name -> Text -> Amount -> IO Response.DeliverTx buyName User{userAddress, userPrivKey} name newVal amount = @@ -40,14 +40,14 @@ deleteName User{userAddress, userPrivKey} name = rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg in getDeliverTxResponse rawTx -setNameValue :: User -> Name -> Text -> IO Response.DeliverTx -setNameValue User{userAddress, userPrivKey} name val = +setName :: User -> Name -> Text -> IO Response.DeliverTx +setName User{userAddress, userPrivKey} name val = let msg = TypedMessage "SetName" (encode $ SetName name userAddress val) rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg in getDeliverTxResponse rawTx -faucetAccount :: User -> IO Response.DeliverTx -faucetAccount User{userAddress, userPrivKey} = - let msg = TypedMessage "FaucetAccount" (encode $ FaucetAccount userAddress 1000) +faucetAccount :: User -> Amount -> IO Response.DeliverTx +faucetAccount User{userAddress, userPrivKey} amount = + let msg = TypedMessage "FaucetAccount" (encode $ FaucetAccount userAddress amount) rawTx = mkSignedRawTransactionWithRoute "token" userPrivKey msg in getDeliverTxResponse rawTx diff --git a/hs-abci-examples/nameservice/interact/Main.hs b/hs-abci-examples/nameservice/interact/Main.hs index 59570736..dead7c2c 100644 --- a/hs-abci-examples/nameservice/interact/Main.hs +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -1,4 +1,14 @@ module Main where +import Interact + main :: IO () -main = putStrLn "do some stuff" +main = do + putStrLn "Running nameservice interaction..." + _ <- faucetAccount user1 1000 + _ <- faucetAccount user2 1000 + _ <- createName user1 "anyName" "no val" + _ <- buyName user2 "anyName" "some val" 10 + _ <- setName user2 "anyName" "some val (again)" + _ <- deleteName user2 "anyName" + putStrLn "Nameservice interaction complete." diff --git a/hs-abci-examples/nameservice/src/Nameservice/Config.hs b/hs-abci-examples/nameservice/src/Nameservice/Config.hs index 217a585c..ce85c684 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Config.hs +++ b/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 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 9bf19811..761f95c6 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 @@ -20,7 +21,6 @@ import qualified Tendermint.SDK.BaseApp as BaseApp import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Types.Address (Address) import qualified Tendermint.Utils.Events as Event - -------------------------------------------------------------------------------- type NameserviceModuleName = "nameservice" @@ -34,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 From 298656f5921cc83a04fb80843d449383c4c97f20 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 2 Jan 2020 17:32:53 -0500 Subject: [PATCH 15/30] add random name generator --- hs-abci-examples/nameservice/interact/Main.hs | 17 ++++++++++++----- hs-abci-examples/nameservice/package.yaml | 1 + .../src/Tendermint/Utils/Request.hs | 10 ++++++++++ stack.yaml | 2 ++ stack.yaml.lock | 14 ++++++++++++++ 5 files changed, 39 insertions(+), 5 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Main.hs b/hs-abci-examples/nameservice/interact/Main.hs index dead7c2c..1c27a344 100644 --- a/hs-abci-examples/nameservice/interact/Main.hs +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -1,14 +1,21 @@ module Main where +import Data.String (fromString) +import Faker.Name (name) import Interact +import Control.Monad (forever) main :: IO () main = do putStrLn "Running nameservice interaction..." _ <- faucetAccount user1 1000 _ <- faucetAccount user2 1000 - _ <- createName user1 "anyName" "no val" - _ <- buyName user2 "anyName" "some val" 10 - _ <- setName user2 "anyName" "some val (again)" - _ <- deleteName user2 "anyName" - putStrLn "Nameservice interaction complete." + forever $ do + genName <- name + putStrLn $ "Generated name: " <> genName + let aName = fromString genName + _ <- createName user1 aName "no val" + _ <- buyName user2 aName "some val" 10 + _ <- setName user2 aName "some val (again)" + _ <- deleteName user2 aName + putStrLn $ "Loop completed." diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index 195152f7..b4bb1056 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -143,6 +143,7 @@ executables: - -Wall dependencies: - base + - faker - nameservice - hs-abci-sdk - hs-abci-test-utils diff --git a/hs-abci-test-utils/src/Tendermint/Utils/Request.hs b/hs-abci-test-utils/src/Tendermint/Utils/Request.hs index b2e61461..26b05e36 100644 --- a/hs-abci-test-utils/src/Tendermint/Utils/Request.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index f32754da..abbd0bd5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,6 +17,8 @@ packages: - ./hs-iavl-client extra-deps: + - faker-0.0.0.2 + - gimlh-0.1.3.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..2e3ca9ad 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,6 +4,20 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: +- 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: proto-lens-runtime-0.5.0.0@sha256:cb39cf13ce4f7dac5414f94a7afe0adc9b831312e6b60588a23bd816accc385f,3132 pantry-tree: From eba7e74985657d01f8e8cc6c5cefcb0ab89890cc Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 2 Jan 2020 17:46:08 -0500 Subject: [PATCH 16/30] Clean up action type signatures +Fix markdown-unlit issue --- .../nameservice/interact/Interact.hs | 21 +++++++++---------- hs-abci-examples/nameservice/interact/Main.hs | 13 ++++++------ hs-abci-examples/nameservice/package.yaml | 2 +- 3 files changed, 17 insertions(+), 19 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index 6a3086c0..9b5898a4 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -7,9 +7,8 @@ import Nameservice.Modules.Nameservice (BuyName (..), import Nameservice.Modules.Token (Amount (..), FaucetAccount (..)) import Nameservice.Modules.TypedMessage (TypedMessage (..)) -import qualified Network.ABCI.Types.Messages.Response as Response import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.Utils.Request (getDeliverTxResponse) +import Tendermint.Utils.Request (runTransaction_) import Tendermint.Utils.User (User (..), makeUser, mkSignedRawTransactionWithRoute) -------------------------------------------------------------------------------- -- Users @@ -25,29 +24,29 @@ user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e03 -- Actions -------------------------------------------------------------------------------- -createName :: User -> Name -> Text -> IO Response.DeliverTx +createName :: User -> Name -> Text -> IO () createName user name val = buyName user name val 0 -buyName :: User -> Name -> Text -> Amount -> IO Response.DeliverTx +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 getDeliverTxResponse rawTx + in runTransaction_ rawTx -deleteName :: User -> Name -> IO Response.DeliverTx +deleteName :: User -> Name -> IO () deleteName User{userAddress, userPrivKey} name = let msg = TypedMessage "DeleteName" (encode $ DeleteName userAddress name) rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg - in getDeliverTxResponse rawTx + in runTransaction_ rawTx -setName :: User -> Name -> Text -> IO Response.DeliverTx +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 getDeliverTxResponse rawTx + in runTransaction_ rawTx -faucetAccount :: User -> Amount -> IO Response.DeliverTx +faucetAccount :: User -> Amount -> IO () faucetAccount User{userAddress, userPrivKey} amount = let msg = TypedMessage "FaucetAccount" (encode $ FaucetAccount userAddress amount) rawTx = mkSignedRawTransactionWithRoute "token" userPrivKey msg - in getDeliverTxResponse rawTx + in runTransaction_ rawTx diff --git a/hs-abci-examples/nameservice/interact/Main.hs b/hs-abci-examples/nameservice/interact/Main.hs index 1c27a344..55c92300 100644 --- a/hs-abci-examples/nameservice/interact/Main.hs +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -8,14 +8,13 @@ import Control.Monad (forever) main :: IO () main = do putStrLn "Running nameservice interaction..." - _ <- faucetAccount user1 1000 - _ <- faucetAccount user2 1000 + faucetAccount user1 1000 + faucetAccount user2 1000 forever $ do genName <- name putStrLn $ "Generated name: " <> genName let aName = fromString genName - _ <- createName user1 aName "no val" - _ <- buyName user2 aName "some val" 10 - _ <- setName user2 aName "some val (again)" - _ <- deleteName user2 aName - putStrLn $ "Loop completed." + createName user1 aName "no val" + buyName user2 aName "some val" 10 + setName user2 aName "some val (again)" + deleteName user2 aName diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index b4bb1056..71c7b783 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -147,7 +147,6 @@ executables: - nameservice - hs-abci-sdk - hs-abci-test-utils - - hs-abci-types - text tests: @@ -168,6 +167,7 @@ tests: - hs-abci-sdk - hs-abci-server - lens + - markdown-unlit - nameservice - polysemy - polysemy-plugin From d4b071321f973dbc6ca2e4aa6103b59c07150c91 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 6 Jan 2020 17:27:44 -0500 Subject: [PATCH 17/30] Async actionBlock --- .../nameservice/interact/Interact.hs | 46 ++++++++++++++----- hs-abci-examples/nameservice/interact/Main.hs | 26 +++++------ hs-abci-examples/nameservice/package.yaml | 1 + 3 files changed, 47 insertions(+), 26 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index 9b5898a4..b9739c7b 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -1,15 +1,25 @@ -module Interact where - -import Data.Text (Text) -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) +module Interact + ( user1 + , user2 + , faucetAccount + , actionBlock + ) 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 -------------------------------------------------------------------------------- @@ -45,6 +55,18 @@ setName User{userAddress, userPrivKey} name val = rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg in runTransaction_ rawTx +actionBlock :: (User, User) -> IO () +actionBlock (u1, u2) = do + genName <- Name.name + genCVal <- Lorem.word + genBVal <- Lorem.word + genSVal <- Lorem.word + let name = fromString genName + createName u1 name (cs genCVal) + buyName u2 name (cs genBVal) 10 + setName u2 name (cs genSVal) + deleteName user2 name + faucetAccount :: User -> Amount -> IO () faucetAccount User{userAddress, userPrivKey} amount = let msg = TypedMessage "FaucetAccount" (encode $ FaucetAccount userAddress amount) diff --git a/hs-abci-examples/nameservice/interact/Main.hs b/hs-abci-examples/nameservice/interact/Main.hs index 55c92300..fdb001e2 100644 --- a/hs-abci-examples/nameservice/interact/Main.hs +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -1,20 +1,18 @@ module Main where -import Data.String (fromString) -import Faker.Name (name) +import Control.Concurrent (forkIO) +import Control.Monad (forever) +import Data.Foldable (for_) +import Data.Maybe (maybe) import Interact -import Control.Monad (forever) +import System.Environment (lookupEnv) +import Text.Read (read) main :: IO () main = do - putStrLn "Running nameservice interaction..." - faucetAccount user1 1000 - faucetAccount user2 1000 - forever $ do - genName <- name - putStrLn $ "Generated name: " <> genName - let aName = fromString genName - createName user1 aName "no val" - buyName user2 aName "some val" 10 - setName user2 aName "some val (again)" - deleteName user2 aName + mThreads <- lookupEnv "TX_COUNT" + let threads = maybe 1 read mThreads :: Int + putStrLn $ "Running nameservice interaction with #threads: " <> show threads + faucetAccount user1 10000 + faucetAccount user2 10000 + for_ [1..threads] $ const . forkIO . forever $ actionBlock (user1, user2) diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index 71c7b783..7f7b1787 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -148,6 +148,7 @@ executables: - hs-abci-sdk - hs-abci-test-utils - text + - string-conversions tests: tutorial: From 38822b32b03cc119111619f5af704f4a8ba78d33 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 6 Jan 2020 17:33:00 -0500 Subject: [PATCH 18/30] unused --- .../nameservice/src/Nameservice/Modules/Nameservice/Types.hs | 2 +- .../nameservice/src/Nameservice/Modules/Token/Types.hs | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) 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 9909bc56..5c510eed 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Types.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Types.hs @@ -20,7 +20,7 @@ import qualified Proto3.Wire.Encode as Encode import qualified Tendermint.SDK.BaseApp as BaseApp import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Types.Address (Address) -import qualified Tendermint.Utils.Events as Event + -------------------------------------------------------------------------------- type NameserviceModuleName = "nameservice" diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs index 536e14b4..13a6d796 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Types.hs @@ -20,7 +20,6 @@ import qualified Tendermint.SDK.BaseApp as BaseApp import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Types.Address (Address, addressFromBytes, addressToBytes) -import qualified Tendermint.Utils.Events as Event -------------------------------------------------------------------------------- From 19174c7662e8dea4a8c86af077347fdc1d8faf99 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 6 Jan 2020 17:35:00 -0500 Subject: [PATCH 19/30] unused from merge --- hs-abci-examples/nameservice/package.yaml | 1 - 1 file changed, 1 deletion(-) diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index 184e7b07..f3caf44d 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -58,7 +58,6 @@ library: - hs-abci-extra - hs-abci-server - hs-abci-sdk - - hs-abci-test-utils - hs-abci-types - http-client - katip From a3dbb8f746951687d0ff87fdab66477042877b16 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 6 Jan 2020 17:46:09 -0500 Subject: [PATCH 20/30] kind of works --- hs-abci-examples/nameservice/interact/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hs-abci-examples/nameservice/interact/Main.hs b/hs-abci-examples/nameservice/interact/Main.hs index fdb001e2..45a827b2 100644 --- a/hs-abci-examples/nameservice/interact/Main.hs +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -15,4 +15,4 @@ main = do putStrLn $ "Running nameservice interaction with #threads: " <> show threads faucetAccount user1 10000 faucetAccount user2 10000 - for_ [1..threads] $ const . forkIO . forever $ actionBlock (user1, user2) + for_ [1..threads] $ \_ -> forkIO . forever $ actionBlock (user1, user2) From 77799c573c48a27d83e27780e73fa3e84e8c6dd7 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 6 Jan 2020 18:09:24 -0500 Subject: [PATCH 21/30] fix concurrency --- hs-abci-examples/nameservice/interact/Main.hs | 13 ++++++------- hs-abci-examples/nameservice/package.yaml | 1 + stack.yaml | 1 + stack.yaml.lock | 7 +++++++ 4 files changed, 15 insertions(+), 7 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Main.hs b/hs-abci-examples/nameservice/interact/Main.hs index 45a827b2..7d2cbcdc 100644 --- a/hs-abci-examples/nameservice/interact/Main.hs +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -1,12 +1,11 @@ module Main where -import Control.Concurrent (forkIO) -import Control.Monad (forever) -import Data.Foldable (for_) -import Data.Maybe (maybe) +import Control.Concurrent.Async (forConcurrently_) +import Control.Monad (forever) +import Data.Maybe (maybe) import Interact -import System.Environment (lookupEnv) -import Text.Read (read) +import System.Environment (lookupEnv) +import Text.Read (read) main :: IO () main = do @@ -15,4 +14,4 @@ main = do putStrLn $ "Running nameservice interaction with #threads: " <> show threads faucetAccount user1 10000 faucetAccount user2 10000 - for_ [1..threads] $ \_ -> forkIO . forever $ actionBlock (user1, user2) + forever $ forConcurrently_ [1..threads] $ \_ -> actionBlock (user1, user2) diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index f3caf44d..b0b9497f 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -141,6 +141,7 @@ executables: - -Werror - -Wall dependencies: + - async - base - faker - nameservice diff --git a/stack.yaml b/stack.yaml index abbd0bd5..1023956a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,6 +17,7 @@ packages: - ./hs-iavl-client extra-deps: + - async-2.2.2 - faker-0.0.0.2 - gimlh-0.1.3.0 - proto-lens-runtime-0.5.0.0 diff --git a/stack.yaml.lock b/stack.yaml.lock index 2e3ca9ad..3dfe4ee4 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,6 +4,13 @@ # 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: From 681610699ced41847eb23052f742852131c33475 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Tue, 7 Jan 2020 14:50:31 -0500 Subject: [PATCH 22/30] WIP --- Makefile | 5 ++ .../nameservice/interact/Interact.hs | 64 +++++++++++++------ hs-abci-examples/nameservice/interact/Main.hs | 4 +- 3 files changed, 51 insertions(+), 22 deletions(-) diff --git a/Makefile b/Makefile index 9ae43fa4..65eaa28e 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,5 @@ STATS_PORT ?= 9200 +INTERACT_THREAD_COUNT ?= 10 export @@ -90,6 +91,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 index b9739c7b..1bd23000 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -5,11 +5,13 @@ module Interact , actionBlock ) where +import Control.Monad (replicateM) 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.Modules.Nameservice (BuyName (..), DeleteName (..), Name (..), SetName (..)) @@ -20,16 +22,6 @@ 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 -------------------------------------------------------------------------------- @@ -55,16 +47,16 @@ setName User{userAddress, userPrivKey} name val = rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg in runTransaction_ rawTx -actionBlock :: (User, User) -> IO () -actionBlock (u1, u2) = do - genName <- Name.name - genCVal <- Lorem.word - genBVal <- Lorem.word - genSVal <- Lorem.word - let name = fromString genName - createName u1 name (cs genCVal) - buyName u2 name (cs genBVal) 10 - setName u2 name (cs genSVal) +actionBlock :: IO () +actionBlock = do + name <- genName + genCVal <- genWords + genBVal <- genWords + genBAmt <- genAmount + genSVal <- genWords + createName user1 name genCVal + buyName user2 name genBVal genBAmt + setName user2 name genSVal deleteName user2 name faucetAccount :: User -> Amount -> IO () @@ -72,3 +64,35 @@ faucetAccount User{userAddress, userPrivKey} amount = let msg = TypedMessage "FaucetAccount" (encode $ FaucetAccount userAddress amount) rawTx = mkSignedRawTransactionWithRoute "token" userPrivKey msg in runTransaction_ rawTx + +-------------------------------------------------------------------------------- +-- Users +-------------------------------------------------------------------------------- + +user1 :: User +user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" + +user2 :: User +user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" + +-------------------------------------------------------------------------------- +-- Generation +-------------------------------------------------------------------------------- + +-- should be as unique as possible to avoid Tx clashing + +genWords :: IO Text +genWords = do + numWords <- Utils.randomNum (1, 25) + ws <- replicateM numWords Lorem.word + return . cs . unwords $ ws + +genName :: IO Name +genName = do + name <- Name.name + return . fromString $ name + +genAmount :: IO 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 index 7d2cbcdc..43124126 100644 --- a/hs-abci-examples/nameservice/interact/Main.hs +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -9,9 +9,9 @@ import Text.Read (read) main :: IO () main = do - mThreads <- lookupEnv "TX_COUNT" + mThreads <- lookupEnv "INTERACT_THREAD_COUNT" let threads = maybe 1 read mThreads :: Int putStrLn $ "Running nameservice interaction with #threads: " <> show threads faucetAccount user1 10000 faucetAccount user2 10000 - forever $ forConcurrently_ [1..threads] $ \_ -> actionBlock (user1, user2) + forever $ forConcurrently_ [1..threads] $ const actionBlock From 25d75f843ba6a214f0b0d44141b3994db12ebc86 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Tue, 14 Jan 2020 10:46:46 -0500 Subject: [PATCH 23/30] 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. --- Makefile | 2 +- .../nameservice/interact/Interact.hs | 51 +++++++++---------- hs-abci-examples/nameservice/interact/Main.hs | 2 - hs-abci-examples/nameservice/package.yaml | 1 + 4 files changed, 27 insertions(+), 29 deletions(-) diff --git a/Makefile b/Makefile index 9aacede2..3a09ac83 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ STATS_PORT ?= 9200 -INTERACT_THREAD_COUNT ?= 10 +INTERACT_THREAD_COUNT ?= 5 export diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index 1bd23000..697e284a 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -1,11 +1,9 @@ module Interact - ( user1 - , user2 - , faucetAccount - , actionBlock + ( actionBlock ) where import Control.Monad (replicateM) +import Data.ByteString (ByteString) import Data.String (fromString) import Data.String.Conversions (cs) import Data.Text (Text) @@ -26,26 +24,34 @@ import Tendermint.Utils.User (User (..), makeUser, mkSigned -- Actions -------------------------------------------------------------------------------- +faucetAccount :: User -> Amount -> IO () +faucetAccount user@User{userAddress} amount = + runAction_ user "token" "FaucetAccount" (FaucetAccount userAddress amount) + createName :: User -> Name -> Text -> IO () createName user name val = buyName user name val 0 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 +buyName user@User{userAddress} name newVal amount = + runAction_ user "nameservice" "BuyName" (BuyName amount name newVal userAddress) 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 +deleteName user@User{userAddress} name = + runAction_ user "nameservice" "DeleteName" (DeleteName userAddress name) 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 +setName user@User{userAddress} name val = + runAction_ user "nameservice" "SetName" (SetName name userAddress val) + +runAction_ + :: HasCodec a + => User + -> ByteString + -> Text + -> a + -> IO () +runAction_ user bs t msg = runTransaction_ =<< + mkSignedRawTransactionWithRoute bs user (TypedMessage t (encode msg)) actionBlock :: IO () actionBlock = do @@ -54,17 +60,12 @@ actionBlock = do genBVal <- genWords genBAmt <- genAmount genSVal <- genWords + faucetAccount user2 genBAmt createName user1 name genCVal buyName user2 name genBVal genBAmt setName user2 name genSVal deleteName user2 name -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 - -------------------------------------------------------------------------------- -- Users -------------------------------------------------------------------------------- @@ -79,11 +80,9 @@ user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e03 -- Generation -------------------------------------------------------------------------------- --- should be as unique as possible to avoid Tx clashing - genWords :: IO Text genWords = do - numWords <- Utils.randomNum (1, 25) + numWords <- Utils.randomNum (1, 10) ws <- replicateM numWords Lorem.word return . cs . unwords $ ws @@ -94,5 +93,5 @@ genName = do genAmount :: IO Amount genAmount = do - genAmt <- Utils.randomNum (1, 1000) + genAmt <- Utils.randomNum (1, 100) return . fromInteger . toInteger $ genAmt diff --git a/hs-abci-examples/nameservice/interact/Main.hs b/hs-abci-examples/nameservice/interact/Main.hs index 43124126..2566efb0 100644 --- a/hs-abci-examples/nameservice/interact/Main.hs +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -12,6 +12,4 @@ main = do mThreads <- lookupEnv "INTERACT_THREAD_COUNT" let threads = maybe 1 read mThreads :: Int putStrLn $ "Running nameservice interaction with #threads: " <> show threads - faucetAccount user1 10000 - faucetAccount user2 10000 forever $ forConcurrently_ [1..threads] $ const actionBlock diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index ee44e8e6..4b27d776 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -141,6 +141,7 @@ executables: dependencies: - async - base + - bytestring - faker - nameservice - hs-abci-sdk From 14d4c0f914882c5ad66b6a436dc332af87d59b7e Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Wed, 15 Jan 2020 15:09:51 -0500 Subject: [PATCH 24/30] Off by one error: allow transfer to 0 an account --- .../nameservice/src/Nameservice/Modules/Token/Keeper.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From ccd357bed0987e3ee96fd27996fac9f424d36665 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Wed, 15 Jan 2020 15:11:00 -0500 Subject: [PATCH 25/30] Update script to generate random users for each thread --- .../nameservice/interact/Interact.hs | 20 +++++++++++-------- hs-abci-examples/nameservice/interact/Main.hs | 6 ++++-- hs-abci-examples/nameservice/package.yaml | 3 ++- stack.yaml | 1 + stack.yaml.lock | 7 +++++++ 5 files changed, 26 insertions(+), 11 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index 697e284a..5325b763 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -1,9 +1,11 @@ module Interact ( actionBlock + , makeRandomUsers ) where import Control.Monad (replicateM) import Data.ByteString (ByteString) +import Data.Char (isHexDigit) import Data.String (fromString) import Data.String.Conversions (cs) import Data.Text (Text) @@ -19,6 +21,8 @@ import Nameservice.Modules.TypedMessage (TypedMessage (..)) import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.Utils.Request (runTransaction_) import Tendermint.Utils.User (User (..), makeUser, mkSignedRawTransactionWithRoute) +import Test.RandomStrings (onlyWith, randomASCII, + randomString) -------------------------------------------------------------------------------- -- Actions @@ -53,8 +57,8 @@ runAction_ runAction_ user bs t msg = runTransaction_ =<< mkSignedRawTransactionWithRoute bs user (TypedMessage t (encode msg)) -actionBlock :: IO () -actionBlock = do +actionBlock :: (User, User) -> IO () +actionBlock (user1, user2) = do name <- genName genCVal <- genWords genBVal <- genWords @@ -70,11 +74,11 @@ actionBlock = do -- Users -------------------------------------------------------------------------------- -user1 :: User -user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" - -user2 :: User -user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" +makeRandomUsers :: IO (User, User) +makeRandomUsers = do + str1 <- randomString (onlyWith isHexDigit randomASCII) 64 + str2 <- randomString (onlyWith isHexDigit randomASCII) 64 + return $ (makeUser str1, makeUser str2) -------------------------------------------------------------------------------- -- Generation @@ -93,5 +97,5 @@ genName = do genAmount :: IO Amount genAmount = do - genAmt <- Utils.randomNum (1, 100) + 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 index 2566efb0..c0cb01e1 100644 --- a/hs-abci-examples/nameservice/interact/Main.hs +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -1,7 +1,7 @@ module Main where import Control.Concurrent.Async (forConcurrently_) -import Control.Monad (forever) +import Control.Monad (forever, replicateM) import Data.Maybe (maybe) import Interact import System.Environment (lookupEnv) @@ -11,5 +11,7 @@ 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_ [1..threads] $ const actionBlock + 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 4b27d776..ec1db51e 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -146,8 +146,9 @@ executables: - nameservice - hs-abci-sdk - hs-abci-test-utils - - text + - random-strings - string-conversions + - text tests: tutorial: diff --git a/stack.yaml b/stack.yaml index 1023956a..ebd00ff3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -20,6 +20,7 @@ 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 3dfe4ee4..4146e7a1 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -25,6 +25,13 @@ packages: 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: From 1c65af4847d8dd9d1788dbb3d6e5b568c0d4e108 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 27 Jan 2020 16:50:17 -0500 Subject: [PATCH 26/30] wip: compile with master changes --- .../nameservice/interact/Interact.hs | 220 +++++++++++++----- 1 file changed, 162 insertions(+), 58 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index 5325b763..493cb36d 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -1,10 +1,11 @@ module Interact - ( actionBlock - , makeRandomUsers + ( -- actionBlock + -- , + makeRandomUsers ) where import Control.Monad (replicateM) -import Data.ByteString (ByteString) + import Data.Char (isHexDigit) import Data.String (fromString) import Data.String.Conversions (cs) @@ -12,73 +13,176 @@ import Data.Text (Text) import qualified Faker.Lorem as Lorem import qualified Faker.Name as Name import qualified Faker.Utils as Utils -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) +import qualified Nameservice.Modules.Nameservice as N +import qualified Nameservice.Modules.Token as T + import Test.RandomStrings (onlyWith, randomASCII, randomString) - +import Tendermint.Utils.Client (ClientConfig (..), + EmptyTxClient (..), + HasQueryClient (..), + HasTxClient (..), + QueryClientResponse (..), + Signer (..), + TxClientResponse (..), + TxOpts (..), + defaultClientTxOpts) +import Tendermint.Utils.User (makeSignerFromUser, + makeUser) +import Tendermint.SDK.Application.Module (AppQueryRouter (QApi), + AppTxRouter (TApi)) +import Data.Proxy +import Servant.API ((:<|>) (..)) +import Control.Monad.Reader (ReaderT, runReaderT) +import qualified Tendermint.SDK.Modules.Auth as Auth +import Nameservice.Application +import qualified Network.Tendermint.Client as RPC +import Tendermint.SDK.BaseApp.Query (QueryArgs (..), + QueryResult (..)) +import Tendermint.Utils.ClientUtils (rpcConfig, assertTx) +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import Tendermint.SDK.Types.Address (Address) +import Data.Default.Class (def) +import Control.Monad (void) -------------------------------------------------------------------------------- -- Actions -------------------------------------------------------------------------------- -faucetAccount :: User -> Amount -> IO () -faucetAccount user@User{userAddress} amount = - runAction_ user "token" "FaucetAccount" (FaucetAccount userAddress amount) - -createName :: User -> Name -> Text -> IO () -createName user name val = buyName user name val 0 - -buyName :: User -> Name -> Text -> Amount -> IO () -buyName user@User{userAddress} name newVal amount = - runAction_ user "nameservice" "BuyName" (BuyName amount name newVal userAddress) - -deleteName :: User -> Name -> IO () -deleteName user@User{userAddress} name = - runAction_ user "nameservice" "DeleteName" (DeleteName userAddress name) - -setName :: User -> Name -> Text -> IO () -setName user@User{userAddress} name val = - runAction_ user "nameservice" "SetName" (SetName name userAddress val) - -runAction_ - :: HasCodec a - => User - -> ByteString - -> Text - -> a - -> IO () -runAction_ user bs t msg = runTransaction_ =<< - mkSignedRawTransactionWithRoute bs user (TypedMessage t (encode msg)) - -actionBlock :: (User, User) -> IO () -actionBlock (user1, user2) = do - name <- genName - genCVal <- genWords - genBVal <- genWords - genBAmt <- genAmount - genSVal <- genWords - faucetAccount user2 genBAmt - createName user1 name genCVal - buyName user2 name genBVal genBAmt - setName user2 name genSVal - deleteName user2 name +faucetAccount :: Signer -> T.Amount -> IO () +faucetAccount s@(Signer addr _) amount = + void . assertTx . runTxClientM $ + let msg = T.FaucetAccount addr amount + opts = TxOpts + { txOptsGas = 0 + , txOptsSigner = s + } + in faucet opts msg + +-- createName :: User -> Name -> Text -> IO () +-- createName user name val = buyName user name val 0 + +-- buyName :: User -> Name -> Text -> Amount -> IO () +-- buyName user@User{userAddress} name newVal amount = +-- runAction_ user "nameservice" "BuyName" (BuyName amount name newVal userAddress) + +-- deleteName :: User -> Name -> IO () +-- deleteName user@User{userAddress} name = +-- runAction_ user "nameservice" "DeleteName" (DeleteName userAddress name) + +-- setName :: User -> Name -> Text -> IO () +-- setName user@User{userAddress} name val = +-- runAction_ user "nameservice" "SetName" (SetName name userAddress val) + +-- runAction_ +-- :: HasCodec a +-- => User +-- -> ByteString +-- -> Text +-- -> a +-- -> IO () +-- runAction_ user bs t msg = runTransaction_ =<< +-- mkSignedRawTransactionWithRoute bs user (TypedMessage t (encode msg)) + +-- actionBlock :: (User, User) -> IO () +-- actionBlock (user1, user2) = do +-- name <- genName +-- genCVal <- genWords +-- genBVal <- genWords +-- genBAmt <- genAmount +-- genSVal <- genWords +-- faucetAccount user2 genBAmt +-- createName user1 name genCVal +-- buyName user2 name genBVal genBAmt +-- setName user2 name genSVal +-- deleteName user2 name -------------------------------------------------------------------------------- -- Users -------------------------------------------------------------------------------- -makeRandomUsers :: IO (User, User) +makeRandomUsers :: IO (Signer, Signer) makeRandomUsers = do str1 <- randomString (onlyWith isHexDigit randomASCII) 64 str2 <- randomString (onlyWith isHexDigit randomASCII) 64 - return $ (makeUser str1, makeUser str2) + 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 +buyName + :: TxOpts + -> N.BuyName + -> TxClientM (TxClientResponse () ()) + +setName + :: TxOpts + -> N.SetName + -> TxClientM (TxClientResponse () ()) + +deleteName + :: TxOpts + -> N.DeleteName + -> TxClientM (TxClientResponse () ()) + +-- Token Client +faucet + :: TxOpts + -> T.FaucetAccount + -> TxClientM (TxClientResponse () ()) + +(buyName :<|> setName :<|> deleteName) :<|> + (_ :<|> _ :<|> faucet) :<|> + EmptyTxClient = + genClientT (Proxy @TxClientM) txApiP defaultClientTxOpts + where + txApiP :: Proxy (TApi NameserviceModules) + txApiP = Proxy + -------------------------------------------------------------------------------- -- Generation @@ -90,12 +194,12 @@ genWords = do ws <- replicateM numWords Lorem.word return . cs . unwords $ ws -genName :: IO Name +genName :: IO N.Name genName = do name <- Name.name return . fromString $ name -genAmount :: IO Amount +genAmount :: IO T.Amount genAmount = do genAmt <- Utils.randomNum (1, 1000) return . fromInteger . toInteger $ genAmt From 63572a36909959c9d342961b9d79a7c05b3ba5eb Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 27 Jan 2020 16:55:04 -0500 Subject: [PATCH 27/30] buyName --- .../nameservice/interact/Interact.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index 493cb36d..7fc29b06 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -61,8 +61,15 @@ faucetAccount s@(Signer addr _) amount = -- createName :: User -> Name -> Text -> IO () -- createName user name val = buyName user name val 0 --- buyName :: User -> Name -> Text -> Amount -> IO () --- buyName user@User{userAddress} name newVal amount = +buyName :: Signer -> N.Name -> Text -> T.Amount -> IO () +buyName s@(Signer addr _) name newVal amount = + void . assertTx . runTxClientM $ + let msg = N.BuyName amount name newVal addr + opts = TxOpts + { txOptsGas = 0 + , txOptsSigner = s + } + in buy opts msg -- runAction_ user "nameservice" "BuyName" (BuyName amount name newVal userAddress) -- deleteName :: User -> Name -> IO () @@ -154,17 +161,17 @@ runTxClientM :: TxClientM a -> IO a runTxClientM m = runReaderT m txClientConfig -- Nameservice Client -buyName +buy :: TxOpts -> N.BuyName -> TxClientM (TxClientResponse () ()) -setName +set :: TxOpts -> N.SetName -> TxClientM (TxClientResponse () ()) -deleteName +delete :: TxOpts -> N.DeleteName -> TxClientM (TxClientResponse () ()) @@ -175,7 +182,7 @@ faucet -> T.FaucetAccount -> TxClientM (TxClientResponse () ()) -(buyName :<|> setName :<|> deleteName) :<|> +(buy :<|> set :<|> delete) :<|> (_ :<|> _ :<|> faucet) :<|> EmptyTxClient = genClientT (Proxy @TxClientM) txApiP defaultClientTxOpts From 4e5c3a114c304b9a0bd0f1b7a9d9bb99a26be791 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 27 Jan 2020 16:56:07 -0500 Subject: [PATCH 28/30] createName --- hs-abci-examples/nameservice/interact/Interact.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index 7fc29b06..a41a2616 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -58,8 +58,8 @@ faucetAccount s@(Signer addr _) amount = } in faucet opts msg --- createName :: User -> Name -> Text -> IO () --- createName user name val = buyName user name val 0 +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 = @@ -70,7 +70,6 @@ buyName s@(Signer addr _) name newVal amount = , txOptsSigner = s } in buy opts msg --- runAction_ user "nameservice" "BuyName" (BuyName amount name newVal userAddress) -- deleteName :: User -> Name -> IO () -- deleteName user@User{userAddress} name = From 39ef3aa05422dcd35b4a3f467723c2c0d906fdf9 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 27 Jan 2020 16:57:19 -0500 Subject: [PATCH 29/30] deleteName --- hs-abci-examples/nameservice/interact/Interact.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index a41a2616..d1a73387 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -71,9 +71,15 @@ buyName s@(Signer addr _) name newVal amount = } in buy opts msg --- deleteName :: User -> Name -> IO () --- deleteName user@User{userAddress} name = --- runAction_ user "nameservice" "DeleteName" (DeleteName userAddress name) +deleteName :: Signer -> N.Name -> IO () +deleteName s@(Signer addr _) name = + void . assertTx . runTxClientM $ + let msg = N.DeleteName addr name + opts = TxOpts + { txOptsGas = 0 + , txOptsSigner = s + } + in delete opts msg -- setName :: User -> Name -> Text -> IO () -- setName user@User{userAddress} name val = From a317a1723fcef2ef230ff4d3e03576a5b5a7d209 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 27 Jan 2020 17:30:19 -0500 Subject: [PATCH 30/30] Works again --- .../nameservice/interact/Interact.hs | 138 ++++++++---------- hs-abci-examples/nameservice/package.yaml | 5 +- 2 files changed, 61 insertions(+), 82 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index d1a73387..7b590951 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -1,23 +1,31 @@ module Interact - ( -- actionBlock - -- , - makeRandomUsers + ( actionBlock + , makeRandomUsers ) where -import Control.Monad (replicateM) - -import Data.Char (isHexDigit) -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 qualified Nameservice.Modules.Nameservice as N -import qualified Nameservice.Modules.Token as T - -import Test.RandomStrings (onlyWith, randomASCII, - randomString) +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 (..), @@ -27,86 +35,54 @@ import Tendermint.Utils.Client (ClientConfig (..), TxClientResponse (..), TxOpts (..), defaultClientTxOpts) +import Tendermint.Utils.ClientUtils (assertTx, rpcConfig) import Tendermint.Utils.User (makeSignerFromUser, makeUser) -import Tendermint.SDK.Application.Module (AppQueryRouter (QApi), - AppTxRouter (TApi)) -import Data.Proxy -import Servant.API ((:<|>) (..)) -import Control.Monad.Reader (ReaderT, runReaderT) -import qualified Tendermint.SDK.Modules.Auth as Auth -import Nameservice.Application -import qualified Network.Tendermint.Client as RPC -import Tendermint.SDK.BaseApp.Query (QueryArgs (..), - QueryResult (..)) -import Tendermint.Utils.ClientUtils (rpcConfig, assertTx) -import Tendermint.SDK.BaseApp.Errors (AppError (..)) -import Tendermint.SDK.Types.Address (Address) -import Data.Default.Class (def) -import Control.Monad (void) +import Test.RandomStrings (onlyWith, randomASCII, + randomString) + -------------------------------------------------------------------------------- -- Actions -------------------------------------------------------------------------------- faucetAccount :: Signer -> T.Amount -> IO () faucetAccount s@(Signer addr _) amount = - void . assertTx . runTxClientM $ - let msg = T.FaucetAccount addr amount - opts = TxOpts - { txOptsGas = 0 - , txOptsSigner = s - } - in faucet opts msg + 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 = - void . assertTx . runTxClientM $ - let msg = N.BuyName amount name newVal addr - opts = TxOpts - { txOptsGas = 0 - , txOptsSigner = s - } - in buy opts msg + runAction_ s buy $ N.BuyName amount name newVal addr deleteName :: Signer -> N.Name -> IO () deleteName s@(Signer addr _) name = - void . assertTx . runTxClientM $ - let msg = N.DeleteName addr name - opts = TxOpts - { txOptsGas = 0 - , txOptsSigner = s - } - in delete opts msg - --- setName :: User -> Name -> Text -> IO () --- setName user@User{userAddress} name val = --- runAction_ user "nameservice" "SetName" (SetName name userAddress val) - --- runAction_ --- :: HasCodec a --- => User --- -> ByteString --- -> Text --- -> a --- -> IO () --- runAction_ user bs t msg = runTransaction_ =<< --- mkSignedRawTransactionWithRoute bs user (TypedMessage t (encode msg)) - --- actionBlock :: (User, User) -> IO () --- actionBlock (user1, user2) = do --- name <- genName --- genCVal <- genWords --- genBVal <- genWords --- genBAmt <- genAmount --- genSVal <- genWords --- faucetAccount user2 genBAmt --- createName user1 name genCVal --- buyName user2 name genBVal genBAmt --- setName user2 name genSVal --- deleteName user2 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 @@ -133,7 +109,7 @@ _ :<|> _ :<|> getAccount = where queryApiP :: Proxy (QApi NameserviceModules) queryApiP = Proxy - + -------------------------------------------------------------------------------- -- Tx Client -------------------------------------------------------------------------------- diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index 1b186277..e57a0f25 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -140,12 +140,15 @@ executables: dependencies: - async - base - - bytestring + - data-default-class - faker + - mtl - nameservice - hs-abci-sdk - hs-abci-test-utils + - hs-tendermint-client - random-strings + - servant - string-conversions - text