From 243d62154a0af690e2f9d3f539e04c5bfd6a9d79 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Thu, 12 Dec 2019 15:13:02 -0500 Subject: [PATCH 01/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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 77192d7d8d824f00e62f9ab2bc05d1a5672e3ee8 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Fri, 3 Jan 2020 10:33:31 -0500 Subject: [PATCH 17/18] Add sleep --- .../nameservice/interact/Interact.hs | 20 +-- hs-abci-examples/nameservice/interact/Main.hs | 9 +- hs-abci-examples/nameservice/package.yaml | 1 + stack.yaml | 25 ++-- stack.yaml.lock | 139 +++++++++--------- 5 files changed, 103 insertions(+), 91 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index 9b5898a4..734b291d 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -1,15 +1,15 @@ 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) +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) -------------------------------------------------------------------------------- -- Users -------------------------------------------------------------------------------- diff --git a/hs-abci-examples/nameservice/interact/Main.hs b/hs-abci-examples/nameservice/interact/Main.hs index 55c92300..bb252f7d 100644 --- a/hs-abci-examples/nameservice/interact/Main.hs +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -1,9 +1,10 @@ module Main where -import Data.String (fromString) -import Faker.Name (name) +import Control.Monad (forever) +import Control.Timeout (sleep) +import Data.String (fromString) +import Faker.Name (name) import Interact -import Control.Monad (forever) main :: IO () main = do @@ -18,3 +19,5 @@ main = do buyName user2 aName "some val" 10 setName user2 aName "some val (again)" deleteName user2 aName + putStrLn "Sleeping for 60 seconds..." + sleep 60 diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index 71c7b783..0a988e03 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 + - timeout tests: tutorial: diff --git a/stack.yaml b/stack.yaml index abbd0bd5..988307f7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -19,30 +19,31 @@ packages: 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 + - http2-client-0.9.0.0 + - http2-grpc-types-0.4.0.0 + - katip-datadog-0.1.0.0 - lens-labels-0.3.0.1 + - polysemy-1.2.3.0 + - polysemy-zoo-0.6.0.0 + - prometheus-2.1.3 - proto-lens-0.5.0.0 - proto-lens-protoc-0.5.0.0 - - containers-0.5.11.0@sha256:28ad7337057442f75bc689315ab4ec7bdf5e6b2c39668f306672cecd82c02798,16685 - - http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348 + - proto-lens-runtime-0.5.0.0 + - proto-lens-setup-0.4.0.2 + - timeout-0.1.1 - binary-0.8.7.0@sha256:ae3e6cca723ac55c54bbb3fa771bcf18142bc727afd57818e66d6ee6c8044f12,7705 - - text-1.2.4.0@sha256:8c24450feb8e3bbb7ea3e17af24ef57e85db077c4bf53e5bcc345b283d1b1d5b,10081 - - katip-elasticsearch-0.6.0.0@sha256:be8513ce611db989c63c9f836af99699767d4fc3a9cb0fd81fcbae4d1f2ed7ee,2746 - bloodhound-0.16.0.0@sha256:b7be3a83e7b914fbe80a9b9de29009ad60cff072f5f8d4af4ee64de8e6406d32,5508 + - containers-0.5.11.0@sha256:28ad7337057442f75bc689315ab4ec7bdf5e6b2c39668f306672cecd82c02798,16685 - hpc-0.6.0.3@sha256:de3f7982345d315f1d7713df38b4f2cf09bd274f7d64dffec0cf2a0d9c8aab19,1185 - - katip-datadog-0.1.0.0 - - prometheus-2.1.3 + - http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348 + - katip-elasticsearch-0.6.0.0@sha256:be8513ce611db989c63c9f836af99699767d4fc3a9cb0fd81fcbae4d1f2ed7ee,2746 + - text-1.2.4.0@sha256:8c24450feb8e3bbb7ea3e17af24ef57e85db077c4bf53e5bcc345b283d1b1d5b,10081 - git: https://github.com/oscoin/avl-auth commit: dfc468845a82cdd7d759943b20853999bc026505 - git: https://github.com/awakesecurity/proto3-suite commit: 3f6dd6f612cf2eba3c05798926ff924b0d5ab4fa - git: https://github.com/awakesecurity/proto3-wire commit: 23015cf6363d1962fde6bdff0de111f7ec59ab75 - - polysemy-1.2.3.0 - - polysemy-zoo-0.6.0.0 - - http2-client-0.9.0.0 - - http2-grpc-types-0.4.0.0 - git: https://github.com/lucasdicioccio/http2-client-grpc commit: 6a1aacfc18e312ef57552133f13dd1024c178706 diff --git a/stack.yaml.lock b/stack.yaml.lock index 2e3ca9ad..0ee7e2cd 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -19,19 +19,26 @@ packages: original: hackage: gimlh-0.1.3.0 - completed: - hackage: proto-lens-runtime-0.5.0.0@sha256:cb39cf13ce4f7dac5414f94a7afe0adc9b831312e6b60588a23bd816accc385f,3132 + hackage: http2-client-0.9.0.0@sha256:b8885c89adcc8b9d4ebb9abf6ae0ac6336e3fdf947a2b1f2b95c4e2c8c4acf01,2685 pantry-tree: - size: 168 - sha256: c45212c2b75d27b7a1e32bb34e1ffd7b3cca98e16f4d5a02016ff9b744a0df64 + size: 853 + sha256: d7a1be66eb14e84cfedd87e8363e406abb244bb74b742e8f0141efce27545008 original: - hackage: proto-lens-runtime-0.5.0.0 + hackage: http2-client-0.9.0.0 - completed: - hackage: proto-lens-setup-0.4.0.2@sha256:2bcc26cd79a318b1988ed89d62f759054fb58bc515700bc4f594bae4a3a64271,3185 + hackage: http2-grpc-types-0.4.0.0@sha256:ffb02152397186dbc925358498b5c005b982ef54f191f4465f9c7947afd7f9d4,1354 pantry-tree: - size: 235 - sha256: 2665efe3a077ba832137de64d2c44493ae7db536b7a0aece2b1778d8a865a76d + size: 405 + sha256: e5025945fee56509538efe6377dd1930189be2bf908bbce428555aa5efab51ff original: - hackage: proto-lens-setup-0.4.0.2 + hackage: http2-grpc-types-0.4.0.0 +- completed: + hackage: katip-datadog-0.1.0.0@sha256:4e72dca402b953bd34b7a744ad23eb90600a420adef67192c9702073564f1cae,1885 + pantry-tree: + size: 415 + sha256: c3d816dcd90b113a246520c8069d3278ee77eacf0f45dd0eb77eb2f7c53d5b3b + original: + hackage: katip-datadog-0.1.0.0 - completed: hackage: lens-labels-0.3.0.1@sha256:228b70bc37d3531c7a80aaa56f7d69bf9f9f0d85637bd886966b01f7d03d3f6b,1196 pantry-tree: @@ -39,6 +46,27 @@ packages: sha256: d0898958b1d869aafe7796452bb04d0e6aef102457ca4c9dcc0fe329271e6091 original: hackage: lens-labels-0.3.0.1 +- completed: + hackage: polysemy-1.2.3.0@sha256:d9cfa7942940c7c6d07d1f26ae70c4f1170f9bd6c331bdbe586e810fafc25f17,5878 + pantry-tree: + size: 3625 + sha256: a54b1b565848944e37a5533bd91e91ecb7cdfa21294ba599c13d015d354c4f39 + original: + hackage: polysemy-1.2.3.0 +- completed: + hackage: polysemy-zoo-0.6.0.0@sha256:44595a96a37b9e33edb87c9f7ff79f8d10f6453d826bc9881b00d8988b69729a,3852 + pantry-tree: + size: 3012 + sha256: 9a8ddbf6c0a5ed2e254202c2990aae99dc4a66fa24949622a123c48795ec6547 + original: + hackage: polysemy-zoo-0.6.0.0 +- completed: + hackage: prometheus-2.1.3@sha256:4fdf8602f7c74367cda182cf71dab108f78a86993b428bf96b61dd6c519b6f22,4296 + pantry-tree: + size: 1559 + sha256: a8d0a0150abddf0d7b673fcb19ff2ef235d4005161826e1538ad802394c9fc0e + original: + hackage: prometheus-2.1.3 - completed: hackage: proto-lens-0.5.0.0@sha256:ec3ad0ab6bd55ac0cd95a2daacb7e826fa2ced6e96c67a57ae1d799b79019c6b,3260 pantry-tree: @@ -54,19 +82,26 @@ packages: original: hackage: proto-lens-protoc-0.5.0.0 - completed: - hackage: containers-0.5.11.0@sha256:28ad7337057442f75bc689315ab4ec7bdf5e6b2c39668f306672cecd82c02798,16685 + hackage: proto-lens-runtime-0.5.0.0@sha256:cb39cf13ce4f7dac5414f94a7afe0adc9b831312e6b60588a23bd816accc385f,3132 pantry-tree: - size: 4849 - sha256: faa4e75922a28f7cfe9920c1d7ab3866b792cefcd29bf79f54cfe3b6b5f57cbf + size: 168 + sha256: c45212c2b75d27b7a1e32bb34e1ffd7b3cca98e16f4d5a02016ff9b744a0df64 original: - hackage: containers-0.5.11.0@sha256:28ad7337057442f75bc689315ab4ec7bdf5e6b2c39668f306672cecd82c02798,16685 + hackage: proto-lens-runtime-0.5.0.0 - completed: - hackage: http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348 + hackage: proto-lens-setup-0.4.0.2@sha256:2bcc26cd79a318b1988ed89d62f759054fb58bc515700bc4f594bae4a3a64271,3185 pantry-tree: - size: 2457 - sha256: 02bcffba9cad572fefb4640f5fc9be68e770b32ab73efcac649db20290994c6d + size: 235 + sha256: 2665efe3a077ba832137de64d2c44493ae7db536b7a0aece2b1778d8a865a76d original: - hackage: http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348 + hackage: proto-lens-setup-0.4.0.2 +- completed: + hackage: timeout-0.1.1@sha256:56c1d3321d7139d1f7ebf04d46c95d3a3f1c8c9e0f15666ae3ccd6bae6204b6e,1427 + pantry-tree: + size: 437 + sha256: e571503d7e609c3fe496de7e858613360bfa6c06e20ac57d9659bd32d0645889 + original: + hackage: timeout-0.1.1 - completed: hackage: binary-0.8.7.0@sha256:ae3e6cca723ac55c54bbb3fa771bcf18142bc727afd57818e66d6ee6c8044f12,7705 pantry-tree: @@ -74,20 +109,6 @@ packages: sha256: 35e44b6d3ccf0d56fc5407dc3f0895e74696a66da189afbd65973c95743f5e25 original: hackage: binary-0.8.7.0@sha256:ae3e6cca723ac55c54bbb3fa771bcf18142bc727afd57818e66d6ee6c8044f12,7705 -- completed: - hackage: text-1.2.4.0@sha256:8c24450feb8e3bbb7ea3e17af24ef57e85db077c4bf53e5bcc345b283d1b1d5b,10081 - pantry-tree: - size: 7457 - sha256: 3437b0a73ce2ae1a81aa8b3438d41a85981c00894cdbee0d6d6d6873046a5d5d - original: - hackage: text-1.2.4.0@sha256:8c24450feb8e3bbb7ea3e17af24ef57e85db077c4bf53e5bcc345b283d1b1d5b,10081 -- completed: - hackage: katip-elasticsearch-0.6.0.0@sha256:be8513ce611db989c63c9f836af99699767d4fc3a9cb0fd81fcbae4d1f2ed7ee,2746 - pantry-tree: - size: 679 - sha256: 907421eb58249f6bed58f4e94f00627b383e53fd0ea0737050c1b1f7ab9fee44 - original: - hackage: katip-elasticsearch-0.6.0.0@sha256:be8513ce611db989c63c9f836af99699767d4fc3a9cb0fd81fcbae4d1f2ed7ee,2746 - completed: hackage: bloodhound-0.16.0.0@sha256:b7be3a83e7b914fbe80a9b9de29009ad60cff072f5f8d4af4ee64de8e6406d32,5508 pantry-tree: @@ -95,6 +116,13 @@ packages: sha256: 7f21ce00e92f7fd24a91dd19a82aab38f62047c1b93f2cc070481760b41a4d37 original: hackage: bloodhound-0.16.0.0@sha256:b7be3a83e7b914fbe80a9b9de29009ad60cff072f5f8d4af4ee64de8e6406d32,5508 +- completed: + hackage: containers-0.5.11.0@sha256:28ad7337057442f75bc689315ab4ec7bdf5e6b2c39668f306672cecd82c02798,16685 + pantry-tree: + size: 4849 + sha256: faa4e75922a28f7cfe9920c1d7ab3866b792cefcd29bf79f54cfe3b6b5f57cbf + original: + hackage: containers-0.5.11.0@sha256:28ad7337057442f75bc689315ab4ec7bdf5e6b2c39668f306672cecd82c02798,16685 - completed: hackage: hpc-0.6.0.3@sha256:de3f7982345d315f1d7713df38b4f2cf09bd274f7d64dffec0cf2a0d9c8aab19,1185 pantry-tree: @@ -103,19 +131,26 @@ packages: original: hackage: hpc-0.6.0.3@sha256:de3f7982345d315f1d7713df38b4f2cf09bd274f7d64dffec0cf2a0d9c8aab19,1185 - completed: - hackage: katip-datadog-0.1.0.0@sha256:4e72dca402b953bd34b7a744ad23eb90600a420adef67192c9702073564f1cae,1885 + hackage: http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348 pantry-tree: - size: 415 - sha256: c3d816dcd90b113a246520c8069d3278ee77eacf0f45dd0eb77eb2f7c53d5b3b + size: 2457 + sha256: 02bcffba9cad572fefb4640f5fc9be68e770b32ab73efcac649db20290994c6d original: - hackage: katip-datadog-0.1.0.0 + hackage: http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348 - completed: - hackage: prometheus-2.1.3@sha256:4fdf8602f7c74367cda182cf71dab108f78a86993b428bf96b61dd6c519b6f22,4296 + hackage: katip-elasticsearch-0.6.0.0@sha256:be8513ce611db989c63c9f836af99699767d4fc3a9cb0fd81fcbae4d1f2ed7ee,2746 pantry-tree: - size: 1559 - sha256: a8d0a0150abddf0d7b673fcb19ff2ef235d4005161826e1538ad802394c9fc0e + size: 679 + sha256: 907421eb58249f6bed58f4e94f00627b383e53fd0ea0737050c1b1f7ab9fee44 original: - hackage: prometheus-2.1.3 + hackage: katip-elasticsearch-0.6.0.0@sha256:be8513ce611db989c63c9f836af99699767d4fc3a9cb0fd81fcbae4d1f2ed7ee,2746 +- completed: + hackage: text-1.2.4.0@sha256:8c24450feb8e3bbb7ea3e17af24ef57e85db077c4bf53e5bcc345b283d1b1d5b,10081 + pantry-tree: + size: 7457 + sha256: 3437b0a73ce2ae1a81aa8b3438d41a85981c00894cdbee0d6d6d6873046a5d5d + original: + hackage: text-1.2.4.0@sha256:8c24450feb8e3bbb7ea3e17af24ef57e85db077c4bf53e5bcc345b283d1b1d5b,10081 - completed: cabal-file: size: 1872 @@ -158,34 +193,6 @@ packages: original: git: https://github.com/awakesecurity/proto3-wire commit: 23015cf6363d1962fde6bdff0de111f7ec59ab75 -- completed: - hackage: polysemy-1.2.3.0@sha256:d9cfa7942940c7c6d07d1f26ae70c4f1170f9bd6c331bdbe586e810fafc25f17,5878 - pantry-tree: - size: 3625 - sha256: a54b1b565848944e37a5533bd91e91ecb7cdfa21294ba599c13d015d354c4f39 - original: - hackage: polysemy-1.2.3.0 -- completed: - hackage: polysemy-zoo-0.6.0.0@sha256:44595a96a37b9e33edb87c9f7ff79f8d10f6453d826bc9881b00d8988b69729a,3852 - pantry-tree: - size: 3012 - sha256: 9a8ddbf6c0a5ed2e254202c2990aae99dc4a66fa24949622a123c48795ec6547 - original: - hackage: polysemy-zoo-0.6.0.0 -- completed: - hackage: http2-client-0.9.0.0@sha256:b8885c89adcc8b9d4ebb9abf6ae0ac6336e3fdf947a2b1f2b95c4e2c8c4acf01,2685 - pantry-tree: - size: 853 - sha256: d7a1be66eb14e84cfedd87e8363e406abb244bb74b742e8f0141efce27545008 - original: - hackage: http2-client-0.9.0.0 -- completed: - hackage: http2-grpc-types-0.4.0.0@sha256:ffb02152397186dbc925358498b5c005b982ef54f191f4465f9c7947afd7f9d4,1354 - pantry-tree: - size: 405 - sha256: e5025945fee56509538efe6377dd1930189be2bf908bbce428555aa5efab51ff - original: - hackage: http2-grpc-types-0.4.0.0 - completed: cabal-file: size: 1910 From bff75c4b35cca4650a3601a20177f5d275632804 Mon Sep 17 00:00:00 2001 From: Carl Factora Date: Mon, 6 Jan 2020 15:40:35 -0500 Subject: [PATCH 18/18] Add ability to generate multiple txs from an action +remove sleep --- .../nameservice/interact/Interact.hs | 55 ++++++++++++++++++- hs-abci-examples/nameservice/interact/Main.hs | 34 ++++++------ hs-abci-examples/nameservice/package.yaml | 2 +- stack.yaml | 1 - stack.yaml.lock | 7 --- 5 files changed, 73 insertions(+), 26 deletions(-) diff --git a/hs-abci-examples/nameservice/interact/Interact.hs b/hs-abci-examples/nameservice/interact/Interact.hs index 734b291d..c501adcb 100644 --- a/hs-abci-examples/nameservice/interact/Interact.hs +++ b/hs-abci-examples/nameservice/interact/Interact.hs @@ -1,6 +1,20 @@ -module Interact where +module Interact + ( genNames + , genVals + , createNames + , buyNames + , setNames + , deleteNames + , faucetAccount + , user1 + , user2 + ) where +import Data.String (fromString) +import Data.String.Conversions (cs) import Data.Text (Text) +import qualified Faker.Lorem as Lorem +import qualified Faker.Name as Name import Nameservice.Modules.Nameservice (BuyName (..), DeleteName (..), Name (..), SetName (..)) @@ -24,27 +38,66 @@ user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e03 -- Actions -------------------------------------------------------------------------------- +genNames :: Int -> IO [Name] +genNames 0 = return [] +genNames x = do + genName <- Name.name + let aName = fromString genName + names <- genNames (x - 1) + return (aName:names) + +genVals :: Int -> IO [Text] +genVals 0 = return [] +genVals x = do + genVal <- Lorem.word + vals <- genVals (x - 1) + return (cs genVal:vals) + createName :: User -> Name -> Text -> IO () createName user name val = buyName user name val 0 +createNames :: User -> [(Name, Text)] -> IO () +createNames _ [] = return () +createNames user ((name, val):rst) = do + createName user name val + createNames user rst + buyName :: User -> Name -> Text -> Amount -> IO () buyName User{userAddress, userPrivKey} name newVal amount = let msg = TypedMessage "BuyName" (encode $ BuyName amount name newVal userAddress) rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg in runTransaction_ rawTx +buyNames :: User -> [(Name, Text, Amount)] -> IO () +buyNames _ [] = return () +buyNames user ((name, val, amt):rst) = do + buyName user name val amt + buyNames user rst + deleteName :: User -> Name -> IO () deleteName User{userAddress, userPrivKey} name = let msg = TypedMessage "DeleteName" (encode $ DeleteName userAddress name) rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg in runTransaction_ rawTx +deleteNames :: User -> [Name] -> IO () +deleteNames _ [] = return () +deleteNames user (name:names) = do + deleteName user name + deleteNames user names + setName :: User -> Name -> Text -> IO () setName User{userAddress, userPrivKey} name val = let msg = TypedMessage "SetName" (encode $ SetName name userAddress val) rawTx = mkSignedRawTransactionWithRoute "nameservice" userPrivKey msg in runTransaction_ rawTx +setNames :: User -> [(Name, Text)] -> IO () +setNames _ [] = return () +setNames user ((name, val):rst) = do + setName user name val + setNames user rst + faucetAccount :: User -> Amount -> IO () faucetAccount User{userAddress, userPrivKey} amount = let msg = TypedMessage "FaucetAccount" (encode $ FaucetAccount userAddress amount) diff --git a/hs-abci-examples/nameservice/interact/Main.hs b/hs-abci-examples/nameservice/interact/Main.hs index bb252f7d..cb860bfc 100644 --- a/hs-abci-examples/nameservice/interact/Main.hs +++ b/hs-abci-examples/nameservice/interact/Main.hs @@ -1,23 +1,25 @@ module Main where -import Control.Monad (forever) -import Control.Timeout (sleep) -import Data.String (fromString) -import Faker.Name (name) +import Control.Monad (forever) +import Data.Maybe (maybe) import Interact +import System.Environment (lookupEnv) +import Text.Read (read) main :: IO () main = do - putStrLn "Running nameservice interaction..." - faucetAccount user1 1000 - faucetAccount user2 1000 + mConc <- lookupEnv "TX_COUNT" + let conc = maybe 1 read mConc + putStrLn $ "Running nameservice interaction w/ TX_COUNT: " <> show conc + faucetAccount user1 10000 + faucetAccount user2 10000 forever $ do - 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 "Sleeping for 60 seconds..." - sleep 60 + names <- genNames conc + vals <- genVals conc + buyVals <- genVals conc + let buyAmts = replicate conc 10 + setVals <- genVals conc + createNames user1 (zip names vals) + buyNames user2 (zip3 names buyVals buyAmts) + setNames user2 (zip names setVals) + deleteNames user2 names diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index 0a988e03..567f6c7a 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -147,8 +147,8 @@ executables: - nameservice - hs-abci-sdk - hs-abci-test-utils + - string-conversions - text - - timeout tests: tutorial: diff --git a/stack.yaml b/stack.yaml index 988307f7..f2e99ae2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -30,7 +30,6 @@ extra-deps: - proto-lens-protoc-0.5.0.0 - proto-lens-runtime-0.5.0.0 - proto-lens-setup-0.4.0.2 - - timeout-0.1.1 - binary-0.8.7.0@sha256:ae3e6cca723ac55c54bbb3fa771bcf18142bc727afd57818e66d6ee6c8044f12,7705 - bloodhound-0.16.0.0@sha256:b7be3a83e7b914fbe80a9b9de29009ad60cff072f5f8d4af4ee64de8e6406d32,5508 - containers-0.5.11.0@sha256:28ad7337057442f75bc689315ab4ec7bdf5e6b2c39668f306672cecd82c02798,16685 diff --git a/stack.yaml.lock b/stack.yaml.lock index 0ee7e2cd..91a3a30d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -95,13 +95,6 @@ packages: sha256: 2665efe3a077ba832137de64d2c44493ae7db536b7a0aece2b1778d8a865a76d original: hackage: proto-lens-setup-0.4.0.2 -- completed: - hackage: timeout-0.1.1@sha256:56c1d3321d7139d1f7ebf04d46c95d3a3f1c8c9e0f15666ae3ccd6bae6204b6e,1427 - pantry-tree: - size: 437 - sha256: e571503d7e609c3fe496de7e858613360bfa6c06e20ac57d9659bd32d0645889 - original: - hackage: timeout-0.1.1 - completed: hackage: binary-0.8.7.0@sha256:ae3e6cca723ac55c54bbb3fa771bcf18142bc727afd57818e66d6ee6c8044f12,7705 pantry-tree: