diff --git a/.dockerignore b/.dockerignore index 2762bb5c..341d88f6 100644 --- a/.dockerignore +++ b/.dockerignore @@ -1,2 +1,6 @@ */docker-compose* -*/test* +**/.stack-work +**/.stack +**/stack.yaml.lock +**/.git +hs-abci-examples/nameservice/conf.d diff --git a/.gitignore b/.gitignore index 0f9b1a9d..a34344d7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,8 @@ .stack-work/ *.cabal *~ +.ci-bins/ +*.dump-hi # nix -result-* \ No newline at end of file +result-* diff --git a/.stylish_haskell.yaml b/.stylish_haskell.yaml index b294d976..8362829d 100644 --- a/.stylish_haskell.yaml +++ b/.stylish_haskell.yaml @@ -205,3 +205,4 @@ language_extensions: - ExistentialQuantification - FunctionalDependencies - ViewPatterns + - PackageImports diff --git a/.travis.yml b/.travis.yml index 3e75c647..2058ec98 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,10 +3,22 @@ ghc: - "8.6.1" cabal: "2.4" sudo: required + +services: +- docker + # Cache .stack for build_times-- +addons: + apt: + sources: + - sourceline: 'ppa:tah83/secp256k1' + packages: + - libsecp256k1-dev + cache: directories: - $HOME/.stack + before_install: # Download and unpack the stack executable - mkdir -p ~/.local/bin @@ -19,15 +31,74 @@ before_install: - rm protoc-release.zip install: - travis_wait 120 stack --skip-ghc-check setup -- travis_wait 120 stack --skip-ghc-check install hlint-2.1.26 stylish-haskell-0.9.4.3 -script: -- make hlint -# When branch is `master` we run `haskell-stylish` and fail if git working directory becomes dirty -- if [ "$TRAVIS_BRANCH" == "master" ]; then make stylish && git diff-index --quiet HEAD; fi +jobs: + include: + + - stage: Cleanliness is next to Godliness + name: "Ensure that code matches style guidelines for PRs to master" + # When branch is `master` we run `haskell-stylish` and fail if git working directory becomes dirty + if: branch = master + script: + - echo "test formatting" + - travis_wait 120 stack --skip-ghc-check install hlint-2.1.26 stylish-haskell-0.9.4.3 weeder-1.0.8 + - make stylish && git diff-index --quiet HEAD + - make hlint + - make weeder + + - echo "test tutorial" + - travis_wait 120 stack --skip-ghc-check install markdown-unlit-0.5.0 + - make test-tutorial + + - stage: Core Tests + name: "Test Core and Client Libraries" + script: + - echo "Test libraries" + # this image is needed for the sdk IAVLSpec + - docker run --name iavl -p 8090:8090 -p 8091:8091 -d foamspace/iavl:latest /iavlserver -db-name "test" -datadir "." -grpc-endpoint "0.0.0.0:8090" -gateway-endpoint "0.0.0.0:8091" + - make test-libraries + - docker rm -f iavl + - echo "Test Libraries with Nix" + - echo "This stage is currently disabled as Nix doesn't seem to play well with libsecp256k1" + + - echo "Test IAVL Client" + - docker run --name iavl -p 8090:8090 -p 8091:8091 -d foamspace/iavl:latest /iavlserver -db-name "test" -datadir "." -grpc-endpoint "0.0.0.0:8090" -gateway-endpoint "0.0.0.0:8091" + - make test-iavl-client + - docker rm -f iavl + + - echo "Test Tendermint Client" + - docker-compose -f hs-tendermint-client/docker-compose.yaml -p test-hs-tendermint-client up -d + - make test-kv-store + - docker-compose -f hs-tendermint-client/docker-compose.yaml -p test-hs-tendermint-client down -v --rmi local + + - echo "Test simple-storage" + - make docker-test-prebake + - docker-compose -f hs-abci-docs/simple-storage/docker-compose.yaml -p test-hs-abci-examples-simple-storage-e2e up -d + - make test-simple-storage + - docker-compose -f hs-abci-docs/simple-storage/docker-compose.yaml -p test-hs-abci-examples-simple-storage-e2e down -v --rmi local -- make test-libraries + - echo "Test nameservice" + - make docker-test-prebake + - docker-compose -f hs-abci-docs/nameservice/docker-compose-test.yaml -p test-hs-abci-examples-nameservice-e2e up -d + - make test-nameservice + - docker-compose -f hs-abci-docs/nameservice/docker-compose-test.yaml -p test-hs-abci-examples-nameservice-e2e down -v --rmi local -- curl https://nixos.org/nix/install | sh -- . $HOME/.nix-profile/etc/profile.d/nix.sh -- stack --nix test hs-abci-types hs-abci-server hs-abci-sdk + - stage: publish website + script: + - echo "building website" + - travis_wait 120 stack --skip-ghc-check install tintin + - make build-site + - make build-docs-local + - mkdir -p ./hs-abci-docs/.stack-work/tintin/rendered/haddocks + - find ./ -type f -name "index.html" | grep -v tintin | sed 's/index.html//g' | xargs -I {} cp -r {} hs-abci-docs/.stack-work/tintin/rendered/haddocks/ + - echo "kepler.dev" > ./hs-abci-docs/.stack-work/tintin/rendered/CNAME + deploy: + provider: pages + local-dir: ./hs-abci-docs/.stack-work/tintin/rendered + email: deploy@travis-ci.org + name: Deployment Bot + skip-cleanup: true + github-token: $GITHUB_TOKEN + keep-history: true + on: + branch: master diff --git a/.weeder.yaml b/.weeder.yaml new file mode 100644 index 00000000..9a8491a9 --- /dev/null +++ b/.weeder.yaml @@ -0,0 +1,136 @@ +- package: + - name: hs-abci-server + - section: + - name: test:hs-abci-server-test + - message: + - name: Redundant build-depends entry + - depends: hspec-discover + +- package: + - name: hs-abci-types + - section: + - name: library + - message: + - name: Missing other-modules entry + - module: + - Proto.Types + - Proto.Types_Fields + - Proto.Vendored.Google.Protobuf.Timestamp + - Proto.Vendored.Google.Protobuf.Timestamp_Fields + - Proto.Vendored.Tendermint.Tendermint.Crypto.Merkle.Merkle + - Proto.Vendored.Tendermint.Tendermint.Crypto.Merkle.Merkle_Fields + - Proto.Vendored.Tendermint.Tendermint.Libs.Common.Types + - Proto.Vendored.Tendermint.Tendermint.Libs.Common.Types_Fields + - message: + - name: Module not compiled + - module: + - Proto.Types + - Proto.Types_Fields + - Proto.Vendored.Gogo.Protobuf.Gogoproto.Gogo + - Proto.Vendored.Gogo.Protobuf.Gogoproto.Gogo_Fields + - Proto.Vendored.Google.Protobuf.Timestamp + - Proto.Vendored.Google.Protobuf.Timestamp_Fields + - Proto.Vendored.Tendermint.Tendermint.Crypto.Merkle.Merkle + - Proto.Vendored.Tendermint.Tendermint.Crypto.Merkle.Merkle_Fields + - Proto.Vendored.Tendermint.Tendermint.Libs.Common.Types + - Proto.Vendored.Tendermint.Tendermint.Libs.Common.Types_Fields + - message: + - name: Redundant build-depends entry + - depends: proto-lens-runtime + - section: + - name: test:hs-abci-types-test + - message: + - name: Redundant build-depends entry + - depends: hspec-discover + +- package: + - name: hs-iavl-client + - section: + - name: test:hs-iavl-client-test + - message: + - name: Redundant build-depends entry + - depends: hspec-discover + - section: + - name: library + - message: + - name: Missing other-modules entry + - module: + - Proto.Google.Protobuf.Empty + - Proto.Iavl.Api + - message: + - name: Module not compiled + - module: + - Proto.Google.Api.Annotations + - Proto.Google.Api.Http + - Proto.Google.Protobuf.Empty + - Proto.Iavl.Api + - Proto.Iavl.Api_Fields + - message: + - name: Redundant build-depends entry + - depends: proto-lens-runtime + +- package: + - name: hs-abci-sdk + - section: + - name: library + - message: + - name: Missing other-modules entry + - module: + - Proto.Modules.Auth + - Proto.Modules.Auth_Fields + - Proto.Modules.Bank + - Proto.Modules.Bank_Fields + - Proto.Types.Transaction + - Proto.Types.Transaction_Fields + - message: + - name: Module not compiled + - module: + - Proto.Modules.Auth + - Proto.Modules.Auth_Fields + - Proto.Modules.Bank + - Proto.Modules.Bank_Fields + - Proto.Types.Transaction + - Proto.Types.Transaction_Fields + - message: + - name: Redundant build-depends entry + - depends: + - polysemy-plugin + - proto-lens-runtime + - section: + - name: test:hs-abci-sdk-test + - message: + - name: Redundant build-depends entry + - depends: + - hspec-discover + - polysemy-plugin + +- package: + - name: simple-storage + - section: + - name: library + - message: + - name: Missing other-modules entry + - module: + - Proto.SimpleStorage.Messages + - Proto.SimpleStorage.Messages_Fields + - message: + - name: Module not compiled + - module: + - Proto.SimpleStorage.Messages + - Proto.SimpleStorage.Messages_Fields + - message: + - name: Redundant build-depends entry + - depends: + - polysemy-plugin + - proto-lens-runtime + + +- package: + - name: nameservice + - section: + - name: library + - message: + - name: Redundant build-depends entry + - depends: polysemy-plugin + - section: + - name: test:tutorial diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 00000000..4e2dac2c --- /dev/null +++ b/Dockerfile @@ -0,0 +1,14 @@ +FROM haskell:8 + +RUN apt-get update && apt-get install --assume-yes protobuf-compiler libsecp256k1-dev + +COPY stack.yaml /tmp/stack.resolver-dummy.yaml +RUN stack --resolver `cat /tmp/stack.resolver-dummy.yaml | grep resolver | sed 's/resolver://'` setup && stack exec -- ghc --version + +# Install GHC. +WORKDIR /project +COPY . /project + +# Install project to /usr/local/bin +RUN stack build --copy-bins --local-bin-path /usr/local/bin + diff --git a/Dockerfile.prebake b/Dockerfile.prebake new file mode 100644 index 00000000..084b21ba --- /dev/null +++ b/Dockerfile.prebake @@ -0,0 +1,8 @@ +# This creates the same image as the regular Dockerfile, but assumes that the binaries +# were compiled into a .ci-bins/ folder in the same directory as this one. This is +# substantially faster than building inside Docker, but only works on Linux systems. +FROM haskell:8 + +RUN apt-get update && apt-get install --assume-yes protobuf-compiler libsecp256k1-dev + +COPY .ci-bins/* /usr/local/bin/ diff --git a/INSTALL.md b/INSTALL.md new file mode 120000 index 00000000..075652d7 --- /dev/null +++ b/INSTALL.md @@ -0,0 +1 @@ +hs-abci-docs/doc/0020-Installation.md \ No newline at end of file diff --git a/Makefile b/Makefile index 53fc9f3a..defa9c1d 100644 --- a/Makefile +++ b/Makefile @@ -1,30 +1,49 @@ -help: ## Ask for help! - @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' +STATS_PORT ?= 9200 +INTERACT_THREAD_COUNT ?= 5 export # This is useful for copying example app binaries built on a linux machine rather than building in docker SIMPLE_STORAGE_BINARY := $(shell stack exec -- which simple-storage) +help: ## Ask for help! + @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' + +# Thank you Apple +UNAME_S := $(shell uname -s) +ifeq ($(UNAME_S),Linux) + SED=sed -i'' +endif +ifeq ($(UNAME_S),Darwin) + SED=sed -i '' +endif + ##################### # Linting and Styling ##################### +weeder: ## look for unused packages and functions + weeder . --build + hlint: ## Run hlint on all haskell projects - stack exec hlint -- -h .hlint.yaml hs-abci-server \ + stack exec hlint -- -e hs -h .hlint.yaml hs-abci-server \ hs-tendermint-client \ hs-abci-extra \ hs-abci-sdk \ - hs-abci-examples/simple-storage \ - hs-abci-examples/nameservice + hs-abci-test-utils \ + hs-abci-docs/simple-storage \ + hs-abci-docs/nameservice \ + hs-iavl-client stylish: ## Run stylish-haskell over all haskell projects find ./hs-abci-types \ ./hs-abci-extra \ ./hs-tendermint-client \ - ./hs-abci-examples \ + ./hs-abci-docs \ ./hs-abci-sdk \ + ./hs-abci-test-utils \ ./hs-abci-server \ + ./hs-iavl-client \ -name "*.hs" | xargs stack exec stylish-haskell -- -c ./.stylish_haskell.yaml -i ################### @@ -32,8 +51,16 @@ stylish: ## Run stylish-haskell over all haskell projects ################### build-docs-local: ## Build the haddocks documentation for just this project (no dependencies) + find . -type f -name "package.yaml" -exec $(SED) -e 's/- -fplugin=Polysemy.Plugin/- -fdefer-type-errors/g' {} + && \ + find . -type f -name "package.yaml" -exec $(SED) -e 's/- -Wall/- -fno-warn-deferred-type-errors/g' {} + && \ stack haddock --no-haddock-deps +build-site: ## Build the tintin site + find ./hs-abci-docs/ -type f -name "*.md" -exec $(SED) -e 's/~~~ haskell.*/```haskell/g' {} + && \ + find ./hs-abci-docs/ -type f -name "*.md" -exec $(SED) -e 's/~~~/```/g' {} + && \ + cd hs-abci-docs && \ + tintin run + ##################### # Core Libraries ##################### @@ -42,7 +69,10 @@ 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 + +test-iavl-client: ## test the iavl client library basic operation (requires grpc service running on port 8090) + stack test hs-iavl-client ##################### @@ -50,13 +80,39 @@ test-libraries: install ## Run the haskell test suite for all haskell libraries ##################### deploy-simple-storage-docker: install ## run the simple storage docker network - docker-compose -f hs-abci-examples/simple-storage/docker-compose.yaml up --build + docker-compose -f hs-abci-docs/simple-storage/docker-compose.yaml up --build + +deploy-nameservice: install ## run the nameservice docker network with elk stack for logging + docker-compose -f hs-abci-docs/nameservice/docker-compose.yaml up --build -deploy-simple-storage-local: install ## run the simple storage locally - stack exec simple-storage +deploy-nameservice-test: install ## run the nameservice docker network for testing + docker-compose -f hs-abci-docs/nameservice/docker-compose-test.yaml up --build -test-kv-store: install ## Run the test suite for the client interface + +##################### +# Tests +##################### + +test-kv-store: ## Run the test suite for the client interface stack test hs-tendermint-client -test-simple-storage: install ## Run the test suite for the example application +test-simple-storage: install ## Run the test suite for the simple-storage example application stack test simple-storage + +test-nameservice: install ## Run the test suite for the nameservice example application + stack test nameservice:nameservice-test + +interact-nameservice: install ## Run nameservice interaction script + INTERACT_THREAD_COUNT=$(INTERACT_THREAD_COUNT) \ + stack exec interact + +test-tutorial: install ## Make sure the tutorial builds + stack test nameservice:tutorial + +##################### +# CI Support +##################### +docker-test-prebake: # Precompile all binaries externally and copy them into a docker image to speed up testing instead of building in Docker. Note that this only works on Linux systems. + mkdir -p .ci-bins + stack build --copy-bins --local-bin-path .ci-bins + docker build -t hs-abci:test -f Dockerfile.prebake . diff --git a/README.md b/README.md index b8d9bbb8..aab1665b 100644 --- a/README.md +++ b/README.md @@ -1,56 +1,14 @@ -# hs-abci +# kepler -![Travis Status](https://travis-ci.com/f-o-a-m/hs-abci.svg?branch=master) +[![Build Status](https://travis-ci.com/f-o-a-m/kepler.svg?branch=master)](https://travis-ci.com/f-o-a-m/kepler) ## Introduction This is the official repository for the Haskell implementation of the ABCI server and SDK for developing applications backed by the Tendermint replication engine. You can read more about Tendermint and the ABCI specs in their [documentation](https://tendermint.com/docs/spec/abci/). -## Build - -### Prerequisites - -#### stack -At the moment the project's build is managed by `stack`. You can find everything you need regarding how to install stack on your machine [here](https://docs.haskellstack.org/en/stable/README/). - -#### protoc -We use a custom setup to generate Haskell bindings to the protobuf files, using the proto-lens library from Google. In order for this to work you need to have the protobuf compiler `protoc` on your machine. You can get installation instructions [here](https://google.github.io/proto-lens/installing-protoc.html) - -#### style -You will also need to install `hlint` and `stylish-haskell` for code hygiene during development. In the project root simply run - -```bash -> stack install hlint stylish-haskell -``` - -### Commands -There is a `Makefile` for this project where you can find all of the options for building, testing etc. The `Makefile` -is documented and there is a help menu which you can access via the commands `make` or `make help`. +To understand how to build a simple application using this library, see the literate haskell [walkthrough](https://github.com/f-o-a-m/kepler/blob/master/hs-abci-docs/nameservice/README.md). -## Protobuf Files and Generated Modules -The protobuf files are all in the `/protos` directory, and we use a custom setup in order -to generate the corresponding `Proto.*` Haskell modules. If you want to view all of these -generated modules, you can run - -```bash -> find hs-abci-types/.stack-work -path '*autogen/Proto' -``` - -to find the root directory. - -## Style Guide -There is a `.stylish-haskell.yaml` file that controls some of the style guide, particularly -around import statements and some indentation rules. There is also a small guide for things that -fall outside of this in the [style wiki](https://github.com/f-o-a-m/hs-abci/wiki/code-style-guide). -If it's not covered by either of these but you think it's really important, mention it in an issue. - -## Building documentation -You can build the haddocks for the library code only using - -```bash -make build-docs-local -``` +## Build -This does not build and link documentation for dependencies, useful mostly for testing -documentation formatting. +See [installation instructions](https://github.com/f-o-a-m/kepler/blob/master/INSTALL.md) diff --git a/hs-abci-docs/.tintin.yml b/hs-abci-docs/.tintin.yml new file mode 100644 index 00000000..1b0cd520 --- /dev/null +++ b/hs-abci-docs/.tintin.yml @@ -0,0 +1,10 @@ +name: kepler +synopsis: Haskell Cosmos SDK +github: f-o-a-m/kepler +author: f-o-a-m +authorWebsite: https://foam.space +color: #5E5184 +#logo: https://pbs.twimg.com/profile_images/791467713956839424/pBRQn1wt_400x400.jpg +titleFont: Lora +titleFontWeight: 400 +bodyFont: Open Sans diff --git a/hs-abci-docs/Makefile b/hs-abci-docs/Makefile new file mode 100644 index 00000000..90f650dc --- /dev/null +++ b/hs-abci-docs/Makefile @@ -0,0 +1,15 @@ +# Thank you Apple +UNAME_S := $(shell uname -s) +ifeq ($(UNAME_S),Linux) + SED=sed -i'' +endif +ifeq ($(UNAME_S),Darwin) + SED=sed -i '' +endif + +pre-process: + find ./doc/ -type f,l -name "*.md" -exec $(SED) -e 's/~~~ haskell.*/```haskell/g' {} + && \ + find ./doc/ -type f,l -name "*.md" -exec $(SED) -e 's/~~~/```/g' {} + + +tintin: + tintin run diff --git a/hs-abci-docs/doc/0010-Overview.md b/hs-abci-docs/doc/0010-Overview.md new file mode 100644 index 00000000..03d97d9f --- /dev/null +++ b/hs-abci-docs/doc/0010-Overview.md @@ -0,0 +1,5 @@ +--- +title: Overview +--- + +The documentation consists of an overview, foundations, a tutorial called ` nameservice` as well as documentation of logging and metrics. You can navigate to the relevant sections on the left side. diff --git a/hs-abci-docs/doc/0020-Installation.md b/hs-abci-docs/doc/0020-Installation.md new file mode 100644 index 00000000..b818511f --- /dev/null +++ b/hs-abci-docs/doc/0020-Installation.md @@ -0,0 +1,67 @@ +--- +title: Installation +--- + +## Build + +### Prerequisites + +#### stack +At the moment the project's build is managed by `stack`. You can find everything you need regarding how to install stack on your machine [here](https://docs.haskellstack.org/en/stable/README/). + +#### protoc +We use a custom setup to generate Haskell bindings to the protobuf files, using the proto-lens library from Google. In order for this to work you need to have the protobuf compiler `protoc` on your machine. You can get installation instructions [here](https://google.github.io/proto-lens/installing-protoc.html) + +#### libsecp256k1 +In order to build with stack you will need this. On MacOS you can use brew: + +``` +> brew tap cuber/homebrew-libsecp256k1 +> brew install libsecp256k1 +``` + +On linux: + +``` +> sudo add-apt-repository ppa:tah83/secp256k1 +> sudo apt-get update +> sudo apt-get install libsecp256k1 +``` + +#### style +You will also need to install `hlint` and `stylish-haskell` for code hygiene during development. In the project root simply run + +```bash +> stack install hlint stylish-haskell +``` + +### Commands +There is a `Makefile` for this project where you can find all of the options for building, testing etc. The `Makefile` +is documented and there is a help menu which you can access via the commands `make` or `make help`. + +## Protobuf Files and Generated Modules +The protobuf files are all in the `/protos` directory, and we use a custom setup in order +to generate the corresponding `Proto.*` Haskell modules. If you want to view all of these +generated modules, you can run + +```bash +> find hs-abci-types/.stack-work -path '*autogen/Proto' +``` + +to find the root directory. + +## Style Guide +There is a `.stylish-haskell.yaml` file that controls some of the style guide, particularly +around import statements and some indentation rules. There is also a small guide for things that +fall outside of this in the [style wiki](https://github.com/f-o-a-m/kepler/wiki/code-style-guide). +If it's not covered by either of these but you think it's really important, mention it in an issue. + +## Building documentation +You can build the haddocks for the library code only using + +```bash +make build-docs-local +``` + +This does not build and link documentation for dependencies, useful mostly for testing +documentation formatting. diff --git a/hs-abci-docs/doc/0310-Overview.md b/hs-abci-docs/doc/0310-Overview.md new file mode 120000 index 00000000..57c4381d --- /dev/null +++ b/hs-abci-docs/doc/0310-Overview.md @@ -0,0 +1 @@ +../nameservice/tutorial/Foundations/01-Overview.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0320-Effects.md b/hs-abci-docs/doc/0320-Effects.md new file mode 120000 index 00000000..28168f98 --- /dev/null +++ b/hs-abci-docs/doc/0320-Effects.md @@ -0,0 +1 @@ +../nameservice/tutorial/Foundations/02-Effects.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0330-Modules.md b/hs-abci-docs/doc/0330-Modules.md new file mode 120000 index 00000000..dad0f248 --- /dev/null +++ b/hs-abci-docs/doc/0330-Modules.md @@ -0,0 +1 @@ +../nameservice/tutorial/Foundations/03-Modules.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0340-Storage.md b/hs-abci-docs/doc/0340-Storage.md new file mode 120000 index 00000000..da8a1d4e --- /dev/null +++ b/hs-abci-docs/doc/0340-Storage.md @@ -0,0 +1 @@ +../nameservice/tutorial/Foundations/04-Storage.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0400-Tutorial.md b/hs-abci-docs/doc/0400-Tutorial.md new file mode 120000 index 00000000..b8f2d6e4 --- /dev/null +++ b/hs-abci-docs/doc/0400-Tutorial.md @@ -0,0 +1 @@ +../nameservice/tutorial/README.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0410-Overview.md b/hs-abci-docs/doc/0410-Overview.md new file mode 120000 index 00000000..c7f7ff49 --- /dev/null +++ b/hs-abci-docs/doc/0410-Overview.md @@ -0,0 +1 @@ +../nameservice/tutorial/Tutorial/Nameservice/01-Overview.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0420-Types.md b/hs-abci-docs/doc/0420-Types.md new file mode 120000 index 00000000..19d081b0 --- /dev/null +++ b/hs-abci-docs/doc/0420-Types.md @@ -0,0 +1 @@ +../nameservice/tutorial/Tutorial/Nameservice/02-Types.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0430-Message.md b/hs-abci-docs/doc/0430-Message.md new file mode 120000 index 00000000..7a036a3d --- /dev/null +++ b/hs-abci-docs/doc/0430-Message.md @@ -0,0 +1 @@ +../nameservice/tutorial/Tutorial/Nameservice/03-Message.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0440-Keeper.md b/hs-abci-docs/doc/0440-Keeper.md new file mode 120000 index 00000000..c0f6820e --- /dev/null +++ b/hs-abci-docs/doc/0440-Keeper.md @@ -0,0 +1 @@ +../nameservice/tutorial/Tutorial/Nameservice/04-Keeper.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0450-Query.md b/hs-abci-docs/doc/0450-Query.md new file mode 120000 index 00000000..b9730e13 --- /dev/null +++ b/hs-abci-docs/doc/0450-Query.md @@ -0,0 +1 @@ +../nameservice/tutorial/Tutorial/Nameservice/05-Query.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0460-Router.md b/hs-abci-docs/doc/0460-Router.md new file mode 120000 index 00000000..a5269423 --- /dev/null +++ b/hs-abci-docs/doc/0460-Router.md @@ -0,0 +1 @@ +../nameservice/tutorial/Tutorial/Nameservice/06-Router.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0470-Module.md b/hs-abci-docs/doc/0470-Module.md new file mode 120000 index 00000000..8c145b0f --- /dev/null +++ b/hs-abci-docs/doc/0470-Module.md @@ -0,0 +1 @@ +../nameservice/tutorial/Tutorial/Nameservice/07-Module.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0480-Application.md b/hs-abci-docs/doc/0480-Application.md new file mode 120000 index 00000000..1598c70c --- /dev/null +++ b/hs-abci-docs/doc/0480-Application.md @@ -0,0 +1 @@ +../nameservice/tutorial/Tutorial/Nameservice/08-Application.md \ No newline at end of file diff --git a/hs-abci-docs/doc/0490-Testing.md b/hs-abci-docs/doc/0490-Testing.md new file mode 120000 index 00000000..ecdd844f --- /dev/null +++ b/hs-abci-docs/doc/0490-Testing.md @@ -0,0 +1 @@ +../nameservice/tutorial/Tutorial/Nameservice/09-Testing.md \ No newline at end of file diff --git a/hs-abci-docs/doc/98-Logging.md b/hs-abci-docs/doc/98-Logging.md new file mode 100644 index 00000000..9ef0ac80 --- /dev/null +++ b/hs-abci-docs/doc/98-Logging.md @@ -0,0 +1,87 @@ +--- +title: Logging +--- + +# Logging + +The SDK has built in support for structured logging via the [katip](https://hackage.haskell.org/package/katip) logging library. Even still, the SDK is agnostic to where you want your logs to go. Katip logs are managed by *scribes* whose job is precisely this, so the output depends on which scribes you use. The two most common scribes are the [console scribe](https://hackage.haskell.org/package/katip-0.8.3.0/docs/Katip-Scribes-Handle.html#v:mkHandleScribe) and the [Elasticsearch scribe](https://hackage.haskell.org/package/katip-elasticsearch). + +The `Nameservice` application has support for either scribe -- it will use Elasticsearch if you provide the `ES_HOST` and `ES_PORT` environment variables or otherwise will default to console logging. The docker deployment is configured to use Elasticsearch. + +## Logging to Elasticsearch + +The docker network includes an `elk` image (Elasticsearch, Logstash, Kibana) for persisting and querying logs. You can read more about this stack [here](https://www.elastic.co/what-is/elk-stack). In summary `elk` is a powerful solution for hosting searchable structured logs. + +When logging to Elasticsearch, you can use the Kibana dashboard for creating queries and visualizations. We will cover the basics here. If you have already launched the docker network, you can view the Kibana dashboard by going to http://localhost:5601/app/kibana. You should see something like + + + +To create an index (a searchable pattern), click on the *Management* tab, click *Create Index*, and enter `nameservice` as the pattern. You should see something like this: + + + +You can ignore the advanced options, e.g. time filter, for now: + + + +To view and search the logs, you can click the `Discover` tab. You should see all of the logs in the resulting search, from both server and application: + + + +## Searching a Log Index + +### Log Structure + +The log structure is effectively a JSON object (with nesting). There are a few fields that are worth pointing out: + +- `message_type`: the abci message type for the message that caused the logs, e.g. `beginBlock`, `deliverTx`, etc. +- `message_hash`: the SHA256 of the protobuf encoded bytes for the abci message that caused the logs. +- `ns` (namespace): a list of increasingly specific scopes for where the log originated. In this case, `nameservice` is the root namespace, `server` or `application` is the next scope. + +Remember that the basic lifescycle of an `ABCI` message is that it first comes to the ABCI-server from tendermint, is then handed off to your application for processing, and finally the response is sent from the ABCI-server back to tendermint. In order to better track this lifecycle, we highly recommend you use the [logging middleware](https://github.com/f-o-a-m/kepler/blob/master/hs-abci-extra/src/Network/ABCI/Server/Middleware/Logger.hs). This middleware will attach the `message_type` and `message_hash` to the context for every single log that is produced, meaning that you can get a trace for a given message by simply searching its hash. + +### Querying the Logs + +You can create custom search filters in the *Discover* tab, just click the *Add a filter* button near the search bar. For example, we can filter all of the logs for those that correspond to a *deliverTx* message: + + + +(**NOTE**: If you run the e2e tests against the docker network, you should see search results corresponding to the transactions created by the test suite. ) + +Similarly, you can compose multiple filters to obtain only those logs emitted by the application itself during a *deliverTx* context, i.e. by filtering for `application` on the `ns` namespace field: + + + +### Indexing Transaction Events + +If you view the results from the filter `message_type=deliverTx, ns=application`, you might see results from the e2e test suite like + +```json +... + "data": { + "message_type": "deliverTx", + "event": { + "old_value": "hello world", + "name": "satoshi", + "new_value": "goodbye to a world" + }, + "event_type": "NameRemapped", + "message_hash": "e9190e5b24e066eb3b967fb39ba9e8ec250393d5c61400b3ed2a9528d967d5e1" + }, + "msg": "NameRemapped", +... +``` + +This log corresponds to an event emitted by the `Nameservice` module during transaction execution, namely the `NameRemapped` event that happens when the owner of a name changes the corresponding value. This is because of the following `BaseApp.logEvent` statement in the `setName` handler: + +```haskell + let event = NameRemapped + { nameRemappedName = setNameName + , nameRemappedNewValue = setNameValue + , nameRemappedOldValue = whoisValue + } + BaseApp.emit event + BaseApp.logEvent event +``` + +In this way the log index serves as a rudimentary event indexer for transaction events as well. diff --git a/hs-abci-docs/doc/99-Metrics.md b/hs-abci-docs/doc/99-Metrics.md new file mode 100644 index 00000000..b0e600e5 --- /dev/null +++ b/hs-abci-docs/doc/99-Metrics.md @@ -0,0 +1,15 @@ +--- +title: Metrics +--- + +# Metrics + +The SDK has some built in support for metrics via [prometheus](https://prometheus.io/), but ultimately you may choose a different runtime interpretation for the metrics, or even choose to ignore it entirely. + +The `Nameservice` application uses application specific metrics, for instance increasing the message counters for module level messages, or for timing module responses. It also uses the server metrics via the [metrics middleware](https://github.com/f-o-a-m/kepler/blob/master/hs-abci-extra/src/Network/ABCI/Server/Middleware/Metrics.hs) to count ABCI messages and to time server responses. This middleware is highly recommended for any production system. + +## Setting up metrics + +The `Nameservice` Docker network is configured to run a prometheus metrics server in addition to a Datadog agent that scrapes and pushes metrics to [datadog](https://www.datadoghq.com/). You must supply a Datadog API key as an environment variable *DD_API_KEY* when you launch the network if you want to do do this. If you don't already have an account, you can [create one](https://www.datadoghq.com/free-datadog-trial/) and receive a two week free trial to play around with this application. + +To simply test if prometheus is indeed collecting your metrics, you can visit `http://localhost:5555/metrics` and you should see something. (`5555` is the default value for the `STATS_PORT` environment variable in the docker compose file.) diff --git a/hs-abci-docs/doc/index.md b/hs-abci-docs/doc/index.md new file mode 100644 index 00000000..7da17c6f --- /dev/null +++ b/hs-abci-docs/doc/index.md @@ -0,0 +1,21 @@ +--- +title: Home +--- + +## Introduction + +This is the official repository for the Haskell implementation of the ABCI server and SDK for developing applications backed by the Tendermint replication engine. + +This site contains a [tutorial](0010-Overview.html) as well as haddocks documentation below. + +You can read more about Tendermint and the ABCI specs in the [documentation](https://tendermint.com/docs/spec/abci/) hosted on their website. + +## Documentation + +- [hs-abci-sdk](haddocks/hs-abci-sdk/) +- [hs-abci-extra](haddocks/hs-abci-extra/) +- [hs-abci-server](haddocks/hs-abci-server/) +- [hs-abci-test-utils](haddocks/hs-abci-test-utils/) +- [hs-abci-types](haddocks/hs-abci-types/) +- [hs-iavl-client](haddocks/hs-iavl-client/) +- [hs-tendermint-client](haddocks/hs-tendermint-client/) diff --git a/hs-abci-examples/nameservice/.gitignore b/hs-abci-docs/nameservice/.gitignore similarity index 100% rename from hs-abci-examples/nameservice/.gitignore rename to hs-abci-docs/nameservice/.gitignore diff --git a/hs-abci-docs/nameservice/README.md b/hs-abci-docs/nameservice/README.md new file mode 100644 index 00000000..d51d4ccc --- /dev/null +++ b/hs-abci-docs/nameservice/README.md @@ -0,0 +1,20 @@ +# Nameservice + +The `Nameservice` application is a sample application that showcases the SDK. It roughly follows the example application from the golang cosmos-sdk, which you can find [here](https://github.com/cosmos/sdk-tutorials/tree/master/nameservice). + +Not that the app itself is also a [tutorial](./tutorial/README.md)! This tutorial explains in depth how the Nameservice app was built. You're encouraged to read this tutorial after reading this. + +## Running the Application + +The `Nameservice` application depends on a few external services. We provide a `docker-compose.yaml` file and highly suggest running the application inside Docker. There is a `make deploy-nameservice` command which can be run from the project root to deploy the application. + +**NOTE** This will also attempt build the nameservice binaries in Docker, which can take a long time. If you are on (Ubuntu) Linux, you can use the `make docker-test-prebake` command first to build the application locally and copy the binaries to the correct image. If you then run `make deploy-nameservice`, it will automatically use these binaries instead of rebuilding inside Docker. + +### Environment Variables + +You can provide the following environment variables when running `make deploy-nameservice` to customize the logger output: + +- `LOG_SEVERITY` (defaults to **info**): minimum log severtiy level `{debug, info, notice, warning, error, critical, alert, emergency}` +- `LOG_VERBOSITY` (defaults to **0**) : for each loggable data point, the level of information actually logged `{0, 1, 2, 3}` + +## [Next: Logging](./docs/Logging.md) diff --git a/hs-abci-examples/nameservice/Setup.hs b/hs-abci-docs/nameservice/Setup.hs similarity index 100% rename from hs-abci-examples/nameservice/Setup.hs rename to hs-abci-docs/nameservice/Setup.hs diff --git a/hs-abci-docs/nameservice/app/Main.hs b/hs-abci-docs/nameservice/app/Main.hs new file mode 100644 index 00000000..dca0944d --- /dev/null +++ b/hs-abci-docs/nameservice/app/Main.hs @@ -0,0 +1,21 @@ +module Main where + +import Control.Concurrent (killThread) +import Control.Exception (bracket) +import Control.Lens ((^.)) +import Data.IORef (readIORef) +import qualified Katip as K +import Nameservice.Config (baseAppContext, + makeAppConfig, + prometheusServerThreadId) +import Nameservice.Server (makeAndServeApplication) +import qualified Tendermint.SDK.BaseApp as BaseApp +import qualified Tendermint.SDK.BaseApp.Logger.Katip as KL + +main :: IO () +main = + let close cfg = do + _ <- K.closeScribes (cfg ^. baseAppContext . BaseApp.contextLogConfig . KL.logEnv) + prometheusThreadId <- readIORef $ cfg ^. prometheusServerThreadId + maybe (pure ()) killThread prometheusThreadId + in bracket makeAppConfig close makeAndServeApplication diff --git a/hs-abci-docs/nameservice/conf.d/openmetrics.d/conf.yaml b/hs-abci-docs/nameservice/conf.d/openmetrics.d/conf.yaml new file mode 100644 index 00000000..ea7fc699 --- /dev/null +++ b/hs-abci-docs/nameservice/conf.d/openmetrics.d/conf.yaml @@ -0,0 +1,10 @@ +## This is configured to work with the docker network, if you want to run in a +## different setting you will need to change 'prometheus_url'. +init_config: + +instances: + - prometheus_url: http://nameservice:5555/metrics + ## namespace option prefixes all metric names in datadog + namespace: nameservice + ## metrics names used in the nameservice app + metrics: ["*"] diff --git a/hs-abci-docs/nameservice/docker-compose-test.yaml b/hs-abci-docs/nameservice/docker-compose-test.yaml new file mode 100644 index 00000000..5703df46 --- /dev/null +++ b/hs-abci-docs/nameservice/docker-compose-test.yaml @@ -0,0 +1,44 @@ +version: '3.7' +services: + tendermint-init: + image: tendermint/tendermint:v0.32.8 + command: init + volumes: + - tendermint-storage:/tendermint + tendermint: + depends_on: + - tendermint-init + - nameservice + image: tendermint/tendermint:v0.32.8 + command: node --rpc.laddr=tcp://0.0.0.0:26657 --proxy_app=tcp://nameservice:26658 + volumes: + - tendermint-storage:/tendermint + restart: always + ports: + - "26656-26657:26656-26657" + nameservice: + build: + context: ../../. + dockerfile: Dockerfile + image: hs-abci:test + depends_on: + - iavl + environment: + - STATS_PORT=9200 + - IAVL_HOST=iavl + - IAVL_PORT=8090 + restart: always + entrypoint: /usr/local/bin/nameservice + expose: + - "26658" + - "9200" + iavl: + image: foamspace/iavl:latest + command: /iavlserver -db-name "test" -datadir "." -grpc-endpoint "0.0.0.0:8090" -gateway-endpoint "0.0.0.0:8091" + ports: + - "8090-8091:8091-8091" + expose: + - "8090" + - "8091" +volumes: + tendermint-storage: diff --git a/hs-abci-docs/nameservice/docker-compose.yaml b/hs-abci-docs/nameservice/docker-compose.yaml new file mode 100644 index 00000000..ee4d3891 --- /dev/null +++ b/hs-abci-docs/nameservice/docker-compose.yaml @@ -0,0 +1,69 @@ +version: '3.7' +services: + tendermint-init: + image: tendermint/tendermint:v0.32.8 + command: init + volumes: + - tendermint-storage:/tendermint + tendermint: + depends_on: + - tendermint-init + - nameservice + image: tendermint/tendermint:v0.32.8 + command: node --rpc.laddr=tcp://0.0.0.0:26657 --proxy_app=tcp://nameservice:26658 + volumes: + - tendermint-storage:/tendermint + restart: always + ports: + - "26656-26657:26656-26657" + nameservice: + entrypoint: /usr/local/bin/nameservice + build: + context: ../../. + dockerfile: Dockerfile + image: hs-abci:test + environment: + - ES_HOST=elk + - ES_PORT=9200 + - STATS_PORT=5555 + - IAVL_HOST=iavl + - IAVL_port=8090 + restart: always + depends_on: + - elk + - iavl + ports: + - "26658" + - "5555:5555" + datadog: + image: datadog/agent:latest + depends_on: + - nameservice + restart: always + environment: + - DD_API_KEY=${DD_API_KEY} + - IAVL_HOST=iavl + - IAVL_PORT=8090 + volumes: + - /proc/:/host/proc/:ro + - ./conf.d/openmetrics.d:/etc/datadog-agent/conf.d/openmetrics.d + elk: + image: sebp/elk:683 + ports: + - "5601:5601" + - "9200:9200" + - "5044:5044" + expose: + - "9200" + - "5601" + iavl: + image: foamspace/iavl:latest + command: /iavlserver -db-name "test" -datadir "." -grpc-endpoint "0.0.0.0:8090" -gateway-endpoint "0.0.0.0:8091" + ports: + - "8090-8091:8091-8091" + expose: + - "8090" + - "8091" + +volumes: + tendermint-storage: diff --git a/hs-abci-docs/nameservice/images/kibana_discover.png b/hs-abci-docs/nameservice/images/kibana_discover.png new file mode 100644 index 00000000..3695504e Binary files /dev/null and b/hs-abci-docs/nameservice/images/kibana_discover.png differ diff --git a/hs-abci-docs/nameservice/images/kibana_discover_filter.png b/hs-abci-docs/nameservice/images/kibana_discover_filter.png new file mode 100644 index 00000000..38512f20 Binary files /dev/null and b/hs-abci-docs/nameservice/images/kibana_discover_filter.png differ diff --git a/hs-abci-docs/nameservice/images/kibana_discover_filter_advanced.png b/hs-abci-docs/nameservice/images/kibana_discover_filter_advanced.png new file mode 100644 index 00000000..9e3877fd Binary files /dev/null and b/hs-abci-docs/nameservice/images/kibana_discover_filter_advanced.png differ diff --git a/hs-abci-docs/nameservice/images/kibana_management.png b/hs-abci-docs/nameservice/images/kibana_management.png new file mode 100644 index 00000000..eb8444bd Binary files /dev/null and b/hs-abci-docs/nameservice/images/kibana_management.png differ diff --git a/hs-abci-docs/nameservice/images/kibana_management_2.png b/hs-abci-docs/nameservice/images/kibana_management_2.png new file mode 100644 index 00000000..6e5686d1 Binary files /dev/null and b/hs-abci-docs/nameservice/images/kibana_management_2.png differ diff --git a/hs-abci-docs/nameservice/images/kibana_welcome_screen.png b/hs-abci-docs/nameservice/images/kibana_welcome_screen.png new file mode 100644 index 00000000..174d9a61 Binary files /dev/null and b/hs-abci-docs/nameservice/images/kibana_welcome_screen.png differ diff --git a/hs-abci-docs/nameservice/interact/Interact.hs b/hs-abci-docs/nameservice/interact/Interact.hs new file mode 100644 index 00000000..8a19b59e --- /dev/null +++ b/hs-abci-docs/nameservice/interact/Interact.hs @@ -0,0 +1,192 @@ +module Interact + ( actionBlock + , makeRandomUsers + ) where + +import Control.Monad (replicateM, void) +import Control.Monad.Reader (ReaderT, runReaderT) +import Data.Char (isHexDigit) +import Data.Default.Class (def) +import Data.Proxy +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Faker.Lorem as Lorem +import qualified Faker.Name as Name +import qualified Faker.Utils as Utils +import Nameservice.Application +import qualified Nameservice.Modules.Nameservice as N +import qualified Network.Tendermint.Client as RPC +import Servant.API ((:<|>) (..)) +import Tendermint.SDK.Application.Module (ApplicationC, ApplicationD, + ApplicationQ) +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import Tendermint.SDK.BaseApp.Query (QueryArgs (..), + QueryResult (..)) +import qualified Tendermint.SDK.Modules.Auth as Auth +import Tendermint.SDK.Types.Address (Address) +import Tendermint.Utils.Client (ClientConfig (..), + EmptyTxClient (..), + HasQueryClient (..), + HasTxClient (..), + QueryClientResponse (..), + Signer (..), + TxClientResponse (..), + TxOpts (..), + defaultClientTxOpts) +import Tendermint.Utils.ClientUtils (assertTx, rpcConfig) +import Tendermint.Utils.User (makeSignerFromUser, + makeUser) +import Test.RandomStrings (onlyWith, randomASCII, + randomString) + +-------------------------------------------------------------------------------- +-- Actions +-------------------------------------------------------------------------------- + +faucetAccount :: Signer -> Auth.Amount -> IO () +faucetAccount s@(Signer addr _) amount = + runAction_ s faucet $ N.FaucetAccountMsg addr N.nameserviceCoinId amount + +createName :: Signer -> Text -> Text -> IO () +createName s name val = buyName s name val 0 + +buyName :: Signer -> Text -> Text -> Auth.Amount -> IO () +buyName s@(Signer addr _) name newVal amount = + runAction_ s buy $ N.BuyNameMsg amount name newVal addr + +deleteName :: Signer -> Text -> IO () +deleteName s@(Signer addr _) name = + runAction_ s delete $ N.DeleteNameMsg addr name + +setName :: Signer -> Text -> Text -> IO () +setName s@(Signer addr _) name val = + runAction_ s set $ N.SetNameMsg name addr val + +runAction_ + :: Signer + -> (TxOpts -> msg -> TxClientM (TxClientResponse () ())) + -> msg + -> IO () +runAction_ s f = void . assertTx . runTxClientM . f (TxOpts 0 s) + +actionBlock :: (Signer, Signer) -> IO () +actionBlock (s1, s2) = do + name <- genName + genCVal <- genWords + genBVal <- genWords + genBAmt <- genAmount + genSVal <- genWords + faucetAccount s2 genBAmt + createName s1 name genCVal + buyName s2 name genBVal genBAmt + setName s2 name genSVal + deleteName s2 name + +-------------------------------------------------------------------------------- +-- Users +-------------------------------------------------------------------------------- + +makeRandomUsers :: IO (Signer, Signer) +makeRandomUsers = do + str1 <- randomString (onlyWith isHexDigit randomASCII) 64 + str2 <- randomString (onlyWith isHexDigit randomASCII) 64 + return $ (makeSignerFromUser . makeUser $ str1 + ,makeSignerFromUser . makeUser $ str2 + ) + +-------------------------------------------------------------------------------- +-- Query Client +-------------------------------------------------------------------------------- + +getAccount + :: QueryArgs Address + -> RPC.TendermintM (QueryClientResponse Auth.Account) + +_ :<|> _ :<|> getAccount = + genClientQ (Proxy :: Proxy m) queryApiP def + where + queryApiP :: Proxy (ApplicationQ NameserviceModules) + queryApiP = Proxy + + -------------------------------------------------------------------------------- +-- Tx Client +-------------------------------------------------------------------------------- + +txClientConfig :: ClientConfig +txClientConfig = + let getNonce addr = do + resp <- RPC.runTendermintM rpcConfig $ getAccount $ + QueryArgs + { queryArgsHeight = -1 + , queryArgsProve = False + , queryArgsData = addr + } + -- @NOTE: TxNonce should be +1 of accountNonce + case resp of + QueryError e -> + if appErrorCode e == 2 + then pure 1 + else error $ "Unknown nonce error: " <> show (appErrorMessage e) + QueryResponse QueryResult {queryResultData} -> + pure $ 1 + Auth.accountNonce queryResultData + + in ClientConfig + { clientGetNonce = getNonce + , clientRPC = rpcConfig + } + +type TxClientM = ReaderT ClientConfig IO + +runTxClientM :: TxClientM a -> IO a +runTxClientM m = runReaderT m txClientConfig + +-- Nameservice Client +buy + :: TxOpts + -> N.BuyNameMsg + -> TxClientM (TxClientResponse () ()) + +set + :: TxOpts + -> N.SetNameMsg + -> TxClientM (TxClientResponse () ()) + +delete + :: TxOpts + -> N.DeleteNameMsg + -> TxClientM (TxClientResponse () ()) + +faucet + :: TxOpts + -> N.FaucetAccountMsg + -> TxClientM (TxClientResponse () ()) + +(buy :<|> set :<|> delete :<|> faucet) :<|> + (_ :<|> _) :<|> + EmptyTxClient = + genClientT (Proxy @TxClientM) txApiCP txApiDP defaultClientTxOpts + where + txApiCP :: Proxy (ApplicationC NameserviceModules) + txApiCP = Proxy + txApiDP :: Proxy (ApplicationD NameserviceModules) + txApiDP = Proxy + + +-------------------------------------------------------------------------------- +-- Generation +-------------------------------------------------------------------------------- + +genWords :: IO Text +genWords = do + numWords <- Utils.randomNum (1, 10) + ws <- replicateM numWords Lorem.word + return . cs . unwords $ ws + +genName :: IO Text +genName = fromString <$> Name.name + +genAmount :: IO Auth.Amount +genAmount = do + genAmt <- Utils.randomNum (1, 1000) + return . fromInteger . toInteger $ genAmt diff --git a/hs-abci-docs/nameservice/interact/Main.hs b/hs-abci-docs/nameservice/interact/Main.hs new file mode 100644 index 00000000..c0cb01e1 --- /dev/null +++ b/hs-abci-docs/nameservice/interact/Main.hs @@ -0,0 +1,17 @@ +module Main where + +import Control.Concurrent.Async (forConcurrently_) +import Control.Monad (forever, replicateM) +import Data.Maybe (maybe) +import Interact +import System.Environment (lookupEnv) +import Text.Read (read) + +main :: IO () +main = do + mThreads <- lookupEnv "INTERACT_THREAD_COUNT" + let threads = maybe 1 read mThreads :: Int + usersForThreads <- replicateM threads makeRandomUsers + putStrLn $ "Running nameservice interaction with #threads: " <> show threads + forever $ forConcurrently_ [0..(threads-1)] $ \i -> + actionBlock $ usersForThreads !! i diff --git a/hs-abci-docs/nameservice/package.yaml b/hs-abci-docs/nameservice/package.yaml new file mode 100644 index 00000000..2f4b224d --- /dev/null +++ b/hs-abci-docs/nameservice/package.yaml @@ -0,0 +1,199 @@ +name: nameservice +version: 0.1.0.0 +github: "f-o-a-m/kepler/hs-abci-docs/nameservice" +license: Apache +author: "Martin Allen" +maintainer: "martin@foam.space" +copyright: "2020 Martin Allen" + +description: Please see the README on GitHub at + +extra-source-files: +- README.md + +default-extensions: + - DeriveGeneric + - NamedFieldPuns + - RecordWildCards + - RankNTypes + - TypeFamilies + - FlexibleContexts + - DataKinds + - TypeApplications + - OverloadedStrings + - PolyKinds + - GeneralizedNewtypeDeriving + - ScopedTypeVariables + - TupleSections + - LambdaCase + - GADTs + - TypeOperators + - FlexibleInstances + - MultiParamTypeClasses + - DefaultSignatures + - FunctionalDependencies + - TypeFamilyDependencies + - DeriveFunctor + - StandaloneDeriving + - ConstraintKinds + +library: + source-dirs: src + dependencies: + - aeson + - aeson-casing + - base >= 4.7 && < 5 + - bloodhound + - errors + - hs-abci-extra + - hs-abci-server + - hs-abci-sdk + - hs-abci-types + - http-client + - katip + - katip-elasticsearch + - lens + - polysemy + - polysemy-plugin + - proto3-suite + - servant + - string-conversions + - text + - validation + ghc-options: + - -fplugin=Polysemy.Plugin + - -Werror + - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wredundant-constraints + exposed-modules: + - Nameservice.Application + - Nameservice.Config + - Nameservice.Aeson + - Nameservice.Server + - Nameservice.Modules.Nameservice + - Nameservice.Modules.Nameservice.Messages + - Nameservice.Modules.Nameservice.Types + - Nameservice.Modules.Nameservice.Store + - Nameservice.Modules.Nameservice.Keeper + - Nameservice.Modules.Nameservice.Query + - Nameservice.Modules.Nameservice.Router + +executables: + nameservice: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - base + - hs-abci-sdk + - katip + - lens + - nameservice + + gen-protos-exe: + main: Main.hs + source-dirs: protogen + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - aeson-casing + - base + - bytestring + - hs-abci-sdk + - nameservice + - pretty + - proto3-suite + - proto3-wire + + interact: + main: Main.hs + source-dirs: interact + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Werror + - -Wall + dependencies: + - async + - base + - data-default-class + - faker + - mtl + - nameservice + - hs-abci-sdk + - hs-abci-test-utils + - hs-tendermint-client + - random-strings + - servant + - string-conversions + - text + +tests: + tutorial: + main: README.lhs + source-dirs: tutorial + other-modules: + - Tutorial.Nameservice.Application + - Tutorial.Nameservice.Keeper + - Tutorial.Nameservice.Message + - Tutorial.Nameservice.Module + - Tutorial.Nameservice.Query + - Tutorial.Nameservice.Types + - Tutorial.Nameservice.Testing + ghc-options: -Wall -pgmL markdown-unlit + dependencies: + - aeson + - base + - data-default-class + - hs-abci-sdk + - hs-abci-server + - hs-abci-test-utils + - hs-tendermint-client + - lens + - markdown-unlit + - mtl + - nameservice + - polysemy + - polysemy-plugin + - proto3-suite + - servant + - string-conversions + - text + nameservice-test: + main: Spec.hs + source-dirs: test + other-modules: + - Nameservice.Test.E2ESpec + - Nameservice.Test.EventOrphans + ghc-options: + - -Werror + - -Wall + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - base >= 4.7 && < 5 + - conduit + - data-default-class + - hs-abci-sdk + - hs-abci-test-utils + - hs-abci-types + - hs-tendermint-client + - hspec + - aeson + - mtl + - nameservice + - resourcet + - servant + - text + - unordered-containers diff --git a/hs-abci-docs/nameservice/protogen/Main.hs b/hs-abci-docs/nameservice/protogen/Main.hs new file mode 100644 index 00000000..be58d77c --- /dev/null +++ b/hs-abci-docs/nameservice/protogen/Main.hs @@ -0,0 +1,11 @@ +-- @NOTE: ^ possibly the only language extension needed from tutorial +-- Seems to be the only requirement for generating the .proto string + +module Main where + +import Protogen (messagesProtoFile, whoisProtoFile) + +main :: IO () +main = do + putStrLn messagesProtoFile + putStrLn whoisProtoFile diff --git a/hs-abci-docs/nameservice/protogen/Protogen.hs b/hs-abci-docs/nameservice/protogen/Protogen.hs new file mode 100644 index 00000000..18f831d6 --- /dev/null +++ b/hs-abci-docs/nameservice/protogen/Protogen.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE MagicHash #-} + +-- @NOTE: ^ possibly the only language extension needed from tutorial +-- Seems to be the only requirement for generating the .proto string + +module Protogen (messagesProtoFile, whoisProtoFile) where + +import Data.Aeson.Casing (snakeCase) +import qualified Data.ByteString.Lazy as BL +import GHC.Exts (Proxy#, proxy#) +import Nameservice.Modules.Nameservice.Messages (BuyNameMessage (..), + DeleteNameMsg (..), + SetNameMsg (..)) +import Nameservice.Modules.Nameservice.Types (WhoisMessage (..)) +import Proto3.Suite (DotProtoDefinition, + Message, + fromByteString, + message, + packageFromDefs) +import Proto3.Suite.DotProto as DotProto +import Proto3.Suite.DotProto.Rendering (RenderingOptions, + defRenderingOptions) +import qualified Proto3.Wire.Decode as Decode +import Proto3.Wire.Types (FieldNumber (..)) +import Tendermint.SDK.Types.Address (Address (..)) +import qualified Text.PrettyPrint as PP + + +-------------------------------------------------------------------------------- +-- Requires magic hash extension +-------------------------------------------------------------------------------- + +stripPrefixName :: DotProtoIdentifier -> DotProtoIdentifier -> FieldNumber -> PP.Doc +stripPrefixName (Single typeName) (Single fieldName) _ = + let prefixLen = length typeName + fieldName' = Single . snakeCase . drop prefixLen $ fieldName + in pPrint fieldName' +-- @NOTE: we don't yet need for other identifiers +stripPrefixName _ _ _ = error "stripPrefixName unused case" + +msgStripPrefixOptions :: RenderingOptions +msgStripPrefixOptions = defRenderingOptions { roSelectorName = stripPrefixName } + +messagesProtoFile :: String +messagesProtoFile = toProtoFile msgStripPrefixOptions $ packageFromDefs "nameservice" + ([ message (proxy# :: Proxy# SetNameMsg) + , message (proxy# :: Proxy# BuyNameMessage) + , message (proxy# :: Proxy# DeleteNameMsg) + ] :: [DotProtoDefinition]) + +whoisProtoFile :: String +whoisProtoFile = toProtoFile msgStripPrefixOptions $ packageFromDefs "nameservice" + ([ message (proxy# :: Proxy# WhoisMessage) ] :: [DotProtoDefinition]) diff --git a/hs-abci-docs/nameservice/src/Nameservice/Aeson.hs b/hs-abci-docs/nameservice/src/Nameservice/Aeson.hs new file mode 100644 index 00000000..5b4a80af --- /dev/null +++ b/hs-abci-docs/nameservice/src/Nameservice/Aeson.hs @@ -0,0 +1,7 @@ +module Nameservice.Aeson where + +import Data.Aeson (Options) +import Data.Aeson.Casing (aesonDrop, snakeCase) + +defaultNameserviceOptions :: String -> Options +defaultNameserviceOptions prefix = aesonDrop (length prefix) snakeCase diff --git a/hs-abci-docs/nameservice/src/Nameservice/Application.hs b/hs-abci-docs/nameservice/src/Nameservice/Application.hs new file mode 100644 index 00000000..36568480 --- /dev/null +++ b/hs-abci-docs/nameservice/src/Nameservice/Application.hs @@ -0,0 +1,35 @@ +module Nameservice.Application + ( NameserviceModules + , handlersContext + ) where + +import Data.Proxy +import qualified Nameservice.Modules.Nameservice as N +import Tendermint.SDK.Application (HandlersContext (..), + ModuleList (..), + baseAppAnteHandler) +import qualified Tendermint.SDK.BaseApp as BA +import Tendermint.SDK.Crypto (Secp256k1) +import qualified Tendermint.SDK.Modules.Auth as A +import qualified Tendermint.SDK.Modules.Bank as B + + +type NameserviceModules = + '[ N.Nameservice + , B.Bank + , A.Auth + ] + +handlersContext :: HandlersContext Secp256k1 NameserviceModules BA.CoreEffs +handlersContext = HandlersContext + { signatureAlgP = Proxy @Secp256k1 + , modules = nameserviceModules + , compileToCore = BA.defaultCompileToCore + , anteHandler = baseAppAnteHandler + } + where + nameserviceModules = + N.nameserviceModule + :+ B.bankModule + :+ A.authModule + :+ NilModules diff --git a/hs-abci-docs/nameservice/src/Nameservice/Config.hs b/hs-abci-docs/nameservice/src/Nameservice/Config.hs new file mode 100644 index 00000000..437c1cfe --- /dev/null +++ b/hs-abci-docs/nameservice/src/Nameservice/Config.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Nameservice.Config + ( AppConfig(..) + , baseAppContext + , prometheusServerThreadId + , makeAppConfig + ) where + +import Control.Concurrent (ThreadId) +import Control.Error (MaybeT (..), + runMaybeT) +import Control.Lens (makeLenses, (&), + (.~), (^.)) +import Data.IORef (IORef, newIORef) +import Data.Maybe (fromMaybe) +import Data.String.Conversions (cs) +import qualified Database.V5.Bloodhound as BH +import qualified Katip as K +import qualified Katip.Scribes.ElasticSearch as ES +import qualified Network.HTTP.Client as Client +import System.Environment +import System.IO (stdout) +import qualified Tendermint.SDK.BaseApp as BaseApp +import Tendermint.SDK.BaseApp.Logger.Katip as KL +import qualified Tendermint.SDK.BaseApp.Metrics.Prometheus as P +import Tendermint.SDK.BaseApp.Store.IAVLStore (GrpcConfig (..), + initIAVLVersions) +import Text.Read (read) + + +data AppConfig = AppConfig + { _baseAppContext :: BaseApp.Context + , _prometheusServerThreadId :: IORef (Maybe ThreadId) + } +makeLenses ''AppConfig + +makeAppConfig :: IO AppConfig +makeAppConfig = do + versions <- initIAVLVersions + grpcConfig <- do + host <- getEnv "IAVL_HOST" + port <- read <$> getEnv "IAVL_PORT" + pure $ GrpcConfig host port + prometheusEnv <- runMaybeT $ do + prometheusPort <- read <$> MaybeT (lookupEnv "STATS_PORT") + pure $ P.MetricsScrapingConfig prometheusPort + c <- BaseApp.makeContext (KL.InitialLogNamespace "dev" "nameservice") prometheusEnv versions grpcConfig + prometheusServer <- newIORef Nothing + addScribesToLogEnv $ + AppConfig { _baseAppContext = c + , _prometheusServerThreadId = prometheusServer + } + +addScribesToLogEnv :: AppConfig -> IO AppConfig +addScribesToLogEnv cfg = do + logLevel <- makeLogLevel + loggingCfg <- makeLoggingConfig + let initialLogEnv = cfg ^. baseAppContext . BaseApp.contextLogConfig . KL.logEnv + scribesLogEnv <- makeKatipScribe loggingCfg logLevel initialLogEnv + pure $ cfg & + baseAppContext . BaseApp.contextLogConfig . KL.logEnv .~ scribesLogEnv + +-------------------------------------------------------------------------------- + +data LogLevel = LogLevel + { severity :: K.Severity + , verbosity :: K.Verbosity + } + +makeLogLevel :: IO LogLevel +makeLogLevel = do + -- LOG_SEVERITY should be in {debug, info, notice, warning, error, critical, alert, emergency} + msev <- lookupEnv "LOG_SEVERITY" + let s = fromMaybe K.InfoS (parseSeverity =<< msev) + -- LOG_VERBOSITY should be in {0,1,2,3} + mverb <- lookupEnv "LOG_VERBOSITY" + let v = fromMaybe K.V0 (parseVerbosity =<< mverb) + return LogLevel {severity = s, verbosity = v} + where + parseSeverity = K.textToSeverity . cs + parseVerbosity v + | v == "0" = Just K.V0 + | v == "1" = Just K.V1 + | v == "2" = Just K.V2 + | v == "3" = Just K.V3 + | otherwise = Nothing + + +data KatipConfig = ES {host :: String, port :: String} | Console + +makeLoggingConfig :: IO KatipConfig +makeLoggingConfig = do + mEsConfig <- runMaybeT $ + ES <$> (MaybeT $ lookupEnv "ES_HOST") <*> (MaybeT $ lookupEnv "ES_PORT") + pure $ fromMaybe Console mEsConfig + +-- makes a log environment for console logs / ES logs +makeKatipScribe + :: KatipConfig + -> LogLevel + -> K.LogEnv + -> IO K.LogEnv +makeKatipScribe kcfg LogLevel{..} le = case kcfg of + Console -> do + handleScribe <- K.mkHandleScribe K.ColorIfTerminal stdout (K.permitItem severity) verbosity + K.registerScribe "stdout" handleScribe K.defaultScribeSettings le + ES {host, port} -> do + mgr <- Client.newManager Client.defaultManagerSettings + let serverAddress = "http://" <> host <> ":" <> port + bloodhoundEnv = BH.mkBHEnv (BH.Server $ cs serverAddress) mgr + esScribe <- ES.mkEsScribe ES.defaultEsScribeCfgV5 bloodhoundEnv (BH.IndexName "nameservice") + (BH.MappingName "application-logs") (K.permitItem severity) verbosity + K.registerScribe "es" esScribe K.defaultScribeSettings le diff --git a/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice.hs b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice.hs new file mode 100644 index 00000000..a5db500f --- /dev/null +++ b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice.hs @@ -0,0 +1,42 @@ +module Nameservice.Modules.Nameservice + + ( + -- * Module + Nameservice + , nameserviceModule + , module Nameservice.Modules.Nameservice.Keeper + , module Nameservice.Modules.Nameservice.Messages + , module Nameservice.Modules.Nameservice.Store + , module Nameservice.Modules.Nameservice.Query + , module Nameservice.Modules.Nameservice.Router + , module Nameservice.Modules.Nameservice.Types + + + ) where + +import Data.Proxy +import Nameservice.Modules.Nameservice.Keeper +import Nameservice.Modules.Nameservice.Messages +import Nameservice.Modules.Nameservice.Query +import Nameservice.Modules.Nameservice.Router +import Nameservice.Modules.Nameservice.Store (Name (..)) +import Nameservice.Modules.Nameservice.Types +import Polysemy (Members) +import Tendermint.SDK.Application (Module (..), + ModuleEffs) +import Tendermint.SDK.BaseApp (DefaultCheckTx (..)) +import Tendermint.SDK.Modules.Bank (Bank) + + +type Nameservice = + Module NameserviceName MessageApi MessageApi QueryApi NameserviceEffs '[Bank] + +nameserviceModule + :: Members (ModuleEffs Nameservice) r + => Nameservice r +nameserviceModule = Module + { moduleTxDeliverer = messageHandlers + , moduleTxChecker = defaultCheckTx (Proxy :: Proxy MessageApi) (Proxy :: Proxy r) + , moduleQuerier = querier + , moduleEval = eval + } diff --git a/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Keeper.hs b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Keeper.hs new file mode 100644 index 00000000..d45ca683 --- /dev/null +++ b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Keeper.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Nameservice.Modules.Nameservice.Keeper + ( NameserviceEffs + , NameserviceKeeper(..) + , nameserviceCoinId + , setName + , deleteName + , buyName + , faucetAccount + , getWhois + , eval + ) where + +import Nameservice.Modules.Nameservice.Messages +import Nameservice.Modules.Nameservice.Store +import Nameservice.Modules.Nameservice.Types +import Polysemy (Member, Members, Sem, + interpret, makeSem) +import Polysemy.Error (Error, mapError, + throw) +import Polysemy.Output (Output) +import qualified Tendermint.SDK.BaseApp as BaseApp +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import Tendermint.SDK.Modules.Auth (Coin (..), CoinId) +import Tendermint.SDK.Modules.Bank (BankEffs, burn, mint, + transfer) + +data NameserviceKeeper m a where + FaucetAccount :: FaucetAccountMsg -> NameserviceKeeper m () + BuyName :: BuyNameMsg -> NameserviceKeeper m () + DeleteName :: DeleteNameMsg -> NameserviceKeeper m () + SetName :: SetNameMsg -> NameserviceKeeper m () + GetWhois :: Name -> NameserviceKeeper m (Maybe Whois) + +makeSem ''NameserviceKeeper + +type NameserviceEffs = '[NameserviceKeeper, Error NameserviceError] + +nameserviceCoinId :: CoinId +nameserviceCoinId = "nameservice" + +eval + :: Members BaseApp.TxEffs r + => Members BankEffs r + => Members BaseApp.BaseEffs r + => forall a. Sem (NameserviceKeeper ': Error NameserviceError ': r) a + -> Sem r a +eval = mapError BaseApp.makeAppError . evalNameservice + where + evalNameservice + :: Members BaseApp.TxEffs r + => Members BaseApp.BaseEffs r + => Members BankEffs r + => Member (Error NameserviceError) r + => Sem (NameserviceKeeper ': r) a -> Sem r a + evalNameservice = + interpret (\case + FaucetAccount msg -> faucetAccountF msg + BuyName msg -> buyNameF msg + DeleteName msg -> deleteNameF msg + SetName msg -> setNameF msg + GetWhois name -> M.lookup name whoisMap + ) + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- + +faucetAccountF + :: Members [BaseApp.Logger, Output BaseApp.Event] r + => Members BankEffs r + => FaucetAccountMsg + -> Sem r () +faucetAccountF FaucetAccountMsg{..} = do + let coin = Coin faucetAccountCoinId faucetAccountAmount + mint faucetAccountTo coin + let event = Faucetted + { faucettedAccount = faucetAccountTo + , faucettedCoinId = faucetAccountCoinId + , faucettedAmount = faucetAccountAmount + } + BaseApp.emit event + BaseApp.logEvent event + +setNameF + :: Members BaseApp.TxEffs r + => Members BaseApp.BaseEffs r + => Member (Error NameserviceError) r + => SetNameMsg + -> Sem r () +setNameF SetNameMsg{..} = do + mwhois <- M.lookup (Name setNameName) whoisMap + case mwhois of + Nothing -> throw $ UnauthorizedSet "Cannot claim name with SetMessage tx." + Just currentWhois@Whois{..} -> + if whoisOwner /= setNameOwner + then throw $ UnauthorizedSet "Setter must be the owner of the Name." + else do + M.insert (Name setNameName) (currentWhois {whoisValue = setNameValue}) whoisMap + let event = NameRemapped + { nameRemappedName = setNameName + , nameRemappedNewValue = setNameValue + , nameRemappedOldValue = whoisValue + } + BaseApp.emit event + BaseApp.logEvent event + +deleteNameF + :: Members BaseApp.TxEffs r + => Members BaseApp.BaseEffs r + => Members BankEffs r + => Member (Error NameserviceError) r + => DeleteNameMsg + -> Sem r () +deleteNameF DeleteNameMsg{..} = do + mWhois <- M.lookup (Name deleteNameName) whoisMap + case mWhois of + Nothing -> throw $ InvalidDelete "Can't remove unassigned name." + Just Whois{..} -> + if whoisOwner /= deleteNameOwner + then throw $ InvalidDelete "Deleter must be the owner." + else do + mint deleteNameOwner (Coin nameserviceCoinId whoisPrice) + M.delete (Name deleteNameName) whoisMap + let event = NameDeleted + { nameDeletedName = deleteNameName + } + BaseApp.emit event + BaseApp.logEvent event + +buyNameF + :: Members BaseApp.TxEffs r + => Members BankEffs r + => Members BaseApp.BaseEffs r + => Member (Error NameserviceError) r + => BuyNameMsg + -> Sem r () +-- ^ did it succeed +buyNameF msg = do + let name = buyNameName msg + mWhois <- M.lookup (Name name) whoisMap + case mWhois of + -- The name is unclaimed, go ahead and debit the account + -- and create it. + Nothing -> buyUnclaimedName msg + -- The name is currently claimed, we will transfer the + -- funds and ownership + Just whois -> buyClaimedName msg whois + where + buyUnclaimedName + :: Members BaseApp.TxEffs r + => Members BaseApp.BaseEffs r + => Members BankEffs r + => BuyNameMsg + -> Sem r () + buyUnclaimedName BuyNameMsg{..} = do + burn buyNameBuyer (Coin nameserviceCoinId buyNameBid) + let whois = Whois + { whoisOwner = buyNameBuyer + , whoisValue = buyNameValue + , whoisPrice = buyNameBid + } + M.insert (Name buyNameName) whois whoisMap + let event = NameClaimed + { nameClaimedOwner = buyNameBuyer + , nameClaimedName = buyNameName + , nameClaimedValue = buyNameValue + , nameClaimedBid = buyNameBid + } + BaseApp.emit event + BaseApp.logEvent event + + buyClaimedName + :: Members BaseApp.TxEffs r + => Member (Error NameserviceError) r + => Members BaseApp.BaseEffs r + => Members BankEffs r + => BuyNameMsg + -> Whois + -> Sem r () + buyClaimedName BuyNameMsg{..} currentWhois = + let Whois{ whoisPrice = forsalePrice, whoisOwner = previousOwner } = currentWhois + in if buyNameBid > forsalePrice + then do + transfer buyNameBuyer (Coin nameserviceCoinId buyNameBid) previousOwner + -- update new owner, price and value based on BuyName + let whois' = currentWhois + { whoisOwner = buyNameBuyer + , whoisPrice = buyNameBid + , whoisValue = buyNameValue + } + M.insert (Name buyNameName) whois' whoisMap + let event = NameClaimed + { nameClaimedOwner = buyNameBuyer + , nameClaimedName = buyNameName + , nameClaimedValue = buyNameValue + , nameClaimedBid = buyNameBid + } + BaseApp.emit event + BaseApp.logEvent event + else throw (InsufficientBid "Bid must exceed the price.") + diff --git a/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Messages.hs b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Messages.hs new file mode 100644 index 00000000..04dbfb55 --- /dev/null +++ b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Messages.hs @@ -0,0 +1,167 @@ +module Nameservice.Modules.Nameservice.Messages + ( SetNameMsg(..) + , BuyNameMsg(..) + , DeleteNameMsg(..) + , FaucetAccountMsg(..) + , BuyNameMessage(..) + ) where + +import Data.Bifunctor (bimap, first) +import Data.Foldable (sequenceA_) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Validation (Validation (..)) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Proto3.Suite (Message, Named, fromByteString, + toLazyByteString) +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Modules.Auth (Amount (..), CoinId (..)) +import Tendermint.SDK.Modules.Bank () +import Tendermint.SDK.Types.Address (Address (..)) +import Tendermint.SDK.Types.Message (HasMessageType (..), Msg (..), + ValidateMessage (..), + coerceProto3Error, + formatMessageParseError, + isAuthorCheck, nonEmptyCheck) + +-- @NOTE: .proto genration will use these type names as is +-- only field names stripped of prefixes during generation +data FaucetAccountMsg = FaucetAccountMsg + { faucetAccountTo :: Address + , faucetAccountCoinId :: CoinId + , faucetAccountAmount :: Amount + } deriving (Eq, Show) + +data FaucetAccountMessage = FaucetAccountMessage + { faucetAccountMessageTo :: Address + , faucetAccountMessageCoinId :: Text + , faucetAccountMessageAmount :: Word64 + } deriving (Eq, Show, Generic) +instance Message FaucetAccountMessage +instance Named FaucetAccountMessage + +instance HasMessageType FaucetAccountMsg where + messageType _ = "FaucetAccount" + +instance HasCodec FaucetAccountMsg where + encode FaucetAccountMsg {..} = + let faucetAccountMessaage = FaucetAccountMessage + { faucetAccountMessageTo = faucetAccountTo + , faucetAccountMessageCoinId = unCoinId faucetAccountCoinId + , faucetAccountMessageAmount = unAmount faucetAccountAmount + } + in cs . toLazyByteString $ faucetAccountMessaage + decode = + let toFaucetAccount FaucetAccountMessage {..} = FaucetAccountMsg + { faucetAccountTo = faucetAccountMessageTo + , faucetAccountCoinId = CoinId faucetAccountMessageCoinId + , faucetAccountAmount = Amount faucetAccountMessageAmount + } + in bimap (formatMessageParseError . coerceProto3Error) toFaucetAccount + . fromByteString @FaucetAccountMessage + +instance ValidateMessage FaucetAccountMsg where + validateMessage _ = Success () + +-------------------------------------------------------------------------------- + +data SetNameMsg = SetNameMsg + { setNameName :: Text + , setNameOwner :: Address + , setNameValue :: Text + } deriving (Eq, Show, Generic) + +instance Message SetNameMsg +instance Named SetNameMsg + +instance HasMessageType SetNameMsg where + messageType _ = "SetName" + +instance HasCodec SetNameMsg where + encode = cs . toLazyByteString + decode = first (formatMessageParseError . coerceProto3Error) . fromByteString + +-- TL;DR. ValidateBasic: https://cosmos.network/docs/tutorial/set-name.html#msg +instance ValidateMessage SetNameMsg where + validateMessage msg@Msg{..} = + let SetNameMsg{setNameName, setNameValue} = msgData + in sequenceA_ + [ nonEmptyCheck "Name" setNameName + , nonEmptyCheck "Value" setNameValue + , isAuthorCheck "Owner" msg setNameOwner + ] + +-------------------------------------------------------------------------------- + +data DeleteNameMsg = DeleteNameMsg + { deleteNameOwner :: Address + , deleteNameName :: Text + } deriving (Eq, Show, Generic) + +instance Message DeleteNameMsg +instance Named DeleteNameMsg + +instance HasMessageType DeleteNameMsg where + messageType _ = "DeleteName" + +instance HasCodec DeleteNameMsg where + encode = cs . toLazyByteString + decode = first (formatMessageParseError . coerceProto3Error) . fromByteString + +instance ValidateMessage DeleteNameMsg where + validateMessage msg@Msg{..} = + let DeleteNameMsg{deleteNameName} = msgData + in sequenceA_ + [ nonEmptyCheck "Name" deleteNameName + , isAuthorCheck "Owner" msg deleteNameOwner + ] + +-------------------------------------------------------------------------------- + +data BuyNameMsg = BuyNameMsg + { buyNameBid :: Amount + , buyNameName :: Text + , buyNameValue :: Text + , buyNameBuyer :: Address + } deriving (Eq, Show) + +data BuyNameMessage = BuyNameMessage + { buyNameMessageBid :: Word64 + , buyNameMessageName :: Text + , buyNameMessageValue :: Text + , buyNameMessageBuyer :: Address + } deriving (Eq, Show, Generic) +instance Message BuyNameMessage +instance Named BuyNameMessage + +instance HasMessageType BuyNameMsg where + messageType _ = "BuyName" + +instance HasCodec BuyNameMsg where + encode BuyNameMsg {..} = + let buyNameMessage = BuyNameMessage + { buyNameMessageBid = unAmount buyNameBid + , buyNameMessageName = buyNameName + , buyNameMessageValue = buyNameValue + , buyNameMessageBuyer = buyNameBuyer + } + in cs . toLazyByteString $ buyNameMessage + decode = + let toBuyName BuyNameMessage {..} = BuyNameMsg + { buyNameBid = Amount buyNameMessageBid + , buyNameName = buyNameMessageName + , buyNameValue = buyNameMessageValue + , buyNameBuyer = buyNameMessageBuyer + } + in bimap (formatMessageParseError . coerceProto3Error) toBuyName + . fromByteString @BuyNameMessage + +instance ValidateMessage BuyNameMsg where + validateMessage msg@Msg{..} = + let BuyNameMsg{buyNameName, buyNameValue} = msgData + in sequenceA_ + [ nonEmptyCheck "Name" buyNameName + , nonEmptyCheck "Value" buyNameValue + , isAuthorCheck "Owner" msg buyNameBuyer + ] diff --git a/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Query.hs b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Query.hs new file mode 100644 index 00000000..13911abb --- /dev/null +++ b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Query.hs @@ -0,0 +1,23 @@ +module Nameservice.Modules.Nameservice.Query + ( QueryApi + , querier + ) where + +import Nameservice.Modules.Nameservice.Store +import Nameservice.Modules.Nameservice.Types +import Polysemy (Members) +import Servant.API ((:>)) +import qualified Tendermint.SDK.BaseApp as BaseApp +import qualified Tendermint.SDK.BaseApp.Store.Map as M + +-------------------------------------------------------------------------------- +-- | Query API +-------------------------------------------------------------------------------- + + +type QueryApi = "whois" :> BaseApp.StoreLeaf (M.Map Name Whois) + +querier + :: Members BaseApp.QueryEffs r + => BaseApp.RouteQ QueryApi r +querier = BaseApp.storeQueryHandler whoisMap diff --git a/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Router.hs b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Router.hs new file mode 100644 index 00000000..e1063e29 --- /dev/null +++ b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Router.hs @@ -0,0 +1,66 @@ +module Nameservice.Modules.Nameservice.Router + ( MessageApi + , messageHandlers + ) where + +import Nameservice.Modules.Nameservice.Keeper (NameserviceEffs, + buyName, deleteName, + faucetAccount, + setName) +import Nameservice.Modules.Nameservice.Messages +import Polysemy (Members, Sem) +import Servant.API ((:<|>) (..)) +import Tendermint.SDK.BaseApp ((:~>), BaseEffs, + Return, RouteTx, + RoutingTx (..), + TypedMessage, + incCount, withTimer) +import Tendermint.SDK.Types.Message (Msg (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) + + +type MessageApi = + TypedMessage BuyNameMsg :~> Return () + :<|> TypedMessage SetNameMsg :~> Return () + :<|> TypedMessage DeleteNameMsg :~> Return () + :<|> TypedMessage FaucetAccountMsg :~> Return () + +messageHandlers + :: Members NameserviceEffs r + => Members BaseEffs r + => RouteTx MessageApi r +messageHandlers = buyNameH :<|> setNameH :<|> deleteNameH :<|> faucetH + +buyNameH + :: Members NameserviceEffs r + => Members BaseEffs r + => RoutingTx BuyNameMsg + -> Sem r () +buyNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "buy_total" + withTimer "buy_duration_seconds" $ buyName msgData + +setNameH + :: Members NameserviceEffs r + => Members BaseEffs r + => RoutingTx SetNameMsg + -> Sem r () +setNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "set_total" + withTimer "set_duration_seconds" $ setName msgData + +deleteNameH + :: Members NameserviceEffs r + => Members BaseEffs r + => RoutingTx DeleteNameMsg + -> Sem r () +deleteNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "delete_total" + withTimer "delete_duration_seconds" $ deleteName msgData + +faucetH + :: Members NameserviceEffs r + => RoutingTx FaucetAccountMsg + -> Sem r () +faucetH (RoutingTx Tx{txMsg=Msg{msgData}}) = + faucetAccount msgData diff --git a/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Store.hs b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Store.hs new file mode 100644 index 00000000..98e0a38d --- /dev/null +++ b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Store.hs @@ -0,0 +1,38 @@ +module Nameservice.Modules.Nameservice.Store + ( Name(..) + , whoisMap + ) where + +import Control.Lens (iso) +import qualified Data.Aeson as A +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Text (Text) +import GHC.TypeLits (symbolVal) +import Nameservice.Modules.Nameservice.Types +import qualified Tendermint.SDK.BaseApp as BaseApp +import qualified Tendermint.SDK.BaseApp.Store.Map as M + +data NameserviceNamespace + +store :: BaseApp.Store NameserviceNamespace +store = BaseApp.makeStore $ + BaseApp.KeyRoot $ cs . symbolVal $ Proxy @NameserviceName + +newtype Name = Name {unName :: Text} deriving (Eq, Show, A.ToJSON, A.FromJSON) + +instance BaseApp.RawKey Name where + rawKey = iso (\(Name n) -> cs n) (Name . cs) + +instance BaseApp.QueryData Name + +data WhoisMapKey = WhoisMapKey + +instance BaseApp.RawKey WhoisMapKey where + rawKey = iso (const "whoisMap") (const WhoisMapKey) + +instance BaseApp.IsKey WhoisMapKey NameserviceNamespace where + type Value WhoisMapKey NameserviceNamespace = M.Map Name Whois + +whoisMap :: M.Map Name Whois +whoisMap = M.makeMap WhoisMapKey store diff --git a/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Types.hs b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Types.hs new file mode 100644 index 00000000..8ba01d70 --- /dev/null +++ b/hs-abci-docs/nameservice/src/Nameservice/Modules/Nameservice/Types.hs @@ -0,0 +1,151 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Nameservice.Modules.Nameservice.Types where + +import Data.Aeson as A +import Data.Bifunctor (bimap) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Nameservice.Aeson (defaultNameserviceOptions) +import Proto3.Suite (Message, Named, fromByteString, + toLazyByteString) +import qualified Tendermint.SDK.BaseApp as BaseApp +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Modules.Auth (Amount (..), CoinId (..)) +import Tendermint.SDK.Modules.Bank () +import Tendermint.SDK.Types.Address (Address) + +-------------------------------------------------------------------------------- + +type NameserviceName = "nameservice" + +-------------------------------------------------------------------------------- + + +data Whois = Whois + { whoisValue :: Text + , whoisOwner :: Address + , whoisPrice :: Amount + } deriving (Eq, Show) + +data WhoisMessage = WhoisMessage + { whoisMessageValue :: Text + , whoisMessageOwner :: Address + , whoisMessagePrice :: Word64 + } deriving (Eq, Show, Generic) +instance Message WhoisMessage +instance Named WhoisMessage + +instance HasCodec Whois where + encode Whois {..} = + let whoisMessage = WhoisMessage + { whoisMessageValue = whoisValue + , whoisMessageOwner = whoisOwner + , whoisMessagePrice = unAmount whoisPrice + } + in cs . toLazyByteString $ whoisMessage + decode = + let toWhois WhoisMessage {..} = Whois + { whoisValue = whoisMessageValue + , whoisOwner = whoisMessageOwner + , whoisPrice = Amount whoisMessagePrice + } + in bimap (cs . show) toWhois . fromByteString @WhoisMessage + +-------------------------------------------------------------------------------- +-- Exceptions +-------------------------------------------------------------------------------- + +data NameserviceError = + InsufficientBid Text + | UnauthorizedSet Text + | InvalidDelete Text + +instance BaseApp.IsAppError NameserviceError where + makeAppError (InsufficientBid msg) = + BaseApp.AppError + { appErrorCode = 1 + , appErrorCodespace = "nameservice" + , appErrorMessage = msg + } + makeAppError (UnauthorizedSet msg) = + BaseApp.AppError + { appErrorCode = 2 + , appErrorCodespace = "nameservice" + , appErrorMessage = msg + } + makeAppError (InvalidDelete msg) = + BaseApp.AppError + { appErrorCode = 3 + , appErrorCodespace = "nameservice" + , appErrorMessage = msg + } + +-------------------------------------------------------------------------------- +-- Events +-------------------------------------------------------------------------------- + +data Faucetted = Faucetted + { faucettedAccount :: Address + , faucettedCoinId :: CoinId + , faucettedAmount :: Amount + } deriving (Eq, Show, Generic) + +faucettedAesonOptions :: A.Options +faucettedAesonOptions = defaultNameserviceOptions "faucetted" + +instance ToJSON Faucetted where + toJSON = A.genericToJSON faucettedAesonOptions +instance FromJSON Faucetted where + parseJSON = A.genericParseJSON faucettedAesonOptions +instance BaseApp.ToEvent Faucetted +instance BaseApp.Select Faucetted + +data NameClaimed = NameClaimed + { nameClaimedOwner :: Address + , nameClaimedName :: Text + , nameClaimedValue :: Text + , nameClaimedBid :: Amount + } deriving (Eq, Show, Generic) + +nameClaimedAesonOptions :: A.Options +nameClaimedAesonOptions = defaultNameserviceOptions "nameClaimed" + +instance ToJSON NameClaimed where + toJSON = A.genericToJSON nameClaimedAesonOptions +instance FromJSON NameClaimed where + parseJSON = A.genericParseJSON nameClaimedAesonOptions +instance BaseApp.ToEvent NameClaimed +instance BaseApp.Select NameClaimed + +data NameRemapped = NameRemapped + { nameRemappedName :: Text + , nameRemappedOldValue :: Text + , nameRemappedNewValue :: Text + } deriving (Eq, Show, Generic) + +nameRemappedAesonOptions :: A.Options +nameRemappedAesonOptions = defaultNameserviceOptions "nameRemapped" + +instance ToJSON NameRemapped where + toJSON = A.genericToJSON nameRemappedAesonOptions +instance FromJSON NameRemapped where + parseJSON = A.genericParseJSON nameRemappedAesonOptions +instance BaseApp.ToEvent NameRemapped +instance BaseApp.Select NameRemapped + +data NameDeleted = NameDeleted + { nameDeletedName :: Text + } deriving (Eq, Show, Generic) + +nameDeletedAesonOptions :: A.Options +nameDeletedAesonOptions = defaultNameserviceOptions "nameDeleted" + +instance ToJSON NameDeleted where + toJSON = A.genericToJSON nameDeletedAesonOptions +instance FromJSON NameDeleted where + parseJSON = A.genericParseJSON nameDeletedAesonOptions +instance BaseApp.ToEvent NameDeleted +instance BaseApp.Select NameDeleted diff --git a/hs-abci-docs/nameservice/src/Nameservice/Server.hs b/hs-abci-docs/nameservice/src/Nameservice/Server.hs new file mode 100644 index 00000000..148e3b2e --- /dev/null +++ b/hs-abci-docs/nameservice/src/Nameservice/Server.hs @@ -0,0 +1,45 @@ +module Nameservice.Server (makeAndServeApplication) where +import Control.Lens ((^?), _Just) +import Data.Foldable (fold) +import Data.IORef (writeIORef) +import Data.Monoid (Endo (..)) +import Nameservice.Application (handlersContext) +import Nameservice.Config (AppConfig (..)) +import Network.ABCI.Server (serveApp) +import Network.ABCI.Server.App (Middleware) +import qualified Network.ABCI.Server.Middleware.Logger as Logger +import qualified Network.ABCI.Server.Middleware.Metrics as Met +import Polysemy (Sem) + +import Tendermint.SDK.Application (createIOApp, + makeApp) +import Tendermint.SDK.BaseApp (Context (..), + CoreEffs, + contextPrometheusEnv, + runCoreEffs) +import Tendermint.SDK.BaseApp.Metrics.Prometheus (envMetricsState, + forkMetricsServer, + metricsRegistry) + +makeAndServeApplication :: AppConfig -> IO () +makeAndServeApplication AppConfig{..} = do + putStrLn "Starting ABCI application..." + case _contextPrometheusEnv _baseAppContext of + Nothing -> pure () + Just prometheusEnv -> do + prometheusThreadId <- forkMetricsServer prometheusEnv + writeIORef _prometheusServerThreadId (Just prometheusThreadId) + metricsMiddleware <- + case _baseAppContext ^? contextPrometheusEnv . _Just . envMetricsState . metricsRegistry of + Nothing -> pure id + Just registry -> Met.mkMetricsMiddleware Met.defaultBuckets registry + + let nat :: forall a. Sem CoreEffs a -> IO a + nat = runCoreEffs _baseAppContext + application = makeApp handlersContext + middleware :: Middleware (Sem CoreEffs) + middleware = appEndo . fold $ + [ Endo Logger.mkLoggerM + , Endo metricsMiddleware + ] + serveApp $ createIOApp nat (middleware application) diff --git a/hs-abci-docs/nameservice/test/Nameservice/Test/E2ESpec.hs b/hs-abci-docs/nameservice/test/Nameservice/Test/E2ESpec.hs new file mode 100644 index 00000000..95251666 --- /dev/null +++ b/hs-abci-docs/nameservice/test/Nameservice/Test/E2ESpec.hs @@ -0,0 +1,516 @@ +module Nameservice.Test.E2ESpec (spec) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, modifyMVar_, + newMVar, readMVar) +import Control.Monad (forM_, void) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ReaderT, runReaderT) +import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.Aeson as A +import Data.Conduit (awaitForever, + runConduit, (.|)) +import Data.Default.Class (def) +import Data.HashSet (fromList) +import Data.Proxy +import Data.Text (Text) +import Nameservice.Application +import qualified Nameservice.Modules.Nameservice as N +import Nameservice.Test.EventOrphans () +import qualified Network.ABCI.Types.Messages.FieldTypes as FT +import qualified Network.Tendermint.Client as RPC +import Servant.API ((:<|>) (..)) +import qualified Tendermint.SDK.Application.Module as M +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import Tendermint.SDK.BaseApp.Events (ToEvent (..)) +import Tendermint.SDK.BaseApp.Query (QueryArgs (..), + QueryResult (..), + defaultQueryArgs) +import qualified Tendermint.SDK.Modules.Auth as Auth +import qualified Tendermint.SDK.Modules.Bank as B +import Tendermint.SDK.Types.Address (Address) +import Tendermint.Utils.Client (ClientConfig (..), + EmptyTxClient (..), + HasQueryClient (..), + HasTxClient (..), + QueryClientResponse (..), + Signer (..), + TxClientResponse (..), + TxOpts (..), + defaultClientTxOpts) +import Tendermint.Utils.ClientUtils (assertQuery, assertTx, + deliverTxEvents, + ensureQueryResponseCode, + ensureResponseCodes, + rpcConfig) +import Tendermint.Utils.Events (FromEvent (..)) +import Tendermint.Utils.User (makeSignerFromUser, + makeUser) +import Test.Hspec + + + +spec :: Spec +spec = do + let satoshi = "satoshi" + faucetAmount = 1000 + + beforeAll (testInit faucetAmount) $ do + + describe "Nameservice Spec" $ do + it "Can query /health to make sure the node is alive" $ const $ do + resp <- RPC.runTendermintM rpcConfig $ RPC.health + resp `shouldBe` RPC.ResultHealth + + it "Can query account balances" $ const $ do + void . assertQuery . RPC.runTendermintM rpcConfig $ + let queryArgs = defaultQueryArgs { queryArgsData = signerAddress user1 } + in getBalance queryArgs N.nameserviceCoinId + + it "Can create a name" $ \tenv -> do + let val = "hello world" + msg = N.BuyNameMsg + { buyNameBid = 0 + , buyNameName = satoshi + , buyNameValue = val + , buyNameBuyer = signerAddress user1 + } + claimedLog = N.NameClaimed + { nameClaimedOwner = signerAddress user1 + , nameClaimedName = satoshi + , nameClaimedValue = val + , nameClaimedBid = 0 + } + opts = TxOpts + { txOptsSigner = user1 + , txOptsGas = 0 + } + + -- Add event to be monitored and later checked for + addEventToCheck tenv claimedLog + + resp <- assertTx . runTxClientM $ buyName opts msg + ensureResponseCodes (0,0) resp + [evclaimedLog] <- deliverTxEvents (Proxy @N.NameClaimed) resp + fromEvent evclaimedLog `shouldBe` Right claimedLog + + it "Can query for a name" $ const $ do + let expected = N.Whois + { whoisValue = "hello world" + , whoisOwner = signerAddress user1 + , whoisPrice = 0 + } + foundWhois <- fmap queryResultData . assertQuery . RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = N.Name satoshi } + foundWhois `shouldBe` expected + + it "Can query for a name that doesn't exist" $ const $ do + let nope = "nope" + resp <- RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = N.Name nope } + ensureQueryResponseCode 2 resp + + it "Can set a name value" $ \tenv -> do + let oldVal = "hello world" + newVal = "goodbye to a world" + msg = N.SetNameMsg + { setNameName = satoshi + , setNameOwner = signerAddress user1 + , setNameValue = newVal + } + remappedLog = N.NameRemapped + { nameRemappedName = satoshi + , nameRemappedOldValue = oldVal + , nameRemappedNewValue = newVal + } + opts = TxOpts + { txOptsSigner = user1 + , txOptsGas = 0 + } + + -- Add event to be monitored and later checked for + addEventToCheck tenv remappedLog + + resp <- assertTx . runTxClientM $ setName opts msg + ensureResponseCodes (0,0) resp + [evremappedLog] <- deliverTxEvents (Proxy @N.NameRemapped) resp + fromEvent evremappedLog `shouldBe` Right remappedLog + + let expected = N.Whois + { whoisValue = "goodbye to a world" + , whoisOwner = signerAddress user1 + , whoisPrice = 0 + } + foundWhois <- fmap queryResultData . assertQuery . RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = N.Name satoshi } + foundWhois `shouldBe` expected + + it "Can fail to set a name" $ const $ do + -- try to set a name without being the owner + let msg = N.SetNameMsg + { setNameName = satoshi + , setNameOwner = signerAddress user2 + , setNameValue = "goodbye to a world" + } + opts = TxOpts + { txOptsSigner = user2 + , txOptsGas = 0 + } + resp <- assertTx . runTxClientM $ setName opts msg + ensureResponseCodes (0,2) resp + + it "Can buy an existing name" $ \tenv -> do + balance1 <- getUserBalance user1 + balance2 <- getUserBalance user2 + N.Whois{whoisPrice} <- fmap queryResultData . assertQuery . RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = N.Name satoshi } + let purchaseAmount = whoisPrice + 1 + newVal = "hello (again) world" + msg = N.BuyNameMsg + { buyNameBid = purchaseAmount + , buyNameName = satoshi + , buyNameValue = newVal + , buyNameBuyer = signerAddress user2 + } + claimedLog = N.NameClaimed + { nameClaimedOwner = signerAddress user2 + , nameClaimedName = satoshi + , nameClaimedValue = newVal + , nameClaimedBid = purchaseAmount + } + transferLog = B.TransferEvent + { transferEventAmount = purchaseAmount + , transferEventCoinId = N.nameserviceCoinId + , transferEventTo = signerAddress user1 + , transferEventFrom = signerAddress user2 + } + opts = TxOpts + { txOptsSigner = user2 + , txOptsGas = 0 + } + + -- Add event to be monitored and later checked for + addEventToCheck tenv transferLog + addEventToCheck tenv claimedLog + + resp <- assertTx . runTxClientM $ buyName opts msg + ensureResponseCodes (0,0) resp + [evtransferLog, evclaimedLog] <- deliverTxEvents (Proxy @N.NameClaimed) resp + fromEvent evtransferLog `shouldBe` Right transferLog + fromEvent evclaimedLog `shouldBe` Right claimedLog + + -- check for updated balances - seller: addr1, buyer: addr2 + sellerFoundAmount <- getUserBalance user1 + sellerFoundAmount `shouldBe` (balance1 + purchaseAmount) + buyerFoundAmount <- getUserBalance user2 + buyerFoundAmount `shouldBe` (balance2 - purchaseAmount) + + let expected = N.Whois + { whoisValue = "hello (again) world" + , whoisOwner = signerAddress user2 + , whoisPrice = purchaseAmount + } + foundWhois <- fmap queryResultData . assertQuery . RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = N.Name satoshi } + foundWhois `shouldBe` expected + + -- @NOTE: this is possibly a problem with the go application too + -- https://cosmos.network/docs/tutorial/buy-name.html#msg + it "Can buy self-owned names and make a profit " $ \tenv -> do + -- check balance before + beforeBuyAmount <- getUserBalance user2 + -- buy + let bid = 500 + val = "hello (again) world" + msg = N.BuyNameMsg + { buyNameBid = bid + , buyNameName = satoshi + , buyNameValue = val + , buyNameBuyer = signerAddress user2 + } + claimedLog = N.NameClaimed + { nameClaimedOwner = signerAddress user2 + , nameClaimedName = satoshi + , nameClaimedValue = val + , nameClaimedBid = bid + } + transferLog = B.TransferEvent + { transferEventAmount = bid + , transferEventCoinId = N.nameserviceCoinId + , transferEventTo = signerAddress user2 + , transferEventFrom = signerAddress user2 + } + opts = TxOpts + { txOptsSigner = user2 + , txOptsGas = 0 + } + + -- Add event to be monitored and later checked for + addEventToCheck tenv transferLog + addEventToCheck tenv claimedLog + + resp <- assertTx . runTxClientM $ buyName opts msg + ensureResponseCodes (0,0) resp + [evtransferLog, evclaimedLog] <- deliverTxEvents (Proxy @N.NameClaimed) resp + fromEvent evtransferLog `shouldBe` Right transferLog + fromEvent evclaimedLog `shouldBe` Right claimedLog + + -- check balance after + afterBuyAmount <- getUserBalance user2 + -- owner/buyer still profits + afterBuyAmount `shouldSatisfy` (> beforeBuyAmount) + + it "Can fail to buy a name" $ const $ do + -- try to buy at a lower price + let msg = N.BuyNameMsg + { buyNameBid = 100 + , buyNameName = satoshi + , buyNameValue = "hello (again) world" + , buyNameBuyer = signerAddress user1 + } + opts = TxOpts + { txOptsSigner = user1 + , txOptsGas = 0 + } + + resp <- assertTx . runTxClientM $ buyName opts msg + ensureResponseCodes (0,1) resp + + it "Can delete names" $ \tenv -> do + let msg = N.DeleteNameMsg + { deleteNameOwner = signerAddress user2 + , deleteNameName = satoshi + } + deletedLog = N.NameDeleted + { nameDeletedName = satoshi + } + + opts = TxOpts + { txOptsSigner = user2 + , txOptsGas = 0 + } + + -- Add event to be monitored and later checked for + addEventToCheck tenv deletedLog + + resp <- assertTx . runTxClientM $ deleteName opts msg + ensureResponseCodes (0,0) resp + [evdeletedLog] <- deliverTxEvents (Proxy @N.NameDeleted) resp + fromEvent evdeletedLog `shouldBe` Right deletedLog + + respQ <- RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = N.Name satoshi } + ensureQueryResponseCode 2 respQ + + + it "Can fail a transfer" $ const $ do + addr2Balance <- getUserBalance user2 + let tooMuchToTransfer = addr2Balance + 1 + msg = B.TransferMsg + { transferFrom = signerAddress user2 + , transferTo = signerAddress user1 + , transferCoinId = N.nameserviceCoinId + , transferAmount = tooMuchToTransfer + } + opts = TxOpts + { txOptsSigner = user2 + , txOptsGas = 0 + } + + resp <- assertTx . runTxClientM $ transfer opts msg + ensureResponseCodes (0,1) resp + + it "Can transfer" $ \tenv -> do + balance1 <- getUserBalance user1 + balance2 <- getUserBalance user2 + let transferAmount = 1 + msg = + B.TransferMsg + { transferFrom = signerAddress user1 + , transferTo = signerAddress user2 + , transferCoinId = N.nameserviceCoinId + , transferAmount = transferAmount + } + transferLog = B.TransferEvent + { transferEventAmount = transferAmount + , transferEventCoinId = N.nameserviceCoinId + , transferEventTo = signerAddress user2 + , transferEventFrom = signerAddress user1 + } + opts = TxOpts + { txOptsSigner = user1 + , txOptsGas = 0 + } + + -- Add event to be monitored and later checked for + addEventToCheck tenv transferLog + + resp <- assertTx . runTxClientM $ transfer opts msg + ensureResponseCodes (0,0) resp + [evtransferLog] <- deliverTxEvents (Proxy @B.TransferEvent) resp + fromEvent evtransferLog `shouldBe` Right transferLog + + -- check balances + balance1' <- getUserBalance user1 + balance1' `shouldBe` balance1 - transferAmount + balance2' <- getUserBalance user2 + balance2' `shouldBe` balance2 + transferAmount + + it "Can monitor all events" $ \(TestEnv mvex mvres _) -> do + expected <- readMVar mvex + res <- readMVar mvres + fromList (map A.toJSON expected) `shouldBe` fromList (map A.toJSON res) + + +faucetUser + :: Auth.Amount + -> Signer + -> IO () +faucetUser amount s@(Signer addr _) = + void . assertTx .runTxClientM $ + let msg = N.FaucetAccountMsg addr N.nameserviceCoinId amount + opts = TxOpts + { txOptsGas = 0 + , txOptsSigner = s + } + in faucet opts msg + +getUserBalance + :: Signer + -> IO Auth.Amount +getUserBalance usr = fmap (Auth.coinAmount . queryResultData) . assertQuery . RPC.runTendermintM rpcConfig $ + let queryArgs = defaultQueryArgs { queryArgsData = signerAddress usr } + in getBalance queryArgs N.nameserviceCoinId + +-------------------------------------------------------------------------------- + +user1 :: Signer +user1 = makeSignerFromUser $ + makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" + +user2 :: Signer +user2 = makeSignerFromUser $ + makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" + +-------------------------------------------------------------------------------- +-- Query Client +-------------------------------------------------------------------------------- + +getAccount + :: QueryArgs Address + -> RPC.TendermintM (QueryClientResponse Auth.Account) + +getWhois + :: QueryArgs N.Name + -> RPC.TendermintM (QueryClientResponse N.Whois) + +getBalance + :: QueryArgs Address + -> Auth.CoinId + -> RPC.TendermintM (QueryClientResponse Auth.Coin) + +getWhois :<|> getBalance :<|> getAccount = + genClientQ (Proxy :: Proxy m) queryApiP def + where + queryApiP :: Proxy (M.ApplicationQ NameserviceModules) + queryApiP = Proxy + + +-------------------------------------------------------------------------------- +-- Tx Client +-------------------------------------------------------------------------------- + +txClientConfig :: ClientConfig +txClientConfig = + let getNonce addr = do + resp <- RPC.runTendermintM rpcConfig $ getAccount $ + QueryArgs + { queryArgsHeight = -1 + , queryArgsProve = False + , queryArgsData = addr + } + -- @NOTE: TxNonce should be +1 of accountNonce + case resp of + QueryError e -> + if appErrorCode e == 2 + then pure 1 + else error $ "Unknown nonce error: " <> show (appErrorMessage e) + QueryResponse QueryResult {queryResultData} -> + pure $ 1 + Auth.accountNonce queryResultData + + in ClientConfig + { clientGetNonce = getNonce + , clientRPC = rpcConfig + } + +type TxClientM = ReaderT ClientConfig IO + +runTxClientM :: TxClientM a -> IO a +runTxClientM m = runReaderT m txClientConfig + + +-- Nameservice Client +buyName + :: TxOpts + -> N.BuyNameMsg + -> TxClientM (TxClientResponse () ()) + +setName + :: TxOpts + -> N.SetNameMsg + -> TxClientM (TxClientResponse () ()) + +deleteName + :: TxOpts + -> N.DeleteNameMsg + -> TxClientM (TxClientResponse () ()) + +-- Bank Client +transfer + :: TxOpts + -> B.TransferMsg + -> TxClientM (TxClientResponse () ()) + +faucet + :: TxOpts + -> N.FaucetAccountMsg + -> TxClientM (TxClientResponse () ()) + +(buyName :<|> setName :<|> deleteName :<|> faucet) :<|> + (_ :<|> transfer) :<|> + EmptyTxClient = + genClientT (Proxy @TxClientM) txApiCP txApiDP defaultClientTxOpts + where + txApiCP :: Proxy (M.ApplicationC NameserviceModules) + txApiCP = Proxy + txApiDP :: Proxy (M.ApplicationD NameserviceModules) + txApiDP = Proxy + +-- Test Init +data TestEnv = TestEnv (MVar [FT.Event]) (MVar [FT.Event]) (MVar [Text]) + +testInit :: Auth.Amount -> IO TestEnv +testInit faucetAmount = do + forM_ [user1, user2] $ faucetUser faucetAmount + TestEnv <$> newMVar [] <*> newMVar [] <*> newMVar [] + + +addEventToCheck :: ToEvent a => TestEnv -> a -> IO () +addEventToCheck (TestEnv mvexpected mvseen mveventTypes) ev = do + let appEv = toEvent ev + modifyMVar_ mvexpected $ pure . (appEv :) + ses <- readMVar mveventTypes + let evType = FT.eventType appEv + if evType`elem` ses + then pure () + else do + _ <- startNewListener evType + modifyMVar_ mveventTypes $ pure . (evType :) + where + startNewListener evType = + let subReq = RPC.RequestSubscribe ("tm.event = 'Tx' AND " <> evType <> " EXISTS") + eventStorer = awaitForever $ \as -> + liftIO $ modifyMVar_ mvseen $ \es -> pure $ + RPC.txEventEvents as <> es + forkTendermintM = forkIO . RPC.runTendermintM rpcConfig . runResourceT . runConduit + in forkTendermintM $ RPC.subscribe subReq .| eventStorer diff --git a/hs-abci-docs/nameservice/test/Nameservice/Test/EventOrphans.hs b/hs-abci-docs/nameservice/test/Nameservice/Test/EventOrphans.hs new file mode 100644 index 00000000..a410fc6a --- /dev/null +++ b/hs-abci-docs/nameservice/test/Nameservice/Test/EventOrphans.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Nameservice.Test.EventOrphans where + +import Nameservice.Modules.Nameservice (Faucetted, NameClaimed, + NameDeleted, NameRemapped) +import Tendermint.SDK.Modules.Bank (TransferEvent) +import qualified Tendermint.Utils.Events as Event + +-- Orphan instances for retrieving event logs for unit testing + +instance Event.FromEvent NameClaimed +instance Event.FromEvent NameRemapped +instance Event.FromEvent NameDeleted +instance Event.FromEvent Faucetted +instance Event.FromEvent TransferEvent diff --git a/hs-abci-examples/simple-storage/test/Spec.hs b/hs-abci-docs/nameservice/test/Spec.hs similarity index 100% rename from hs-abci-examples/simple-storage/test/Spec.hs rename to hs-abci-docs/nameservice/test/Spec.hs diff --git a/hs-abci-docs/nameservice/tutorial/Foundations/01-Overview.md b/hs-abci-docs/nameservice/tutorial/Foundations/01-Overview.md new file mode 100644 index 00000000..a009653c --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Foundations/01-Overview.md @@ -0,0 +1,25 @@ +--- +title: Foundations - Overview +--- + +# Overview + +The SDK relies heavily on two abstractions to facilitate application development, effects systems and Modules. + +## Effects Systems + +The effects system is backed by a library called `polysemy` which we mentioned in the introduction. An application basically has three layers of effects + +1. **Application level effects**: These are introduced by the application developer in order to customize application behavior. Examples include things like `AuthEffs` from `Tendermint.SDK.Modules.Auth` that allow for manipulating accounts and throwing custom `Auth` errors. +2. **Transaction effects**: These are the effects that allow you to interpret transactions, emit events, meter gas, and handle storage requests. +3. **Base effects**: These include things like logging, metrics, exception handling, and some error handling. +4. **Store effects**: These are the effects that describe the possible interactions with an abstract merkelized key-value database. +5. **Core effects**: These are largely internal and used to interpet the other effects to `IO`. There are a two different core options available in the SDK (distinguished by a an in-memory versus production database), but the more advanced developer might wish to write their own. + +The tutorial explains the multiple points at which you can hook your application specific effects and types into the SDK. + +## Modules + +The core building block of an application is a `Module`. There are some modules that ship with the SDK and make up a kind of standard library. These modules are of general utility, like dealing with things like authentication or coins, and are considered to be safe. + +The most useful part of the SDK is that you are free to define your own modules, or depend on other third party modules outside the SDK. Since they all have the same type, they all easily compose into larger applications as standalone components or dependencies. diff --git a/hs-abci-docs/nameservice/tutorial/Foundations/02-Effects.md b/hs-abci-docs/nameservice/tutorial/Foundations/02-Effects.md new file mode 100644 index 00000000..c7cc47ef --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Foundations/02-Effects.md @@ -0,0 +1,109 @@ +--- +title: Foundations - Effects +--- + +# Effects Lists + +There are several distinguished effects lists you should be familiar with that come up at different parts of the sdk or application development. They are often combined or stacked using the `:&` operator, which is simply concatenation of type level lists. + + +## BaseEffs + +`BaseEffs` is a set of effects that the SDK operates with and are freely available +for an application developer to make use of in any part of their application code. They +are defined as: + +~~~ haskell ignore +type BaseEffs = + [ Metrics + , Logger + , Resource + , Error AppError + ] +~~~ + +These effects are: + +1. `Metrics` - creates and manages custom counters and timers. +2. `Logger` - allows for structured logging with log levels. +3. `Resource` - allows for bracketing and resource management in the presence of exeptions. +4. `Error AppError` -- allows for errors of type `AppError` to be thrown or caught. + +The SDK does not make any assumptions about how `BaseEffs` will be interpreted at runtime, it only assumes that the developer might want use one of the provided core effects systems to interpret them. For example, the standard `CoreEffs` uses a prometheus metrics server to interpret the `Metrics` effect while `PureCoreEffs` just ignores the effect entirely. + +## TxEffs + +`TxEffs` are the effects used to interpret transactions and are defined as + +~~~ haskell ignore +type TxEffs = + [ Output Event + , GasMeter + , WriteStore + , ReadStore + , Error AppError + ] +~~~ + +where + +1. `Output Event` - allows for emitting events during transaction execution. +2. `GasMeter` - allows for gas costs to be levied at any place during transaction code. +3. `WriteStore` - allows for put/delete operations on the database. +4. `ReadStore` - allows for get/prove operations on the database. +5. `Error AppError` - allows for throwing and catching errors raised during transactions. + +`TxEffs` effects are available any time during transactions and are interpreted at the time of transaction routing. It's worth noting that the interpreters take care of finalizing writes to the database when it's appropriate (i.e. during a `deliverTx` message) and not otherwise (e.g. during a `checkTx` message). + +## QueryEffs + +`QueryEffs` are used to interpret queries and are defined as + +~~~ haskell ignore +type QueryEffs = + [ ReadStore + , Error AppError + ] +~~~ + +where + +1. `ReadStore` allows for get/prove operations on the database. +2. `Error AppError` allows for throwing/catching errors when performing database queries. + +`QueryEffs` are available any time you are writing handlers for a module's query api. The SDK manages a separate connection for reading from committed (i.e. via blocks) state when `QueryEffs` are present. + +## StoreEffs + +`StoreEffs` describe the possible interactions with an abstract merkelized key-value database: + +~~~ haskell ignore +type StoreEffs = + [ Tagged 'Consensus ReadStore + , Tagged 'QueryAndMempool ReadStore + , Tagged 'Consensus WriteStore + , Transaction + , CommitBlock + ] +~~~ + + They are used to interpret `TxEffects` depending on what context you're in, e.g. while executing a `delierTx` versus `checkTx` message, or a `query`. Some effects are tagged with a promoted value of type `Scope`, i.e. `'Consensus` and `'QueryAndMempool`. This is because your application will keep multiple connections to the database that are used in different situations. For example, since writing to the state at a previous blocktimes is impossible, we disallow writing to the database in such instances. + + +# Effects Type Synonyms + +There are a few effects lists that appear so frequently at different points in the SDK that they deserve synonyms: + +## Effs + +`Effs` is technically a type family coming from the class `Tendermint.SDK.Application.Module.Eval`. It is used to enumerate all the effects that would be needed in order to run an application defined by a `ModuleList`. + +## BaseAppEffs + +There is a type alias in the SDK called `BaseAppEffs` with the definition + +~~~ haskell ignore +type BaseApp core = BaseEffs :& StoreEffs :& core +~~~ + +It sits at the bottom of any applications effects list and ultimately everything is interpreted through these effects before being run, e.g. `TxEffs` and `QueryEffs`. This effects list is pretty much the only place where the application developer needs to decide how the interpretation should be done. There are two options in the SDK, using `PureCoreEffs` or `CoreEffs` depending on whether you want to rely on an external or in-memory database. \ No newline at end of file diff --git a/hs-abci-docs/nameservice/tutorial/Foundations/03-Modules.md b/hs-abci-docs/nameservice/tutorial/Foundations/03-Modules.md new file mode 100644 index 00000000..a64065ab --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Foundations/03-Modules.md @@ -0,0 +1,67 @@ +--- +title: Foundations - Module +--- + +# Modules and Components + +First a note. There is a small technical distinction betweek a `Module` and a `Component`, but we often use these words interchangable. A `Component` is simply a type synonym for a partially applied `Module`, which leaves the `r` parameter free. It's basically the type level description of a `Module` that hasn't yet been put in the context of a larger application, which is where the `r` comes in. + +## Definition + +A `Module` has a very specific meaning in the context of this SDK. A `Module` is something between a library and a small state machine. Here is the type: + +~~~ haskell ignore +data Module (name :: Symbol) (check :: *) (deliver :: *) (query :: *) (es :: EffectRow) (deps :: [Component]) (r :: EffectRow) = Module + { moduleTxChecker :: T.RouteTx check r + , moduleTxDeliverer :: T.RouteTx deliver r + , moduleQuerier :: Q.RouteQ query r + , moduleEval :: forall s. (Members T.TxEffs s, Members (DependencyEffs deps) s) => forall a. Sem (es :& s) a -> Sem s a + } + +~~~ + +where `DependencyEffs` is a type level function that gathers effect dependencies from a list of `Component`s that the module depends on: + +~~~ haskell ignore + +type family DependencyEffs (ms :: [Component]) :: EffectRow where + DependencyEffs '[] = '[] + DependencyEffs (Module _ _ _ _ es deps ': rest) = es :& DependencyEffs rest + DependencyEffs _ = TypeError ('Text "DependencyEffs is a partial function defined only on partially applied Modules") + +~~~ + +Let's take a look at the type parameters + +- `name` is the name of the module, e.g. `"bank"`. +- `check` is the transaction router api type for `checkTx` messages. +- `deliver` is the transaction router api type for `checkTx` messages. +- `query` is the query router api type for `query` messages +- `es` is the set of effects introduced by this module. +- `deps` is the list of `Components` (i.e. Modules) that this module depends on, in the sense that the `eval` function for this module will interpret into those effects. (For example, the `BankEffs` for the `Bank` module are interpreted into `AuthEffs`) +- `r` is the global set of effects that this module will run in when part of a larger application (more on this later). + +Below that line we see the fields for the `Module` data type, where + + - `moduleTxDeliverer` specifies how the module processes transactions in order to update the application state during `deliverTx` messages. + - `moduleTxChecker` is used during `checkTx` messages to check if a transaction in the mempool is a valid transaction. + - `moduleQuerier` is responsible for handling queries for application state from the `query` message. + - `moduleEval` is the natural transformation that specifies how to interpet the `Module` in terms of `BaseApp`. + +If you have ever used the `servant` library for specifying rest apis, then the type families `T.RouteTx` and `Q.RouteQ` may look familiar to you, they play a similar role as `ServerT`. + +Note that in the event that a `Module` is _abstract_, meaning it doesn't have any messages to respond to, then we have `msg ~ Void`. + +## Composition + +`Module`s are meant to be composed to create larger applications. We will see examples of this with the `Nameservice` application. The way to do this is easy, as the `ModuleList` data type allows you to simply combine them in a heterogeneous list: + +~~~ haskell ignore +data ModuleList (ms :: [Component]) r where + NilModules :: Modules '[] r + (:+) :: Module name check deliver query es r + -> Modules ms r + -> Modules (Module name check deliver query es ': ms) r +~~~ + +When you are ready to create your application, you simply specify a value of type `ModuleList` and some other configuration data, and the SDK will create an `App` for you. diff --git a/hs-abci-docs/nameservice/tutorial/Foundations/04-Storage.md b/hs-abci-docs/nameservice/tutorial/Foundations/04-Storage.md new file mode 100644 index 00000000..26f1321c --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Foundations/04-Storage.md @@ -0,0 +1,77 @@ +--- +title: Foundations - Storage +--- + +# Database + +ABCI applications depend on some kind of merkelized storage in order to achieve consensus on a valid application state. The SDK has two database options to interpret `StoreEffs`, an in-memory [avl-auth](https://github.com/oscoin/avl-auth) option as well as a persisted [iavl](https://github.com/tendermint/iavl) option. + +# Stores + +The most convenient way to partition a key-value store is by heavy use of prefixes -- for example, if you want to separate each module's keyspace, you can use prefix all of the keys that it manages by the module's unique name. If you want to partition storage within a module, say for a list or mapping, you can again use prefixes to create a unique keyspace. + +The definition of a `Store` is a unique keyspace. Implementation wise, it is effectively a list of prefixes to concatenate when creating keys. There are currently 6 ways of creating Stores: + +1. From a `KeyRoot`, which basically defines a top level Store. +2. Using the `nestStore` function to mount one Store in another. +3. By creating a `Var`, which creates a keyspace with exactly one key. +4. By creating an `Array`, which creates a keyspace whose keys are type `Word64`. +5. By creating a `Map k v`, which creates a keyspace whose keys are type `k`. +6. By creating a `List`, which creates a linked list whose keyspace is internal. + + +Because a Store is a unique keyspace, it allows us to build a typed key-value storage on top of the raw ByteString interface. This is achieved by adding a phantom namespace type to the Store type and declaring an instance of the `IsKey` class: + + +~~~ haskell ignore +data Store ns = Store + { storePathFromRoot :: [ByteString] + } + +class RawKey k where + rawKey :: Iso' k BS.ByteString + +class RawKey k => IsKey k ns where + type Value k ns :: * +~~~ + +# Example + +Let's take the example of the `Auth` module which is responsible for maintaining a mapping `Address -> Account`. To declare the mapping, we first need to make a namespace and a root storage for the module: + +~~~ haskell ignore +data AuthNamespace + +store :: Store AuthNamespace +store = makeStore $ KeyRoot "auth" +~~~ + + +We then need to make a new keyspace for our accounts mapping, which looks like + +~~~ haskell ignore +data AccountsMapKey = AccountsMapKey + +instance RawKey AccountsMapKey where + rawKey = iso (const "accounts") (const AccountsMapKey) + +instance IsKey AccountsMapKey AuthNamespace where + type Value AccountsMapKey AuthNamespace = Map Address Account +~~~ + +This tells the compiler that the `AccountsMapKey` key type can only be used to access the mapping `Map Address Account`, it cannot be used to query any other types. + +We can then declare the mapping itself like + +~~~ haskell ignore +accountsMap :: Map Address Account +accountsMap = makeMap AccountsMapKey store +~~~ + +This both creates the mapping and mounts it inside of our module level store. The effect of this is that if you wanted to query the underlying raw key-value store for the account associated to the address `0xdeadbeef`, then the actual key looks something like + +~~~ haskell ignore +encodeUtf8 "auth" <> encodeUtf8 "accounts" <> bytesFromHex "0xdeafbeef" +~~~ + +While writing apps inside the SDK you do not need to worry about the explicit prefixing since everything is taken care of for you. However, if you are querying for state via an ABCI `query` message, the `key` field that is returned in the response will contain this full path. In the above example, if you wanted to recover the address from the key, you would need to know the prefixes that were applied. diff --git a/hs-abci-docs/nameservice/tutorial/README.lhs b/hs-abci-docs/nameservice/tutorial/README.lhs new file mode 120000 index 00000000..42061c01 --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/README.lhs @@ -0,0 +1 @@ +README.md \ No newline at end of file diff --git a/hs-abci-docs/nameservice/tutorial/README.md b/hs-abci-docs/nameservice/tutorial/README.md new file mode 100644 index 00000000..08030f1e --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/README.md @@ -0,0 +1,58 @@ +--- +title: Tutorial +--- + +## Introduction + +We're going to build an example application that mirrors the `golang` [cosmos-sdk](https://github.com/cosmos/cosmos-sdk) example application called [Nameservice](https://github.com/cosmos/sdk-tutorials/tree/master/nameservice). There is also a tutorial for that application which you can find [here](https://tutorials.cosmos.network/nameservice/tutorial/00-intro.html) for comparison. + +## Application Specification +The Nameservice application is a simple marketplace for a name resolution service. Let us say that a `Name` resolves to type called `Whois` where + +~~~ haskell ignore +data Whois = Whois + { whoisValue :: Text + , whoisOwner :: Address + , whoisPrice :: Amount + } +~~~ + +This means that users can buy and sell entries in a shared mapping of type `Name -> Whois` where: +1. An unclaimed `Name` can be bought by a user and set to an arbitrary value. +2. Existing `(Name, Whois)` pairs can be updated by their owner or sold to a new owner for the price. +3. Existing `(Name, Whois)` pairs can be deleted by their owner and the owner receives a refund for the purchase price. + +The application consists of three modules: +1. `Auth` - Manages accounts for users, things like nonces and token balances. +2. `Token` - Allows users manage their tokens, things like transfering or burning. +3. `Nameservice` - Controls the shared `Name -> Value` mapping described above. + +## How to Read this Tutorial + +First a warning. The `hs-abci-sdk` package is a sophisticated *framework* for building blockchain applications backed by tendermint consensus. As it is a framework, there are certain points when syntax is simplified at the expense of introducing indirection, type synonyms, and a few type families. There was a serious amount of effort to expose as little of this as possible, but alas sometimes things will be confusing and it's best to blindly follow the examples. + +This tutorial is largely written as a literate haskell file to simulate developing the Nameservice app from scratch. The file structure is similar to the actual app. We will partially develop a haskell module corresponding to what you find in the app, but possibly not the whole thing. Thus whenever we depend on a haskell module in the tutorial, rather than importing from the tutorial itself we will import from the app. + +The benefit of this is that we don't have to develop the entire application in this tutorial. Any breaking changes in the app will (hopefully) break the tutorial and so if you can read this, the tutorial is correct. + +## Tutorial Goals +The goal of this tutorial is to explain how the Nameservice app is constructed using the `hs-abci-sdk` package. Nameservice is a relatively simple but still non-trivial application. +If you would like to start with something simpler, you can view the tutorial for the [simple-storage](https://github.com/f-o-a-m/kepler/tree/master/hs-abci-docs/simple-storage) example application. + +This tutorial should teach you: +1. How to construct application specific modules. +2. How to enable a module to receive application specific transactions. +3. How to compose modules and wire up an application. +4. How to add event logging, console logging, and other effects to module. +4. How to use the type system to control the capabilities of a module. + +The SDK makes heavy use of the effects system brought to haskell by the [polysemy](https://hackage.haskell.org/package/polysemy-1.2.3.0) library. We're not going to explain how this library works here, there are several existing tutorials that do this already. Suffice it to say that polysemy encourages the application developer to develop modules that have well defined roles and scopes, and to prohibit certain modules from interfering with the roles and scopes of other modules unless explicitly allowed by the type system. + +It is also allows the application developer to construct modules without much regard for how they will plug into the SDK, leaving that job to the SDK itself. + + diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/01-Overview.md b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/01-Overview.md new file mode 100644 index 00000000..37a31aaa --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/01-Overview.md @@ -0,0 +1,29 @@ +--- +title: Nameservice - Overview +--- + +# Overview + +This section is where we sketch the definition of the Nameservice module and application. It's to everyones benefit if module structures follow a similar file heirachy as the Nameservice module, or any module found in the SDK. In the case of Nameservice this roughly translates to + +``` +├── Nameservice +  │   ├── Keeper.hs +  │   ├── Messages.hs +  │   ├── Query.hs +  │   ├── Router.hs +  │   └── Types.hs +  ├── Nameservice.hs + +``` + +The contents of these modules are roughly as follows: + +- `Nameservice.Types` - Core types and instances for the module, including events, custom errors, database types. +- `Nameservice.Keeper` - Defines the module's effect system, it's database operations (if any), core utility. +- `Nameservice.Message` - Defines the message types that the module must process (if any) and their validation instances. +- `Nameservice.Query` - Defines the query server for handling state queries from clients. +- `Nameservice.Router` - Defines the transaction router for the module. +- `Namervice` Defines the module itself and re-exports any types or utils necessary for using this module as a dependency. + +The reason why we suggest this is that each of these haskell modules is buiding up one of the core components of our defition of a module, and it provides a nice logical split between these pieces. diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/02-Types.md b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/02-Types.md new file mode 100644 index 00000000..54c9f31f --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/02-Types.md @@ -0,0 +1,255 @@ +--- +title: Nameservice - Types +--- + +# Types + +The `Types` module is used to define the basic types that the module will make use of. This includes things like custom error types, event types, database types, etc. + +## Using A Typed Key Value Store +It is important to note that the database modeled by the `RawStore` effect (in the `BaseApp` type) is just a key value store for raw `ByteString`s. This means you can _think_ of `RawStore` as + +~~~ haskell ignore +type RawStore = Map ByteString ByteString +~~~ + +although the definition of `RawStore` is different than the above. + +The interface we give is actually a typed key value store. This means that within the scope of a module `m`, for any key type `k`, there is only one possible value type `v` associated with `k`. + +For example, a user's balance in the `Bank` module, might be modeled by a mapping + +~~~ haskell ignore +balance :: Tendermint.SDK.Types.Address -> Integer +~~~ + +(We'll properly introduce the module `Bank` later in the walkthrough.) + +This means that in the scope of the `Bank` module, the database utlity `get` function applied to a value of type `Address` will result in a value of type `Integer`. If the `Bank` module would like to store another mapping whose keys have type `Tendermint.SDK.Types.Address`, you must use a newtype instead. Otherwise you will get a compiler error. + +At the same time, you are free to define another mapping from `k -> v'` in the scope of a different module. For example, you can have both the `balance` mapping described above, as well a mapping + +~~~ haskell ignore +owner :: Tendermint.SDK.Types.Address -> Account +~~~ +in the `Auth` module. + +## Tutorial.Nameservice.Types + +Let's look at the example in `Nameservice.Types`. + +~~~ haskell +module Tutorial.Nameservice.Types where + +import Control.Lens (iso) +import qualified Data.Aeson as A +import Data.Bifunctor (bimap) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Nameservice.Aeson (defaultNameserviceOptions) +import Proto3.Suite (Message, fromByteString, toLazyByteString) +import qualified Tendermint.SDK.BaseApp as BA +import Tendermint.SDK.Codec (HasCodec(..)) +import Tendermint.SDK.Types.Address (Address) +import Tendermint.SDK.Modules.Auth (Amount (..)) +import Tendermint.SDK.Modules.Bank () +~~~ + +### Storage types + +Remember the `Nameservice` module is responsible for maintaining a marketplace around a mapping `Name -> Whois`. Let us define the types for the marketplace mapping as + +~~~ haskell +newtype Name = Name Text deriving (Eq, Show, Generic, A.ToJSON, A.FromJSON, HasCodec) + +data Whois = Whois + { whoisValue :: Text + , whoisOwner :: Address + , whoisPrice :: Amount + } deriving (Eq, Show) +~~~ + +The way that we register `Name` as a key in the store is by using the `RawKey` typeclass + +~~~ haskell ignore +class RawKey k where + rawKey :: Iso' k ByteString +~~~ + +This class gives us a way to convert back and forth from a key to its encoding as a `ByteString`. In our case we implement + +~~~ haskell +-- here cs resolves to Data.Text.Encoding.encodeUtf8, Data.Text.Encoding.decodeUtf8 respectively +instance BA.RawKey Name where + rawKey = iso (\(Name n) -> cs n) (Name . cs) +~~~ + +In order to register `Whois` as a storage type, we must implement the `HasCodec` typeclass + +~~~ haskell ignore +class HasCodec a where + encode :: a -> ByteString + decode :: ByteString -> Either Text a +~~~ + +This class is used everywhere in the SDK as the binary codec class for things like storage items, messages, transaction formats etc. It's agnostic to the actual serialization format, you can use `JSON`, `CBOR`, `Protobuf`, etc. Throughout the SDK we typically use `protobuf` as it is powerful in addition to the fact that there's decent support for this in Haskell either through the `proto3-suite` package or the `proto-lens` package. + +So we can implement a `HasCodec` instance for `Whois` via the `WhoisMessage` type: + +~~~ haskell +-- Message is a class from proto3-suite that defines protobuf codecs generically. +data WhoisMessage = WhoisMessage + { whoisMessageValue :: Text + , whoisMessageOwner :: Address + , whoisMessagePrice :: Word64 + } deriving (Eq, Show, Generic) +instance Message WhoisMessage + +instance HasCodec Whois where + encode Whois {..} = + let whoisMessage = WhoisMessage + { whoisMessageValue = whoisValue + , whoisMessageOwner = whoisOwner + , whoisMessagePrice = unAmount whoisPrice + } + in cs . toLazyByteString $ whoisMessage + decode = + let toWhois WhoisMessage {..} = Whois + { whoisValue = whoisMessageValue + , whoisOwner = whoisMessageOwner + , whoisPrice = Amount whoisMessagePrice + } + in bimap (cs . show) toWhois . fromByteString @WhoisMessage +~~~ + +Finally we can register `(Name, Whois)` with the module's store with the `IsKey` class, which tells how to associate a key type with a value type within the scope of given module, where the scope is represented by the modules name as a type level string. There is an optional prefixing function for the key in this context in order to avoid collisions in the database. This would be useful for example if you were using multiple newtyped `Address` types as keys in the same module. + +~~~ haskell ignore +class RawKey k => IsKey k ns where + type Value k ns = a | a -> ns k + prefixWith :: Proxy k -> Proxy ns -> BS.ByteString + + default prefixWith :: Proxy k -> Proxy ns -> BS.ByteString + prefixWith _ _ = "" +~~~ + +For the case of the `Name -> Whois` mapping, the `IsKey` instance looked like looks like this: + +~~~ haskell +data NameserviceNamespace + +instance BA.IsKey Name NameserviceNamespace where + type Value Name NameserviceNamespace = Whois +~~~ + +At is point, you can use the database operations exported by `Tendermint.SDK.BaseApp.Store` such as `put`/`set`/`delete` for key value pairs of type `(Name, Whois)`. + +### Query Types + +The [`cosmos-sdk`](https://github.com/cosmos/cosmos-sdk) assumes that you use `url` formatted queries with some possible query params. For example, to query a `Whois` value based on a `Name`, you might submit a `query` message with the route `nameservice/whois` and supply a value of type `Name` to specify as the `data` field. Our SDK makes the same assumption for compatability reasons. + +### Error Types + +You might want to define a module specific error type that has a `throw`/`catch` interface. This error type should be accessible by any other dependent modules, and any uncaught error should eventually be converted into some kind of generic application error understandable by Tendermint. + +There is a simple way to do this using the `IsAppError` typeclass + +~~~ haskell ignore +data AppError = AppError + { appErrorCode :: Word32 + , appErrorCodespace :: Text + , appErrorMessage :: Text + } deriving Show + +class IsAppError e where + makeAppError :: e -> AppError +~~~ + +The fields for `AppError` correspond to tendermint message fields for messages that support error return types, such as `checkTx`, `deliverTx`, and `query`. Typically we use the module name as the codespace, like in the definition of `NameserviceError`: + +~~~ haskell +data NameserviceError = + InsufficientBid Text + | UnauthorizedSet Text + | InvalidDelete Text + +instance BA.IsAppError NameserviceError where + -- remember 'symbolVal (Proxy @NameserviceName)' resolves to "nameservice" + makeAppError (InsufficientBid msg) = + BA.AppError + { appErrorCode = 1 + , appErrorCodespace = "nameservice" + , appErrorMessage = msg + } + makeAppError (UnauthorizedSet msg) = + BA.AppError + { appErrorCode = 2 + , appErrorCodespace = "nameservice" + , appErrorMessage = msg + } + makeAppError (InvalidDelete msg) = + BA.AppError + { appErrorCode = 3 + , appErrorCodespace = "nameservice" + , appErrorMessage = msg + } +~~~ + +### Event Types +Tendermint has the capability to report event logs for transactions in the responses for both `checkTx` and `deliverTx` messages. The basic event type can be found in `Network.ABCI.Types.MessageFields`, it is simply a named key value mapping between `Bytestring`s: + +~~~ haskell ignore +data Event = Event + { eventType :: Text + -- ^ Type of Event + , eventAttributes :: [KVPair] + -- ^ Event attributes + } + +data KVPair = KVPair + { kVPairKey :: Base64String + -- ^ key + , kVPairValue :: Base64String + -- ^ value + } +~~~ + +Similar to the custom error messages, you can define custom events at the module level as long as they implement the `ToEvent` class to translate them to this standard type: + +~~~ haskell ignore +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 +~~~ + +As you can see, there is a default instance for those types which have a `JSON` representation as an `Object`. The reason that we chose a `JSON` default instance is simply because of support for generics, but this isn't set in stone. + +In the case of `Nameservice`, here is an example of a custom event: + +~~~ haskell +data NameClaimed = NameClaimed + { nameClaimedOwner :: Address + , nameClaimedName :: Name + , nameClaimedValue :: Text + , nameClaimedBid :: Amount + } deriving (Eq, Show, Generic) + +-- 'defaultNameserviceOptions' is used to remove the record accessor prefix. +nameClaimedAesonOptions :: A.Options +nameClaimedAesonOptions = defaultNameserviceOptions "nameClaimed" + +instance A.ToJSON NameClaimed where + toJSON = A.genericToJSON nameClaimedAesonOptions + +instance A.FromJSON NameClaimed where + parseJSON = A.genericParseJSON nameClaimedAesonOptions + +instance BA.ToEvent NameClaimed +~~~ diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/03-Message.md b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/03-Message.md new file mode 100644 index 00000000..3cb61e04 --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/03-Message.md @@ -0,0 +1,199 @@ +--- +title: Nameservice - Message +--- + +# Message + +## Message Types + +Each module is ultimately a small state machine used for processing messages. Each module must define what messages it accepts, if any. Like many other types found in the SDK, this message class must implement the `HasCodec` class. We recommend using a protobuf serialization format for messages using either the `proto3-suite` or `proto-lens` libraries, though in theory you could use anything (e.g. `JSON`). + +### `proto3-suite` +The advantages of using the `proto3-suite` library are that it has support for generics and that you can generate a `.proto` file from your haskell code for export to other applications. This is particularly useful when prototyping or when you have control over the message specification. +The disadvantage is that `proto3-suite` doesn't act as a `protoc` plugin, and instead uses it's own protobuf parser. This means that you do not have access to the full protobuf specs when parsing `.proto` files. + +### `proto-lens` +The advantages of using `proto-lens` are that it can parse and generate types for pretty much any `.proto` file. +The disadvantage is that the generated code is a bit strange, and may require you to create wrapper types to avoid depending directly on the generated code. An additional disadvantage is that you cannot generate `.proto` files from haskell code. + +All in all, neither is really difficult to work with, and depending on what stage you're at in development you might chose one over the other. + +## Tutorial.Nameservice.Message + +~~~ haskell +module Tutorial.Nameservice.Message where + +import Data.Bifunctor (bimap, first) +import Data.Foldable (sequenceA_) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Nameservice.Modules.Nameservice.Types +import Proto3.Suite (Named, Message, fromByteString, toLazyByteString) +import Tendermint.SDK.Types.Address (Address) +import Tendermint.SDK.Types.Message (Msg(..), ValidateMessage(..), HasMessageType(..), + isAuthorCheck, nonEmptyCheck, + coerceProto3Error, formatMessageParseError) +import Tendermint.SDK.Modules.Auth (Amount (..)) +import Tendermint.SDK.Modules.Bank () +import Tendermint.SDK.Codec (HasCodec(..)) +~~~ + +### Message Definitions + +For the puroposes of the tutorial, we will use the `proto3-suite` for the message codecs. For `BuyName`, an intermediary datatype, `BuyNameMessage` is used to support encoding for `Amount`: + + +~~~ haskell +data SetNameMsg = SetNameMsg + { setNameName :: Text + , setNameOwner :: Address + , setNameValue :: Text + } deriving (Eq, Show, Generic) + +instance Message SetNameMsg +instance Named SetNameMsg + +instance HasCodec SetNameMsg where + encode = cs . toLazyByteString + decode = first (formatMessageParseError . coerceProto3Error) . fromByteString + +data DeleteNameMsg = DeleteNameMsg + { deleteNameOwner :: Address + , deleteNameName :: Text + } deriving (Eq, Show, Generic) + +instance Message DeleteNameMsg +instance Named DeleteNameMsg + +instance HasCodec DeleteNameMsg where + encode = cs . toLazyByteString + decode = first (formatMessageParseError . coerceProto3Error) . fromByteString + +data BuyNameMsg = BuyNameMsg + { buyNameBid :: Amount + , buyNameName :: Text + , buyNameValue :: Text + , buyNameBuyer :: Address + } deriving (Eq, Show) + +data BuyNameMessage = BuyNameMessage + { buyNameMessageBid :: Word64 + , buyNameMessageName :: Text + , buyNameMessageValue :: Text + , buyNameMessageBuyer :: Address + } deriving (Eq, Show, Generic) +instance Message BuyNameMessage +instance Named BuyNameMessage + +instance HasCodec BuyNameMsg where + encode BuyNameMsg {..} = + let buyNameMessage = BuyNameMessage + { buyNameMessageBid = unAmount buyNameBid + , buyNameMessageName = buyNameName + , buyNameMessageValue = buyNameValue + , buyNameMessageBuyer = buyNameBuyer + } + in cs . toLazyByteString $ buyNameMessage + decode = + let toBuyName BuyNameMessage {..} = BuyNameMsg + { buyNameBid = Amount buyNameMessageBid + , buyNameName = buyNameMessageName + , buyNameValue = buyNameMessageValue + , buyNameBuyer = buyNameMessageBuyer + } + in bimap (formatMessageParseError . coerceProto3Error) toBuyName + . fromByteString @BuyNameMessage +~~~ + +As `protobuf` is a schemaless format, parsing is sometimes ambiguous if two types are the same up to field names, or one is a subset of the other. For this reason we use the type class `HasTypedMessage` + +~~~ haskell ignore +class HasMessageType msg where + messageType :: Proxy msg -> Text +~~~ + +to associate each message to a tag to assist in parsing. So for example, we can implement this class for our message types as + +~~~ haskell + +instance HasMessageType SetNameMsg where + messageType _ = "SetName" + +instance HasMessageType DeleteNameMsg where + messageType _ = "DeleteName" + +instance HasMessageType BuyNameMsg where + messageType _ = "BuyName" +~~~ + + +## Message Validation + +Message validation is an important part of the transaction life cycle. When a `checkTx` message comes in, Tendermint is asking whether a transaction bytestring from the mempool is potentially runnable. At the very least this means that + +1. The transaction parses to a known message +2. The message passes basic signature authentication, if any is required. +3. The message author has enough funds for the gas costs, if any. +4. The message can be successfully routed to a module without handling. + +On top of this you might wish to ensure other static properties of the message, such as that the author of the message is the owner of the funds being transfered. For this we have a `ValidateMessage` class: + +~~~ haskell ignore +data MessageSemanticError = + PermissionError Text + | InvalidFieldError Text + | OtherSemanticError Text + +class ValidateMessage msg where + validateMessage :: Msg msg -> Validation [MessageSemanticError] () +~~~ + +We're using the applicative functor [`Data.Validation.Validation`](https://hackage.haskell.org/package/validation-1.1/docs/Data-Validation.html#t:Validation) to perform valdiation because it is capable of reporting all errors at once, rather than the first that occurs as in ther case with something like `Either`. + +Here's what the `isAuthor` check looks like, that was described above: + +~~~ haskell ignore +isAuthorCheck + :: Text + -> Msg msg + -> (msg -> Address) + -> V.Validation [MessageSemanticError] () +isAuthorCheck fieldName Msg{msgAuthor, msgData} getAuthor + | getAuthor msgData /= msgAuthor = + _Failure # [PermissionError $ fieldName <> " must be message author."] + | otherwise = Success () +~~~ + +It is also possible to run dynamic checks on the transaction, i.e. checks that need to query state in order to succeed or fail. We will say more on this later. + +Here are the validation instances for our message types, which use some of the combinators defined in the SDK + +~~~ haskell +instance ValidateMessage SetNameMsg where + validateMessage msg@Msg{..} = + let SetNameMsg{setNameName, setNameValue} = msgData + in sequenceA_ + [ nonEmptyCheck "Name" setNameName + , nonEmptyCheck "Value" setNameValue + , isAuthorCheck "Owner" msg setNameOwner + ] + +instance ValidateMessage DeleteNameMsg where + validateMessage msg@Msg{..} = + let DeleteNameMsg{deleteNameName} = msgData + in sequenceA_ + [ nonEmptyCheck "Name" deleteNameName + , isAuthorCheck "Owner" msg deleteNameOwner + ] + +instance ValidateMessage BuyNameMsg where + validateMessage msg@Msg{..} = + let BuyNameMsg{buyNameName, buyNameValue} = msgData + in sequenceA_ + [ nonEmptyCheck "Name" buyNameName + , nonEmptyCheck "Value" buyNameValue + , isAuthorCheck "Owner" msg buyNameBuyer + ] +~~~ diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/04-Keeper.md b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/04-Keeper.md new file mode 100644 index 00000000..5b44c516 --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/04-Keeper.md @@ -0,0 +1,133 @@ +--- +title: Nameservice - Keeper +--- + +# Keeper + +## Definition + +"Keeper" is a word taken from the cosmos-sdk, it's basically the interface that the module exposes to the other modules in the application. For example, in the Nameservice app, the Nameservice keeper exposes functions to `buy`/`sell`/`delete` entries in the mapping. Likewise, the Nameservice keeper depends on the keeper from the `bank` module in order to transfer tokens when executing those methods. A keeper might also indicate what kinds of exceptions are able to be caught and thrown from the module. For example, calling `transfer` while buying a `Name` might throw an `InsufficientFunds` exception, which the Namerservice module can chose whether to catch or not. + +## Tutorial.Nameservice.Keeper + +In this section, we will make use of the `Store` types defined in `Nameservice.Modules.Nameservice.Store`. For an overview on how this is setup, see the `Storage` chapter in the `Foundations` section of the tutorial. + +~~~ haskell +{-# LANGUAGE TemplateHaskell #-} +module Tutorial.Nameservice.Keeper where + +import Polysemy (Sem, Member, Members, makeSem) +import Polysemy.Error (Error, throw) +import Nameservice.Modules.Nameservice.Messages +import Nameservice.Modules.Nameservice.Store (Name(..), whoisMap) +import Nameservice.Modules.Nameservice.Types (Whois(..), NameDeleted(..), NameserviceError(..)) +import qualified Tendermint.SDK.BaseApp as BA +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import Tendermint.SDK.Modules.Bank (BankEffs, Coin(..), CoinId, mint) + + +nameserviceCoinId :: CoinId +nameserviceCoinId = "nameservice" +~~~ + +Generally a keeper is defined by a set of effects that the module introduces and depends on. In the case of Nameservice, we introduce the custom `Nameservice` effect: + + +~~~ haskell +type NameserviceEffs = '[NameserviceKeeper, Error NameserviceError] + +data NameserviceKeeper m a where + BuyName :: BuyNameMsg -> NameserviceKeeper m () + DeleteName :: DeleteNameMsg -> NameserviceKeeper m () + SetName :: SetNameMsg -> NameserviceKeeper m () + GetWhois :: Name -> NameserviceKeeper m (Maybe Whois) + +makeSem ''NameserviceKeeper +~~~ + +where `makeSem` is from polysemy, it uses template Haskell to create the helper functions `buyName`, `deleteName`, `setName`, `getWhois`: + +~~~ haskell ignore +buyName :: BuyNameMsg -> NameserviceKeeper m () +deleteName :: DeleteNameMsg -> NameserviceKeeper m () +setName :: SetNameMsg -> NameserviceKeeper m () +getWhois :: Name -> NameserviceKeeper m (Maybe Whois) +~~~ + +### Evaluating Module Effects + +Like we said before, all transactions must ultimately compile to the set of effects belonging to `TxEffs` and `BaseEffs`. In particular this means that we must interpret `NameserviceEffs` into more basic effects. To do this we follow the general pattern of first interpreting `NameserviceKeeper` effects, then finally interpreting `Error NameserviceError` in terms of `Error AppError`. Let's focus on the `DeleteName` summand of `NameserviceKeeper`. We can write an interpreting function as follows: + +~~~ haskell +deleteNameF + :: Members BA.TxEffs r + => Members BA.BaseEffs r + => Members BankEffs r + => Member (Error NameserviceError) r + => DeleteNameMsg + -> Sem r () +deleteNameF DeleteNameMsg{..} = do + mWhois <- M.lookup (Name deleteNameName) whoisMap + case mWhois of + Nothing -> throw $ InvalidDelete "Can't remove unassigned name." + Just Whois{..} -> + if whoisOwner /= deleteNameOwner + then throw $ InvalidDelete "Deleter must be the owner." + else do + mint deleteNameOwner (Coin nameserviceCoinId whoisPrice) + M.delete (Name deleteNameName) whoisMap + let event = NameDeleted + { nameDeletedName = deleteNameName + } + BA.emit event + BA.logEvent event +~~~ + +The control flow should be pretty clear: +1. Check that the name is actually registered, if not throw an error. +2. Check that the name is registered to the person trying to delete it, if not throw an error. +3. Refund the tokens locked in the name to the owner. +4. Delete the entry from the database. +5. Emit an event that the name has been deleted and log this event. + +Taking a look at the class constraints, we see + +~~~ haskell ignore + ( Members BaseApp.TxEffs r + , Members BaseApp.BaseEffs r + , Members BankEffs r + , Member (Error NameserviceError) r + ) +~~~ + +- The `TxEffs` effect is required because the function manipulates the `whoisMap` and emits an `Event`. +- The `BaseEffs` effect is required because the function has logging. +- The `Error NameserviceError` effect is required because the function may throw an error. +- The `BankEffs` effect is required because the function will mint coins. + + +Using this helper function and others, we can write our module's `eval` function by interpreting the `NameserviceEffs` in two steps: + +~~~ haskell ignore +eval + :: Members BA.TxEffs r + => Members BankEffs r + => Members BA.BaseEffs r + => forall a. Sem (NameserviceKeeper ': Error NameserviceError ': r) a + -> Sem r a +eval = mapError BaseApp.makeAppError . evalNameservice + where + evalNameservice + :: Members BA.TxEffs r + => Members BA.BaseEffs r + => Members BankEffs r + => Member (Error NameserviceError) r + => Sem (NameserviceKeeper ': r) a -> Sem r a + evalNameservice = + interpret (\case + ... + DeleteName msg -> deleteNameF msg + ... + ) + +~~~ diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/05-Query.md b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/05-Query.md new file mode 100644 index 00000000..c2a55b4a --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/05-Query.md @@ -0,0 +1,43 @@ +--- +title: Nameservice - Query +--- + +# Query + +## Tutorial.Nameservice.Query + +~~~ haskell +module Tutorial.Nameservice.Query where + +import Nameservice.Modules.Nameservice.Types (Whois) +import Nameservice.Modules.Nameservice.Store (Name, whoisMap) +import Polysemy (Members) +import Tendermint.SDK.BaseApp (QueryEffs, StoreLeaf, RouteQ, storeQueryHandler) +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import Servant.API ((:>)) +~~~ + +The way to query application state is via the `query` message which uses a `url` like format. The SDK tries to abstract as much of this away as possible. For example, if you want to only serve state that you have registered with the store via the `IsKey` class, then things are very easy. If you need to make joins to serve requests, we support this as well and it's not hard, but we will skip this for now. + +In the case we just want to serve data we have registered with the `IsKey` class, we simply need to declare some types: + +```haskell + +type Api = "whois" :> StoreLeaf (M.Map Name Whois) + +``` + +`Api` is the list of valid urls for this module. In this case, when unpacked it will create a single endpoint `/whois` that expects a value of type `Name` as the `data` field in the ABCI `query` object. Technically speaking it is a `Name` prefixed by some other storage related prefixes dictated by the module, but we will hold off on this for now. If you use the automatically generated client libraries, you don't need to worry about this. + +To serve all the data, we can use the `storeQueryHandler` function by supplying the appropriate `store` we want to serve. + +~~~ haskell +querier + :: Members QueryEffs r + => RouteQ Api r +querier = storeQueryHandler whoisMap +~~~ + +Here `RouteQ` is a type family that can build a server from the `Api` type to handle incoming requests. It is similar to how `servant` works, and is largely vendored from that codebase. + +Note that more advanced queries are possible other than just serving what is in storage. For example you might want to use joins to fulfill requests or use query parameters in the url. These are all possible, but we won't go into details here as they are not used in the app. diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/06-Router.md b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/06-Router.md new file mode 100644 index 00000000..4e886bb0 --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/06-Router.md @@ -0,0 +1,123 @@ +--- +title: Nameservice - Router +--- + +# Router + +## Tutorial.Nameservice.Router + +The Router is where you specifiy the handlers for the messages that the module accepts. The router is typed in a [servant](https://hackage.haskell.org/package/servant) style, using combinators and primitives to declare a very precise type for the router. + +~~~ haskell +module Tutorial.Nameservice.Router where + +import Nameservice.Modules.Nameservice.Keeper (NameserviceEffs, + buyName, deleteName, + setName) +import Nameservice.Modules.Nameservice.Messages (BuyName, DeleteName, + SetName) +import Polysemy (Members, Sem) +import Tendermint.SDK.Modules.Bank (BankEffs) +import Servant.API ((:<|>) (..)) +import Tendermint.SDK.BaseApp ((:~>), BaseEffs, + Return, + RouteContext (..), + RouteTx, + RoutingTx (..), + TxEffs, TypedMessage, + incCount, withTimer) +import Tendermint.SDK.Types.Message (Msg (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) + +~~~ + +## Typing the Router + +First we declare the type for our router + +~~~ haskell +type MessageApi = + TypedMessage BuyName :~> Return () + :<|> TypedMessage SetName :~> Return () + :<|> TypedMessage DeleteName :~> Return () +~~~ + +Lets break it down: + +- `(:<|>)` is the operator which denotes alternative, so our router is composed of 3 handlers in this case. +- `TypedMessage` is a combinator that speficies that message type we want to accept. We requre that whatever the message type is, it implements the `HasTypedMessage` class. +- `(:~>)` is a combinator that allows us to connect a message type with a response +- `Return` is used to specify the return type. + +Since there are two possible ABCI messages that the router has to accomodate, `checkTx` and `deliverTx`, the router may return different values depending on the ABCI message type. For example, it's possible that the `checkTx` does not fully mimic the transaction and simply returns `()`, while the `deliverTx` message returns a value of type `Whois`. Concretely you would write + +~~~ haskell ignore +type BuyNameHandler = TypeMessage BuyName :~> Return' 'OnCheckUnit Whois +~~~ + +or equivalently using the alias + +~~~ haskell ignore +type BuyNameHandler = TypeMessage BuyName :~> Return Whois +~~~ + + Alternatively, you could write the application so that each `checkTx` ABCI message is handled in the same way as the `deliverTx` message, e.g. the both return a value of type `Whois`. + +~~~ haskell ignore +type BuyNameHandler = TypeMessage BuyName :~> Return' 'OnCheckEval Whois +~~~ + + +In the case of our actual application, all the transactions return `()` for both `checkTx` and `deliverTx` + +## Implementing the Handlers + +Similar to the servant style, the types for the handlers must be computed from the type of the router. This requires that you understand what each of the combinators corresponds to, and again this ultimately depends on which `RouteContext` we're in, either `CheckTx` or `DeliverTx`. + +Rather than cover all possible cases, we just note that in the case of the Nameservice app we end up with the following server type for the `DeliverTx` context: + +~~~ haskell + +messageHandlers + :: Members BaseEffs r + => Members BankEffs r + => Members NameserviceEffs r + => RouteTx MessageApi r 'DeliverTx +messageHandlers = buyNameH :<|> setNameH :<|> deleteNameH + +buyNameH + :: Members BaseEffs r + => Members TxEffs r + => Members BankEffs r + => Members NameserviceEffs r + => RoutingTx BuyName + -> Sem r () +buyNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "buy_total" + withTimer "buy_duration_seconds" $ buyName msgData + +setNameH + :: Members BaseEffs r + => Members TxEffs r + => Members NameserviceEffs r + => RoutingTx SetName + -> Sem r () +setNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "set_total" + withTimer "set_duration_seconds" $ setName msgData + +deleteNameH + :: Members BaseEffs r + => Members TxEffs r + => Members BankEffs r + => Members NameserviceEffs r + => RoutingTx DeleteName + -> Sem r () +deleteNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "delete_total" + withTimer "delete_duration_seconds" $ deleteName msgData + + ~~~ + + +[Next: Module](Module.md) \ No newline at end of file diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/07-Module.md b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/07-Module.md new file mode 100644 index 00000000..40789369 --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/07-Module.md @@ -0,0 +1,81 @@ +--- +title: Nameservice - Module +--- + +# Module + +## Tutorial.Nameservice.Module + +At this point we can collect the relevant pieces to form the Nameservice module: + +~~~ haskell +module Tutorial.Nameservice.Module where + +import Nameservice.Modules.Nameservice.Keeper (NameserviceEffs, eval) +import Nameservice.Modules.Nameservice.Query (QueryApi, querier) +import Nameservice.Modules.Nameservice.Router (MessageApi, messageHandlers) +import Nameservice.Modules.Nameservice.Types (NameserviceName) +import Tendermint.SDK.Application (Module (..), ModuleEffs) +import Tendermint.SDK.BaseApp (DefaultCheckTx (..)) +import Tendermint.SDK.Modules.Bank (Bank) +import Data.Proxy +import Polysemy (Members) + +-- a convenient type alias +type Nameservice = + Module NameserviceName MessageApi MessageApi QueryApi NameserviceEffs '[Bank] + +nameserviceModule + :: Members (ModuleEffs Nameservice) r + => Nameservice r +nameserviceModule = Module + { moduleTxDeliverer = messageHandlers + , moduleTxChecker = defaultCheckTx (Proxy :: Proxy MessageApi) (Proxy :: Proxy r) + , moduleQuerier = querier + , moduleEval = eval + } + +~~~ + +Here We are using `defaultCheckTx` as our transaction checker, which is a static, message validating handler defined as: + +~~~ haskell ignore +defaultCheckTxHandler + :: Member (Error AppError) r + => ValidateMessage msg + => RoutingTx msg + -> Sem r () +defaultCheckTxHandler(RoutingTx Tx{txMsg}) = + case validateMessage txMsg of + V.Failure err -> + throwSDKError . MessageValidation . map formatMessageSemanticError $ err + V.Success _ -> pure () +~~~ + +Note that this checker can be used to implement any transaction for which +1. The message accepted by the router has a `ValidateMessage` instance +2. The return type in the serve type is `Return ()` + +To generate a server for which every transaction has these properties, we used the `defaultCheckTx` type class method on the `MessageApi` type. This will generate a server of type `VoidReturn MessageApi`, which has the exact same shape as `MessageApi` just will all the return values changed to `Return ()`. In this paricular case all handlers for `MessageApi` already return `()`, so we have `MessageApi ~ VoidReturn MessageApi` and there's no need to use the `VoidReturn` family in the module type. + +Note the constraint on `r` in the Module's type using the constraint-valued type family `ModuleEffs`. In this case it evaluates to the following equivalent set of constraints: + +~~~ haskell ignore +... + ModuleEffs Nameservice r + ~ ( Members NameserviceEffs r + , Members (DependencyEffs '[Bank] r) + , Members TxEffs r + , Members BaseEffs r + ) + ~ ( Members NameserviceEffs r + , Members BankEffs r + , Members TxEffs r + , Members BaseEffs r + ) +... +~~~ + +This is saying that we can run this module in any context for which `r` has the effects from `NameserviceEffs`, `BankEffs`, `TxEffs`, and `BaseEffs`. This is how we explicitly declare global effect dependencies for a module, by using the constraint system. + +Other than that, there is nothing really to note. We are just collecting the pieces we have already defined in one place. diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/08-Application.md b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/08-Application.md new file mode 100644 index 00000000..d810d13b --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/08-Application.md @@ -0,0 +1,110 @@ +--- +title: Nameservice - Application +--- + +# Application + +## From Modules to App + +The `App` type in `Network.ABCI.Server` is defined as + +~~~ haskell ignore +newtype App m = App + { unApp :: forall (t :: MessageType). Request t -> m (Response t) } +~~~ + +and ultimately our configuration of modules must be converted to this format. This is probably the most important part of the SDK, to provide the bridge between the list of modules - a heterogeneous list of type `ModuleList` - and the actual application. The type that provides the input for this bridge is `HandlersContext`: + +~~~ haskell ignore +data HandlersContext alg ms core = HandlersContext + { signatureAlgP :: Proxy alg + , modules :: M.ModuleList ms (Effs ms core) + , anteHandler :: BA.AnteHandler (Effs ms core) + , compileToCore :: forall a. Sem (BA.BaseAppEffs core) a -> Sem core a + } +~~~ + +where +- `alg` is the signature schema you would like to use for authentication (e.g. Secp256k1) +- `ms` is the type level list of modules +- `r` is the global effects list for the application +- `core` is the set of core effects that are used to interpet `BaseApp` to `IO`. +- `Effs` is a type family that gathers the effect dependencies for `ms` in the appropriate order. + +We should say a few words on this `compileToCore` field. The application developer has to, at the end of the day, specify how the entire effects system for the application will be interpreted to `IO`. Luckily most of these decisions are abstracted away, but the one that remains is dealing with `BaseApp core`. The sdk provides two default methods for two different types of `core`: + + +~~~ haskell ignore +defaultCompileToCore + :: forall a. + Sem (BaseApp CoreEffs) a + -> Sem CoreEffs a + +defaultCompileToPureCore + :: forall a. + Sem (BaseApp PureCoreEffs) a + -> Sem PureCoreEffs a +~~~ + + +The difference is that `defaultCompileToCore` uses the IAVL store external database and also allows for metrics, where `defaultCompileToPureCore` uses an in-memory db and treats all metrics operations as a no-op. + +## Tutorial.Nameservice.Application + +~~~ haskell +module Tutorial.Nameservice.Application where + +import Data.Proxy +import Nameservice.Modules.Nameservice (Nameservice, nameserviceModule) +import Network.ABCI.Server.App (App) +import Polysemy (Sem) +import Tendermint.SDK.Modules.Auth (Auth, authModule) +import Tendermint.SDK.Application (ModuleList(..), HandlersContext(..), baseAppAnteHandler, makeApp, createIOApp) +import Tendermint.SDK.BaseApp (CoreEffs, Context, defaultCompileToCore, runCoreEffs) +import Tendermint.SDK.Crypto (Secp256k1) +import Tendermint.SDK.Modules.Bank (Bank, bankModule) +~~~ + +At this point we need to simply list the modules we want to use in our application. We only require that if a module is declared as a dependency by another (via the `deps` type variable in the `Module` type), then that dependency should be inserted below that module. For example, since `Nameservice` depends on `Bank`, we must list `Bank` after `Nameservice`. Similarly since `Bank` depends on `Auth`, we must list `Auth` after `Bank`: + + +~~~ haskell +type NameserviceModules = + '[ Nameservice + , Bank + , Auth + ] +~~~ + +We're now ready to define the `HandlersContext` for our application: + +~~~ haskell +handlersContext :: HandlersContext Secp256k1 NameserviceModules CoreEffs +handlersContext = HandlersContext + { signatureAlgP = Proxy @Secp256k1 + , modules = nameserviceModules + , compileToCore = defaultCompileToCore + , anteHandler = baseAppAnteHandler + } + where + nameserviceModules = + nameserviceModule + :+ bankModule + :+ authModule + :+ NilModules +~~~ + +Finally we're able to define our application that runs in the `CoreEffs` context defined in the SDK: + + +~~~ haskell +app :: App (Sem CoreEffs) +app = makeApp handlersContext +~~~ + +Since the ABCI server requires you to pass a value of type `App IO`, we have one more transformation to perform to get replace the `Sem CoreEffs` in our app. We can simple use the `createIOApp` function: + +~~~ haskell +makeIOApp :: Context -> App IO +makeIOApp ctx = createIOApp (runCoreEffs ctx) app +~~~ diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/09-Testing.md b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/09-Testing.md new file mode 100644 index 00000000..1bba738e --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/09-Testing.md @@ -0,0 +1,158 @@ +--- +title: Nameservice - Testing +--- + +# Testing and Client Generation + +It's time to see the real benefits of including as much information as possible in the types, which goes beyond a simple guarantee that certain things won't fail at runtime. Since the `api`s for querying state and delivering transactions was specified in the type of each module, hence in the type of the application via the `ModulesList`, we are able to generate client libraries for these actions for free. This is especially useful in testing to eliminate as much boilerplate as possible, and to get compile time failures whenever an api change would break your tests. + + +Let's take a look at how this works in the `E2E` test suite: + + +~~~ haskell + +module Tutorial.Nameservice.Testing where + +import Control.Monad.Reader (ReaderT, runReaderT) +import Data.Default.Class (def) +import Data.Proxy +import Nameservice.Application +import qualified Nameservice.Modules.Nameservice as N +import qualified Network.Tendermint.Client as RPC +import Servant.API ((:<|>) (..)) +import qualified Tendermint.SDK.Application.Module as M +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import Tendermint.SDK.BaseApp.Query (QueryArgs (..), + QueryResult (..)) +import qualified Tendermint.SDK.Modules.Auth as Auth +import qualified Tendermint.SDK.Modules.Bank as B +import Tendermint.SDK.Types.Address (Address) +import Tendermint.Utils.Client (ClientConfig (..), + EmptyTxClient (..), + QueryClientResponse (..), + TxClientResponse (..), + TxOpts (..), HasTxClient(..), + HasQueryClient(..), + defaultClientTxOpts) +import Tendermint.Utils.ClientUtils (rpcConfig) +~~~ + +First let's look at how to generate a client for querying state. If you've ever used servant client, this should look familiar since the design was heavily influenced (i.e. shamelessly stolen) from there: + + +~~~ haskell + +getAccount + :: QueryArgs Address + -> RPC.TendermintM (QueryClientResponse Auth.Account) + +getWhois + :: QueryArgs N.Name + -> RPC.TendermintM (QueryClientResponse N.Whois) + +getBalance + :: QueryArgs Address + -> Auth.CoinId + -> RPC.TendermintM (QueryClientResponse Auth.Coin) + +getWhois :<|> getBalance :<|> getAccount = + genClientQ (Proxy :: Proxy m) queryApiP def + where + queryApiP :: Proxy (M.ApplicationQ NameserviceModules) + queryApiP = Proxy +~~~ + +We can then use these generated functions by simply providing an `RPCConfig` object as defined in the Tendermint client library: + +~~~ haskell +getWhois' :: QueryArgs N.Name -> IO (QueryClientResponse N.Whois) +getWhois' = RPC.runTendermintM rpcConfig . getWhois +~~~ + +Similarly we can generate a client for sending transactions as well. This is slightly tricker because of the `nonce` problem, exlpained in the following chain of reasoning: + +1. In order to submit a valid transaction, we need to provide the correct nonce value for the transaction author, which is an ever increasing sequence of natural numbers. +2. In order to get the current nonce value for a transaction author, we need to query the accounts module for their current nonce value. +3. Therefore in order to generate a client for submitting transactions, we should make use of our query client for the auth module, using the returned nonce value to template the transaction. + +Therefore the `ClientConfig` object for the transaction client includes the method for querying nonces: + + +~~~ haskell +type TxClientM = ReaderT ClientConfig IO + +runTxClientM :: TxClientM a -> IO a +runTxClientM m = runReaderT m txClientConfig + +txClientConfig :: ClientConfig +txClientConfig = + let getNonce addr = do + resp <- RPC.runTendermintM rpcConfig $ getAccount $ + QueryArgs + { queryArgsHeight = -1 + , queryArgsProve = False + , queryArgsData = addr + } + -- @NOTE: TxNonce should be +1 of accountNonce + case resp of + QueryError e -> + if appErrorCode e == 2 + then pure 1 + else error $ "Unknown nonce error: " <> show (appErrorMessage e) + QueryResponse QueryResult {queryResultData} -> + pure $ 1 + Auth.accountNonce queryResultData + + in ClientConfig + { clientGetNonce = getNonce + , clientRPC = rpcConfig + } +~~~ + + +Once we have defined our monad capable of querying nonces, we can then generate the transaction client using this monad as our context. + +~~~ haskell + +-- Nameservice Client +buyName + :: TxOpts + -> N.BuyNameMsg + -> TxClientM (TxClientResponse () ()) + +setName + :: TxOpts + -> N.SetNameMsg + -> TxClientM (TxClientResponse () ()) + +deleteName + :: TxOpts + -> N.DeleteNameMsg + -> TxClientM (TxClientResponse () ()) + +-- Bank Client +transfer + :: TxOpts + -> B.TransferMsg + -> TxClientM (TxClientResponse () ()) + +faucet + :: TxOpts + -> N.FaucetAccountMsg + -> TxClientM (TxClientResponse () ()) + +(buyName :<|> setName :<|> deleteName :<|> faucet) :<|> + (_ :<|> transfer) :<|> + EmptyTxClient = + genClientT (Proxy @TxClientM) txApiCP txApiDP defaultClientTxOpts + where + txApiCP :: Proxy (M.ApplicationC NameserviceModules) + txApiCP = Proxy + txApiDP :: Proxy (M.ApplicationD NameserviceModules) + txApiDP = Proxy +~~~ + +Here you'll see that the `TxClientResponse` has two type variables, which in this case are always both `()`. This is because it is possible to return separate values depending on whether we are in the `checkTx` versus `deliverTx` context. + + +To see how these clients are used together with other test combinators for the `hs-abci-test-utils` package, you can view the `E2E` test files in the nameservice test suite. \ No newline at end of file diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Application.lhs b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Application.lhs new file mode 120000 index 00000000..4bc43a41 --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Application.lhs @@ -0,0 +1 @@ +08-Application.md \ No newline at end of file diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Keeper.lhs b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Keeper.lhs new file mode 120000 index 00000000..6262309b --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Keeper.lhs @@ -0,0 +1 @@ +04-Keeper.md \ No newline at end of file diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Message.lhs b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Message.lhs new file mode 120000 index 00000000..0330728d --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Message.lhs @@ -0,0 +1 @@ +03-Message.md \ No newline at end of file diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Module.lhs b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Module.lhs new file mode 120000 index 00000000..5f1386c0 --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Module.lhs @@ -0,0 +1 @@ +07-Module.md \ No newline at end of file diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Query.lhs b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Query.lhs new file mode 120000 index 00000000..ad79aed3 --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Query.lhs @@ -0,0 +1 @@ +05-Query.md \ No newline at end of file diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Router.lhs b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Router.lhs new file mode 120000 index 00000000..aeb17b8a --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Router.lhs @@ -0,0 +1 @@ +06-Router.md \ No newline at end of file diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Testing.lhs b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Testing.lhs new file mode 120000 index 00000000..2784e992 --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Testing.lhs @@ -0,0 +1 @@ +09-Testing.md \ No newline at end of file diff --git a/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Types.lhs b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Types.lhs new file mode 120000 index 00000000..1265f50c --- /dev/null +++ b/hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/Types.lhs @@ -0,0 +1 @@ +02-Types.md \ No newline at end of file diff --git a/hs-abci-docs/package.yaml b/hs-abci-docs/package.yaml new file mode 100644 index 00000000..43e5f156 --- /dev/null +++ b/hs-abci-docs/package.yaml @@ -0,0 +1,9 @@ +name: kepler +version: 1.0.0.0 +github: "f-o-a-m/kepler" +license: Apache +author: "f-o-a-m" +maintainer: "martin@foam.space" +copyright: "2020 FOAM" +synopsis: "Haskell cosmos sdk" +description: Please see the README on GitHub at diff --git a/hs-abci-docs/simple-storage/README.md b/hs-abci-docs/simple-storage/README.md new file mode 100644 index 00000000..9ffd955b --- /dev/null +++ b/hs-abci-docs/simple-storage/README.md @@ -0,0 +1,23 @@ +# hs-abci-example + +The example application is meant to test all of the other hs-abci libraries and serve as a demo. +It's a simple application called **Simple Storage** that maintains a shared 32-byte integer and +allows users to update and query the count. + +## Environment Variables +- LOG_SEVERITY (defaults to **info**) : minimum log severtiy level {debug, info, notice, warning, error, critical, alert, emergency} +- LOG_VERBOSITY (defaults to **0**) : for each loggable data point, the level of information actually logged {0, 1, 2, 3} + +## Running with Docker +There is a `docker-compose.yaml` file in this directory. If you use the `make` command from the project root + +```bash +> make deploy-simple-storage-docker +``` + +it will build an image for simple-storage and launch it in a docker network +with a tendermint-core node. + +## Application Messages +The application uses a protobuf file to define its [transaction messages](https://github.com/f-o-a-m/kepler/blob/master/hs-abci-docs/simple-storage/protos/simple-storage/messages.proto). Thus if you would like to post transactions to this application via RPC, you will need to first consume +this profobuf file. You can follow the pattern in the test suite using hs-tendermint-client. diff --git a/hs-abci-examples/simple-storage/Setup.hs b/hs-abci-docs/simple-storage/Setup.hs similarity index 100% rename from hs-abci-examples/simple-storage/Setup.hs rename to hs-abci-docs/simple-storage/Setup.hs diff --git a/hs-abci-docs/simple-storage/app/Main.hs b/hs-abci-docs/simple-storage/app/Main.hs new file mode 100644 index 00000000..fd87ad5e --- /dev/null +++ b/hs-abci-docs/simple-storage/app/Main.hs @@ -0,0 +1,16 @@ +module Main where + +import Control.Exception (bracket) +import Control.Lens ((^.)) +import qualified Katip as K +import SimpleStorage.Config (baseAppContext, + makeAppConfig) +import SimpleStorage.Server (makeAndServeApplication) +import qualified Tendermint.SDK.BaseApp as BaseApp +import qualified Tendermint.SDK.BaseApp.Logger.Katip as KL + +main :: IO () +main = + let close cfg = K.closeScribes (cfg ^. baseAppContext . BaseApp.contextLogConfig . KL.logEnv) + in bracket makeAppConfig close makeAndServeApplication + diff --git a/hs-abci-docs/simple-storage/docker-compose.yaml b/hs-abci-docs/simple-storage/docker-compose.yaml new file mode 100644 index 00000000..9750c6f3 --- /dev/null +++ b/hs-abci-docs/simple-storage/docker-compose.yaml @@ -0,0 +1,43 @@ +version: '3.7' +services: + tendermint-init: + image: tendermint/tendermint:v0.32.8 + command: init + volumes: + - tendermint-storage:/tendermint + tendermint: + depends_on: + - tendermint-init + - simple-storage + image: tendermint/tendermint:v0.32.8 + command: node --rpc.laddr=tcp://0.0.0.0:26657 --proxy_app=tcp://simple-storage:26658 + volumes: + - tendermint-storage:/tendermint + restart: always + ports: + - "26656-26657:26656-26657" + simple-storage: + build: + context: ../../. + dockerfile: Dockerfile + image: hs-abci:test + environment: + - DD_API_KEY=${DD_API_KEY} + - IAVL_HOST=iavl + - IAVL_PORT=8090 + restart: always + entrypoint: /usr/local/bin/simple-storage + expose: + - "26658" + iavl: + image: foamspace/iavl:latest + command: /iavlserver -db-name "test" -datadir "." -grpc-endpoint "0.0.0.0:8090" -gateway-endpoint "0.0.0.0:8091" + ports: + - "8090:8090" + - "8091:8091" + expose: + - "8090" + - "8091" + +volumes: + tendermint-storage: diff --git a/hs-abci-examples/simple-storage/package.yaml b/hs-abci-docs/simple-storage/package.yaml similarity index 55% rename from hs-abci-examples/simple-storage/package.yaml rename to hs-abci-docs/simple-storage/package.yaml index 13c61263..b39204bd 100644 --- a/hs-abci-examples/simple-storage/package.yaml +++ b/hs-abci-docs/simple-storage/package.yaml @@ -1,15 +1,15 @@ name: simple-storage version: 0.1.0.0 -github: "f-o-a-m/hs-abci/hs-abci-examples/simple-storage" +github: "f-o-a-m/kepler/hs-abci-docs/simple-storage" license: Apache author: Martin Allen maintainer: "martin@foam.space" -copyright: "2019 Martin Allen" +copyright: "2020 Martin Allen" extra-source-files: - protos/**/*.proto -description: Please see the README on GitHub at +description: Please see the README on GitHub at default-extensions: - DeriveGeneric @@ -37,41 +37,6 @@ default-extensions: - StandaloneDeriving - ConstraintKinds - -dependencies: -- async -- avl-auth -- base >= 4.7 && < 5 -- binary -- bytestring -- containers -- conduit -- cryptonite -- data-default-class -- errors -- exceptions -- free -- hs-abci-extra -- hs-abci-server -- hs-abci-types -- hs-abci-extra -- hs-abci-sdk -- http-types -- kan-extensions -- katip -- lens -- memory -- mtl -- polysemy -- polysemy-plugin -- proto-lens -- proto-lens-runtime -- servant -- stm -- string-conversions -- text -- uri-bytestring - custom-setup: dependencies: - base @@ -85,12 +50,44 @@ library: - -fplugin=Polysemy.Plugin - -Werror - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wredundant-constraints + dependencies: + - aeson + - base >= 4.7 && < 5 + - bytestring + - cereal + - cereal-text + - cryptonite + - hs-abci-extra + - hs-abci-server + - hs-abci-types + - hs-abci-extra + - hs-abci-sdk + - katip + - lens + - memory + - polysemy + - polysemy-plugin + - proto-lens + - proto-lens-runtime + - servant + - string-conversions + - text + - validation exposed-modules: - SimpleStorage.Server - SimpleStorage.Application - - SimpleStorage.Handlers + - SimpleStorage.Config - SimpleStorage.Modules.SimpleStorage - - SimpleStorage.Types + - SimpleStorage.Modules.SimpleStorage.Types + - SimpleStorage.Modules.SimpleStorage.Message + - SimpleStorage.Modules.SimpleStorage.Keeper + - SimpleStorage.Modules.SimpleStorage.Router + - SimpleStorage.Modules.SimpleStorage.Query generated-exposed-modules: - Proto.SimpleStorage.Messages @@ -104,7 +101,16 @@ executables: ghc-options: - -Werror - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wredundant-constraints dependencies: + - base >= 4.7 && < 5 + - katip + - hs-abci-sdk + - lens - simple-storage tests: @@ -113,7 +119,6 @@ tests: source-dirs: test other-modules: - SimpleStorage.Test.E2ESpec - - SimpleStorage.Test.HandlersSpec ghc-options: - -Werror - -Wall @@ -121,10 +126,13 @@ tests: - -rtsopts - -with-rtsopts=-N dependencies: - - aeson - - aeson-pretty + - base >= 4.7 && < 5 + - data-default-class + - hs-abci-sdk - simple-storage - - hs-abci-types + - hs-abci-test-utils - hs-tendermint-client - hspec - - QuickCheck + - mtl + - servant + - random diff --git a/hs-abci-examples/simple-storage/protos/simple-storage/messages.proto b/hs-abci-docs/simple-storage/protos/simple-storage/messages.proto similarity index 100% rename from hs-abci-examples/simple-storage/protos/simple-storage/messages.proto rename to hs-abci-docs/simple-storage/protos/simple-storage/messages.proto diff --git a/hs-abci-docs/simple-storage/src/SimpleStorage/Application.hs b/hs-abci-docs/simple-storage/src/SimpleStorage/Application.hs new file mode 100644 index 00000000..9a952053 --- /dev/null +++ b/hs-abci-docs/simple-storage/src/SimpleStorage/Application.hs @@ -0,0 +1,33 @@ +module SimpleStorage.Application + ( SimpleStorageModules + , handlersContext + ) where + +import Data.Proxy +import SimpleStorage.Modules.SimpleStorage as SimpleStorage +import Tendermint.SDK.Application (HandlersContext (..), + ModuleList (..), + baseAppAnteHandler) +import qualified Tendermint.SDK.BaseApp as BA +import Tendermint.SDK.Crypto (Secp256k1) +import qualified Tendermint.SDK.Modules.Auth as A + +-------------------------------------------------------------------------------- + +type SimpleStorageModules = + '[ SimpleStorage.SimpleStorage + , A.Auth + ] + +handlersContext :: HandlersContext Secp256k1 SimpleStorageModules BA.CoreEffs +handlersContext = HandlersContext + { signatureAlgP = Proxy @Secp256k1 + , modules = simpleStorageModules + , compileToCore = BA.defaultCompileToCore + , anteHandler = baseAppAnteHandler + } + where + simpleStorageModules = + SimpleStorage.simpleStorageModule + :+ A.authModule + :+ NilModules diff --git a/hs-abci-docs/simple-storage/src/SimpleStorage/Config.hs b/hs-abci-docs/simple-storage/src/SimpleStorage/Config.hs new file mode 100644 index 00000000..a8c7a662 --- /dev/null +++ b/hs-abci-docs/simple-storage/src/SimpleStorage/Config.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TemplateHaskell #-} + +module SimpleStorage.Config + ( AppConfig(..) + , baseAppContext + , makeAppConfig + ) where + +import Control.Lens (makeLenses, (&), (.~), + (^.)) +import Data.Maybe (fromMaybe) +import Data.String.Conversions (cs) +import qualified Katip as K +import System.Environment +import System.IO (stdout) +import qualified Tendermint.SDK.BaseApp as BaseApp +import Tendermint.SDK.BaseApp.Logger.Katip as KL +import Tendermint.SDK.BaseApp.Store.IAVLStore (GrpcConfig (..), + initIAVLVersions) + + +data AppConfig = AppConfig + { _baseAppContext :: BaseApp.Context + } +makeLenses ''AppConfig + +makeAppConfig :: IO AppConfig +makeAppConfig = do + versions <- initIAVLVersions + grpcConfig <- do + host <- getEnv "IAVL_HOST" + port <- read <$> getEnv "IAVL_PORT" + pure $ GrpcConfig host port + c <- BaseApp.makeContext (KL.InitialLogNamespace "dev" "simple-storage") Nothing versions grpcConfig + addScribesToLogEnv $ + AppConfig { _baseAppContext = c + } + +addScribesToLogEnv :: AppConfig -> IO AppConfig +addScribesToLogEnv cfg = do + logLevel <- makeLogLevel + let initialLogEnv = cfg ^. baseAppContext . BaseApp.contextLogConfig . KL.logEnv + scribesLogEnv <- makeKatipScribe logLevel initialLogEnv + pure $ cfg & + baseAppContext . BaseApp.contextLogConfig . KL.logEnv .~ scribesLogEnv + +-------------------------------------------------------------------------------- + +data LogLevel = LogLevel + { severity :: K.Severity + , verbosity :: K.Verbosity + } + +makeLogLevel :: IO LogLevel +makeLogLevel = do + -- LOG_SEVERITY should be in {debug, info, notice, warning, error, critical, alert, emergency} + msev <- lookupEnv "LOG_SEVERITY" + let s = fromMaybe K.InfoS (parseSeverity =<< msev) + -- LOG_VERBOSITY should be in {0,1,2,3} + mverb <- lookupEnv "LOG_VERBOSITY" + let v = fromMaybe K.V0 (parseVerbosity =<< mverb) + return LogLevel {severity = s, verbosity = v} + where + parseSeverity = K.textToSeverity . cs + parseVerbosity v + | v == "0" = Just K.V0 + | v == "1" = Just K.V1 + | v == "2" = Just K.V2 + | v == "3" = Just K.V3 + | otherwise = Nothing + +-- makes a log environment for console logs / ES logs +makeKatipScribe + :: LogLevel + -> K.LogEnv + -> IO K.LogEnv +makeKatipScribe LogLevel{..} le = do + handleScribe <- K.mkHandleScribe K.ColorIfTerminal stdout (K.permitItem severity) verbosity + K.registerScribe "stdout" handleScribe K.defaultScribeSettings le diff --git a/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage.hs b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage.hs new file mode 100644 index 00000000..4a4c634f --- /dev/null +++ b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage.hs @@ -0,0 +1,32 @@ +module SimpleStorage.Modules.SimpleStorage + ( SimpleStorage + , simpleStorageModule + + , module SimpleStorage.Modules.SimpleStorage.Keeper + , module SimpleStorage.Modules.SimpleStorage.Message + , module SimpleStorage.Modules.SimpleStorage.Types + ) where + +import Data.Proxy +import Polysemy (Members) +import SimpleStorage.Modules.SimpleStorage.Keeper hiding (countVar) +import SimpleStorage.Modules.SimpleStorage.Message +import SimpleStorage.Modules.SimpleStorage.Query +import SimpleStorage.Modules.SimpleStorage.Router +import SimpleStorage.Modules.SimpleStorage.Types +import Tendermint.SDK.Application (Module (..), + ModuleEffs) +import qualified Tendermint.SDK.BaseApp as BaseApp + +type SimpleStorage = + Module SimpleStorageName MessageApi MessageApi QueryApi SimpleStorageEffs '[] + +simpleStorageModule + :: Members (ModuleEffs SimpleStorage) r + => SimpleStorage r +simpleStorageModule = Module + { moduleTxDeliverer = messageHandlers + , moduleTxChecker = BaseApp.defaultCheckTx (Proxy @MessageApi) (Proxy :: Proxy r) + , moduleQuerier = querier + , moduleEval = eval + } diff --git a/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Keeper.hs b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Keeper.hs new file mode 100644 index 00000000..008d55f7 --- /dev/null +++ b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Keeper.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TemplateHaskell #-} + +module SimpleStorage.Modules.SimpleStorage.Keeper + ( SimpleStorageEffs + , SimpleStorageKeeper(..) + , updateCount + , getCount + , eval + -- + , countVar + ) where + +import Control.Lens (iso) +import Crypto.Hash (SHA256 (..), + hashWith) +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import Data.String.Conversions (cs) +import Polysemy (Members, Sem, + interpret, makeSem) +import Polysemy.Output (Output) +import SimpleStorage.Modules.SimpleStorage.Types +import qualified Tendermint.SDK.BaseApp as BaseApp +import qualified Tendermint.SDK.BaseApp.Store.Var as V + +type SimpleStorageEffs = '[SimpleStorageKeeper] + +data SimpleStorageKeeper m a where + UpdateCount :: Count -> SimpleStorageKeeper m () + GetCount :: SimpleStorageKeeper m (Maybe Count) + +makeSem ''SimpleStorageKeeper + +eval + :: forall r. + Members BaseApp.TxEffs r + => Members BaseApp.BaseEffs r + => forall a. (Sem (SimpleStorageKeeper ': r) a -> Sem r a) +eval = interpret (\case + UpdateCount count -> updateCountF count + GetCount -> V.takeVar countVar + ) + +updateCountF + :: Members '[BaseApp.WriteStore, Output BaseApp.Event, BaseApp.Logger] r + => Count + -> Sem r () +updateCountF count = do + V.putVar count countVar + let event = CountSet count + BaseApp.emit event + BaseApp.logEvent event + + +-------------------------------------------------------------------------------- + +data SimpleStorageNamespace + +store :: BaseApp.Store SimpleStorageNamespace +store = BaseApp.makeStore $ BaseApp.KeyRoot "simple_storage" + +data CountKey = CountKey + +instance BaseApp.RawKey CountKey where + rawKey = iso (\_ -> cs countKey) (const CountKey) + where + countKey :: ByteString + countKey = convert . hashWith SHA256 . cs @_ @ByteString $ ("count" :: String) + +instance BaseApp.IsKey CountKey SimpleStorageNamespace where + type Value CountKey SimpleStorageNamespace = V.Var Count + +countVar :: V.Var Count +countVar = V.makeVar CountKey store + +instance BaseApp.QueryData CountKey diff --git a/hs-abci-examples/simple-storage/src/SimpleStorage/Types.hs b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Message.hs similarity index 55% rename from hs-abci-examples/simple-storage/src/SimpleStorage/Types.hs rename to hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Message.hs index 1042b768..fe54cc93 100644 --- a/hs-abci-examples/simple-storage/src/SimpleStorage/Types.hs +++ b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Message.hs @@ -1,41 +1,36 @@ -module SimpleStorage.Types where +module SimpleStorage.Modules.SimpleStorage.Message + ( UpdateCountTx(..) + )where import Control.Lens (from, iso, view, (&), - (.~), (^.)) -import Control.Lens.Wrapped (Wrapped (..), _Unwrapped') -import Data.Binary (Binary) -import Data.ByteString (ByteString) + (.~), (^.), _Wrapped') +import Control.Lens.Wrapped (Wrapped (..)) +import Data.Bifunctor (bimap) import Data.Int (Int32) -import qualified Data.ProtoLens as PL +import qualified Data.ProtoLens as P import Data.ProtoLens.Message (Message (..)) +import Data.Serialize.Text () +import Data.String.Conversions (cs) import Data.Text (Text) +import Data.Validation (Validation (..)) import GHC.Generics (Generic) import Proto.SimpleStorage.Messages as M import Proto.SimpleStorage.Messages_Fields as M +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Message (HasMessageType (..), + ValidateMessage (..)) -data AppTxMessage = - ATMUpdateCount UpdateCountTx - -decodeAppTxMessage - :: ByteString - -> Either String AppTxMessage -decodeAppTxMessage = fmap (ATMUpdateCount . view _Unwrapped') . PL.decodeMessage - -encodeAppTxMessage - :: AppTxMessage - -> ByteString -encodeAppTxMessage = \case - ATMUpdateCount a -> PL.encodeMessage $ a ^. from _Unwrapped' - - --------------------------------------------------------------------------------- data UpdateCountTx = UpdateCountTx { updateCountTxUsername :: Text , updateCountTxCount :: Int32 } deriving (Show, Eq, Generic) -instance Binary UpdateCountTx +instance HasMessageType UpdateCountTx where + messageType _ = "update_count" + +instance ValidateMessage UpdateCountTx where + validateMessage _ = Success () instance Wrapped UpdateCountTx where type Unwrapped UpdateCountTx = M.UpdateCount @@ -50,3 +45,7 @@ instance Wrapped UpdateCountTx where UpdateCountTx { updateCountTxUsername = msg ^. M.username , updateCountTxCount = msg ^. M.count } + +instance HasCodec UpdateCountTx where + encode = P.encodeMessage . view _Wrapped' + decode = bimap cs (view $ from _Wrapped') . P.decodeMessage diff --git a/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Query.hs b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Query.hs new file mode 100644 index 00000000..c243c39f --- /dev/null +++ b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Query.hs @@ -0,0 +1,19 @@ +module SimpleStorage.Modules.SimpleStorage.Query + ( QueryApi + , querier + ) where + +import Polysemy (Members) +import Servant.API ((:>)) +import SimpleStorage.Modules.SimpleStorage.Keeper (countVar) +import SimpleStorage.Modules.SimpleStorage.Types (Count) +import qualified Tendermint.SDK.BaseApp as BaseApp +import qualified Tendermint.SDK.BaseApp.Store.Var as V + + +type QueryApi = "count" :> BaseApp.StoreLeaf (V.Var Count) + +querier + :: Members BaseApp.QueryEffs r + => BaseApp.RouteQ QueryApi r +querier = BaseApp.storeQueryHandler countVar diff --git a/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Router.hs b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Router.hs new file mode 100644 index 00000000..7172824f --- /dev/null +++ b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Router.hs @@ -0,0 +1,34 @@ +module SimpleStorage.Modules.SimpleStorage.Router + ( MessageApi + , messageHandlers + ) where + +import Polysemy (Member, Sem) +import SimpleStorage.Modules.SimpleStorage.Keeper (SimpleStorageKeeper, + updateCount) +import SimpleStorage.Modules.SimpleStorage.Message +import SimpleStorage.Modules.SimpleStorage.Types (Count (..)) +import Tendermint.SDK.BaseApp ((:~>), Return, + RouteTx, + RoutingTx (..), + TypedMessage) +import Tendermint.SDK.Types.Message (Msg (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) + + +type MessageApi = + TypedMessage UpdateCountTx :~> Return () + +messageHandlers + :: Member SimpleStorageKeeper r + => RouteTx MessageApi r +messageHandlers = updateCountH + +updateCountH + :: Member SimpleStorageKeeper r + => RoutingTx UpdateCountTx + -> Sem r () +updateCountH (RoutingTx Tx{txMsg}) = + let Msg{msgData} = txMsg + UpdateCountTx{updateCountTxCount} = msgData + in updateCount (Count updateCountTxCount) diff --git a/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Types.hs b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Types.hs new file mode 100644 index 00000000..67a7b19a --- /dev/null +++ b/hs-abci-docs/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Types.hs @@ -0,0 +1,39 @@ +module SimpleStorage.Modules.SimpleStorage.Types where + +import qualified Data.Aeson as A +import Data.Bifunctor (first) +import Data.Int (Int32) +import qualified Data.Serialize as Serialize +import qualified Data.Serialize.Text () +import Data.String.Conversions (cs) +import GHC.Generics (Generic) +import qualified Tendermint.SDK.BaseApp as BaseApp +import Tendermint.SDK.Codec (HasCodec (..)) + +type SimpleStorageName = "simple_storage" + +newtype Count = Count Int32 deriving (Eq, Show, A.ToJSON, A.FromJSON, Serialize.Serialize) + +instance HasCodec Count where + encode = Serialize.encode + decode = first cs . Serialize.decode + +-------------------------------------------------------------------------------- +-- Events +-------------------------------------------------------------------------------- + +data CountSet = CountSet { newCount :: Count } deriving Generic + +countSetOptions :: A.Options +countSetOptions = A.defaultOptions + +instance A.ToJSON CountSet where + toJSON = A.genericToJSON countSetOptions + +instance A.FromJSON CountSet where + parseJSON = A.genericParseJSON countSetOptions + +instance BaseApp.ToEvent CountSet + +instance BaseApp.Select CountSet + diff --git a/hs-abci-docs/simple-storage/src/SimpleStorage/Server.hs b/hs-abci-docs/simple-storage/src/SimpleStorage/Server.hs new file mode 100644 index 00000000..9e077a1b --- /dev/null +++ b/hs-abci-docs/simple-storage/src/SimpleStorage/Server.hs @@ -0,0 +1,24 @@ +module SimpleStorage.Server (makeAndServeApplication) where + +import Data.Foldable (fold) +import Data.Monoid (Endo (..)) +import Network.ABCI.Server (serveApp) +import Network.ABCI.Server.App (Middleware) +import qualified Network.ABCI.Server.Middleware.Logger as Logger +import Polysemy (Sem) +import SimpleStorage.Application (handlersContext) +import SimpleStorage.Config (AppConfig (..)) +import Tendermint.SDK.Application (createIOApp, makeApp) +import Tendermint.SDK.BaseApp (CoreEffs, runCoreEffs) + +makeAndServeApplication :: AppConfig -> IO () +makeAndServeApplication AppConfig{..} = do + putStrLn "Starting ABCI application..." + let nat :: forall a. Sem CoreEffs a -> IO a + nat = runCoreEffs _baseAppContext + application = makeApp handlersContext + middleware :: Middleware (Sem CoreEffs) + middleware = appEndo . fold $ + [ Endo Logger.mkLoggerM + ] + serveApp $ createIOApp nat (middleware application) diff --git a/hs-abci-docs/simple-storage/test/SimpleStorage/Test/E2ESpec.hs b/hs-abci-docs/simple-storage/test/SimpleStorage/Test/E2ESpec.hs new file mode 100644 index 00000000..6b13c38c --- /dev/null +++ b/hs-abci-docs/simple-storage/test/SimpleStorage/Test/E2ESpec.hs @@ -0,0 +1,126 @@ +module SimpleStorage.Test.E2ESpec (spec) where + +import Control.Monad.Reader (ReaderT, runReaderT) +import Data.Default.Class (def) +import Data.Int (Int32) +import Data.Proxy +import qualified Network.Tendermint.Client as RPC +import Servant.API ((:<|>) (..)) +import SimpleStorage.Application +import qualified SimpleStorage.Modules.SimpleStorage as SS +import System.Random (randomIO) +import qualified Tendermint.SDK.Application.Module as M +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import Tendermint.SDK.BaseApp.Query (QueryArgs (..), + QueryResult (..), + defaultQueryArgs) +import qualified Tendermint.SDK.Modules.Auth as Auth +import Tendermint.SDK.Types.Address (Address) +import Tendermint.Utils.Client (ClientConfig (..), + EmptyTxClient (..), + HasQueryClient (..), + HasTxClient (..), + QueryClientResponse (..), + TxClientResponse (..), + TxOpts (..), + defaultClientTxOpts) +import Tendermint.Utils.ClientUtils (assertQuery, assertTx, + ensureResponseCodes, + rpcConfig) +import Tendermint.Utils.User (User (..), + makeSignerFromUser, + makeUser) +import Test.Hspec + +spec :: Spec +spec = do + beforeAll (abs <$> randomIO :: IO Int32) $ + describe "SimpleStorage E2E - via hs-tendermint-client" $ do + + it "Can query /health to make sure the node is alive" $ \_ -> do + resp <- RPC.runTendermintM rpcConfig RPC.health + resp `shouldBe` RPC.ResultHealth + + it "Can submit a tx synchronously and make sure that the response code is 0 (success)" $ \c -> do + let txOpts = TxOpts + { txOptsGas = 0 + , txOptsSigner = makeSignerFromUser user1 + } + tx = SS.UpdateCountTx + { SS.updateCountTxUsername = "charles" + , SS.updateCountTxCount = c + } + resp <- assertTx . runTxClientM $ updateCount txOpts tx + ensureResponseCodes (0,0) resp + + it "can make sure the synchronous tx transaction worked and the count is now 4" $ \c -> do + resp <- assertQuery . RPC.runTendermintM rpcConfig $ + getCount defaultQueryArgs { queryArgsData = () } + let foundCount = queryResultData resp + foundCount `shouldBe` SS.Count c + +-------------------------------------------------------------------------------- +-- Query Client +-------------------------------------------------------------------------------- + +getCount + :: QueryArgs () + -> RPC.TendermintM (QueryClientResponse SS.Count) + +getAccount + :: QueryArgs Address + -> RPC.TendermintM (QueryClientResponse Auth.Account) + +getCount :<|> getAccount = + genClientQ (Proxy :: Proxy m) queryApiP def + where + queryApiP :: Proxy (M.ApplicationQ SimpleStorageModules) + queryApiP = Proxy + + +-------------------------------------------------------------------------------- +-- Tx Client +-------------------------------------------------------------------------------- + +txClientConfig :: ClientConfig +txClientConfig = + let getNonce addr = do + resp <- RPC.runTendermintM rpcConfig $ getAccount $ + defaultQueryArgs { queryArgsData = addr } + -- @NOTE: TxNonce should be +1 of accountNonce + case resp of + QueryError e -> + if appErrorCode e == 2 + then pure 1 + else error $ "Unknown nonce error: " <> show (appErrorMessage e) + QueryResponse QueryResult{queryResultData} -> + pure $ 1 + Auth.accountNonce queryResultData + + in ClientConfig + { clientGetNonce = getNonce + , clientRPC = rpcConfig + } + +type TxClientM = ReaderT ClientConfig IO + +runTxClientM :: TxClientM a -> IO a +runTxClientM m = runReaderT m txClientConfig + +updateCount + :: TxOpts + -> SS.UpdateCountTx + -> TxClientM (TxClientResponse () ()) + +updateCount :<|> EmptyTxClient = + genClientT (Proxy @TxClientM) txApiCP txApiDP defaultClientTxOpts + where + txApiCP :: Proxy (M.ApplicationC SimpleStorageModules) + txApiCP = Proxy + txApiDP :: Proxy (M.ApplicationD SimpleStorageModules) + txApiDP = Proxy + + +-------------------------------------------------------------------------------- + +user1 :: User +user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" diff --git a/hs-abci-docs/simple-storage/test/Spec.hs b/hs-abci-docs/simple-storage/test/Spec.hs new file mode 100644 index 00000000..fcb16768 --- /dev/null +++ b/hs-abci-docs/simple-storage/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} diff --git a/hs-abci-examples/nameservice/README.md b/hs-abci-examples/nameservice/README.md deleted file mode 100644 index e40d5f34..00000000 --- a/hs-abci-examples/nameservice/README.md +++ /dev/null @@ -1 +0,0 @@ -# nameservice diff --git a/hs-abci-examples/nameservice/app/Main.hs b/hs-abci-examples/nameservice/app/Main.hs deleted file mode 100644 index 1f30b888..00000000 --- a/hs-abci-examples/nameservice/app/Main.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Main where - -import Control.Exception (bracket) -import qualified Katip as K -import Nameservice.Application (makeAppConfig) -import Nameservice.Server (makeAndServeApplication) -import System.IO (stdout) -import Tendermint.SDK.Logger.Katip (LogConfig (..), mkLogConfig) - - -main :: IO () -main = do - logCfg <- mkLogConfig "dev" "nameservice" - handleScribe <- K.mkHandleScribe K.ColorIfTerminal stdout (K.permitItem K.DebugS) K.V2 - let mkLogEnv = K.registerScribe "stdout" handleScribe K.defaultScribeSettings (_logEnv logCfg) - bracket mkLogEnv K.closeScribes $ \le -> do - cfg <- makeAppConfig logCfg {_logEnv = le} - makeAndServeApplication cfg diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml deleted file mode 100644 index b1fcac0a..00000000 --- a/hs-abci-examples/nameservice/package.yaml +++ /dev/null @@ -1,83 +0,0 @@ -name: nameservice -version: 0.1.0.0 -github: "githubuser/nameservice" -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 - -default-extensions: - - DeriveGeneric - - NamedFieldPuns - - RecordWildCards - - RankNTypes - - TypeFamilies - - FlexibleContexts - - DataKinds - - TypeApplications - - OverloadedStrings - - PolyKinds - - GeneralizedNewtypeDeriving - - ScopedTypeVariables - - TupleSections - - LambdaCase - - GADTs - - TypeOperators - - FlexibleInstances - - MultiParamTypeClasses - - DefaultSignatures - - FunctionalDependencies - - TypeFamilyDependencies - - DeriveFunctor - - StandaloneDeriving - - ConstraintKinds - -dependencies: -- base >= 4.7 && < 5 -- exceptions -- hs-abci-extra -- hs-abci-sdk -- hs-abci-server -- hs-abci-types -- polysemy -- katip - -library: - source-dirs: src - exposed-modules: - - Nameservice.Application - - Nameservice.Server - -executables: - nameservice-exe: - main: Main.hs - source-dirs: app - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - nameservice - -tests: - nameservice-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - nameservice diff --git a/hs-abci-examples/nameservice/src/Lib.hs b/hs-abci-examples/nameservice/src/Lib.hs deleted file mode 100644 index d36ff271..00000000 --- a/hs-abci-examples/nameservice/src/Lib.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Lib - ( someFunc - ) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/hs-abci-examples/nameservice/src/Nameservice/Application.hs b/hs-abci-examples/nameservice/src/Nameservice/Application.hs deleted file mode 100644 index e1bc7a0c..00000000 --- a/hs-abci-examples/nameservice/src/Nameservice/Application.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -module Nameservice.Application - ( AppError(..) - , AppConfig(..) - , makeAppConfig - , Handler - , runHandler - ) where - -import Control.Exception (Exception) -import Control.Monad.Catch (throwM) -import Polysemy (Sem) -import Polysemy.Error (Error, runError) -import qualified Tendermint.SDK.BaseApp as BaseApp -import qualified Tendermint.SDK.Logger.Katip as KL - -data AppConfig = AppConfig - { baseAppContext :: BaseApp.Context - } - -makeAppConfig :: KL.LogConfig -> IO AppConfig -makeAppConfig logCfg = do - c <- BaseApp.makeContext logCfg - pure $ AppConfig { baseAppContext = c - } - --------------------------------------------------------------------------------- - -data AppError = AppError String deriving (Show) - -instance Exception AppError - -type EffR = - ( Error AppError - ': BaseApp.BaseApp - ) - -type Handler = Sem EffR - --- NOTE: this should probably go in the library -runHandler - :: AppConfig - -> Handler a - -> IO a -runHandler AppConfig{baseAppContext} m = do - eRes <- BaseApp.eval baseAppContext . - runError $ m - case eRes of - Left e -> throwM e - Right a -> pure a diff --git a/hs-abci-examples/nameservice/src/Nameservice/Server.hs b/hs-abci-examples/nameservice/src/Nameservice/Server.hs deleted file mode 100644 index c79d4462..00000000 --- a/hs-abci-examples/nameservice/src/Nameservice/Server.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Nameservice.Server (makeAndServeApplication) where - -import Data.Foldable (fold) -import Data.Monoid (Endo (..)) -import Data.Proxy -import Nameservice.Application (AppConfig, - AppError, - Handler, - runHandler) -import Network.ABCI.Server (serveApp) -import Network.ABCI.Server.App (Middleware) -import qualified Network.ABCI.Server.Middleware.RequestLogger as ReqLogger -import qualified Network.ABCI.Server.Middleware.ResponseLogger as ResLogger -import Tendermint.SDK.Application (MakeApplication (..), - createApplication) -import Tendermint.SDK.Router (QueryApplication, - serve) - -makeAndServeApplication :: AppConfig -> IO () -makeAndServeApplication cfg = undefined --- let serveRoutes :: QueryApplication Handler --- serveRoutes = serve (Proxy :: Proxy SS.Api) SS.server --- makeApplication :: MakeApplication Handler AppError --- makeApplication = MakeApplication --- { transformer = runHandler cfg --- , appErrorP = Proxy --- , app = simpleStorageApp serveRoutes --- , initialize = [SS.initialize] --- } --- putStrLn "Starting ABCI application..." --- application <- createApplication makeApplication --- serveApp =<< hookInMiddleware application --- where --- mkMiddleware :: IO (Middleware IO) --- mkMiddleware = do --- reqLogger <- ReqLogger.mkLogStdoutDev --- resLogger <- ResLogger.mkLogStdoutDev --- pure . appEndo . fold $ --- [ Endo reqLogger --- , Endo resLogger --- ] --- hookInMiddleware _app = do --- middleware <- mkMiddleware --- pure $ middleware _app diff --git a/hs-abci-examples/nameservice/test/Spec.hs b/hs-abci-examples/nameservice/test/Spec.hs deleted file mode 100644 index cd4753fc..00000000 --- a/hs-abci-examples/nameservice/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented" diff --git a/hs-abci-examples/simple-storage/Dockerfile b/hs-abci-examples/simple-storage/Dockerfile deleted file mode 100644 index 07be24ab..00000000 --- a/hs-abci-examples/simple-storage/Dockerfile +++ /dev/null @@ -1,21 +0,0 @@ -FROM haskell:8 - -RUN apt-get update && apt-get install --assume-yes protobuf-compiler - -# Install GHC. -WORKDIR /project -COPY ./stack.yaml /project -RUN stack setup && stack exec -- ghc --version - -# Install dependencies. -COPY hs-abci-types hs-abci-types/ -COPY hs-tendermint-client hs-tendermint-client/ -COPY hs-abci-server hs-abci-server/ -COPY hs-abci-extra hs-abci-extra/ -COPY hs-abci-sdk hs-abci-sdk/ -COPY hs-abci-examples/simple-storage simple-storage/ - -RUN stack build simple-storage --copy-bins --local-bin-path /usr/local/bin - -# Run project. -CMD /usr/local/bin/simple-storage diff --git a/hs-abci-examples/simple-storage/README.md b/hs-abci-examples/simple-storage/README.md deleted file mode 100644 index 1e8fd4ef..00000000 --- a/hs-abci-examples/simple-storage/README.md +++ /dev/null @@ -1,34 +0,0 @@ -# hs-abci-example - -The example application is meant to test all of the other hs-abci libraries and serve as a demo. -It's a simple application called **Simple Storage** that maintains a shared 32-byte integer and -allows users to update and query the count. - -## Running with Docker -There is a `docker-compose.yaml` file in this directory. If you use the `make` command from the project root - -```bash -> make deploy-simple-storage-docker -``` - -it will build an image for simple-storage and launch it in a docker network -with a tendermint-core node. The port for simple-storage is not exposed outside of the docker network -- -if you would like to submit transactions or query state you must do it using the tendermint RPC. - -## Running Locally -Assuming you have a [Tendermint v0.32.2 binary](https://github.com/tendermint/tendermint/releases/tag/v0.32.2) in your path, you can start a tendermint core node with - -```bash -> tendermint init -> tendermint node --consensus.create_empty_blocks=false -``` - -The `--consensus.create_empty_blocks=false` flag is helpful for keeping the logs from being polluted with empty blocks. You can then then start the example application using - -```bash -> make deploy-simple-storage-local -``` - -## Application Messages -The application uses a protobuf file to define its [transaction messages](https://github.com/f-o-a-m/hs-abci/blob/master/hs-abci-example/protos/simple-storage/messages.proto). Thus if you would like to post transactions to this application via RPC, you will need to first consume -this profobuf file. You can follow the pattern in the test suite using hs-tendermint-client. diff --git a/hs-abci-examples/simple-storage/app/Main.hs b/hs-abci-examples/simple-storage/app/Main.hs deleted file mode 100644 index 0183034f..00000000 --- a/hs-abci-examples/simple-storage/app/Main.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Main where - -import Control.Exception (bracket) -import qualified Katip as K -import SimpleStorage.Application (makeAppConfig) -import SimpleStorage.Server (makeAndServeApplication) -import System.IO (stdout) -import Tendermint.SDK.Logger.Katip (LogConfig (..), mkLogConfig) - - -main :: IO () -main = do - logCfg <- mkLogConfig "dev" "simple-storage" - handleScribe <- K.mkHandleScribe K.ColorIfTerminal stdout (K.permitItem K.DebugS) K.V2 - let mkLogEnv = K.registerScribe "stdout" handleScribe K.defaultScribeSettings (_logEnv logCfg) - bracket mkLogEnv K.closeScribes $ \le -> do - cfg <- makeAppConfig logCfg {_logEnv = le} - makeAndServeApplication cfg diff --git a/hs-abci-examples/simple-storage/docker-compose.yaml b/hs-abci-examples/simple-storage/docker-compose.yaml deleted file mode 100644 index 0be9dd09..00000000 --- a/hs-abci-examples/simple-storage/docker-compose.yaml +++ /dev/null @@ -1,25 +0,0 @@ -version: '3.7' -services: - tendermint-init: - image: tendermint/tendermint:v0.32.2 - command: init - volumes: - - /tmp:/tendermint - tendermint: - depends_on: - - tendermint-init - - simple_storage - image: tendermint/tendermint:v0.32.2 - command: node --proxy_app=tcp://simple_storage:26658 - volumes: - - /tmp:/tendermint - restart: always - ports: - - "26656-26657:26656-26657" - simple_storage: - build: - context: ../../. - dockerfile: hs-abci-examples/simple-storage/Dockerfile - restart: always - expose: - - "26658" diff --git a/hs-abci-examples/simple-storage/src/SimpleStorage/Application.hs b/hs-abci-examples/simple-storage/src/SimpleStorage/Application.hs deleted file mode 100644 index 11c7dbdb..00000000 --- a/hs-abci-examples/simple-storage/src/SimpleStorage/Application.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -module SimpleStorage.Application - ( AppError(..) - , AppConfig(..) - , makeAppConfig - , Handler - , runHandler - ) where - -import Control.Exception (Exception) -import Control.Monad.Catch (throwM) -import Polysemy (Sem) -import Polysemy.Error (Error, runError) -import SimpleStorage.Modules.SimpleStorage as SimpleStorage -import qualified Tendermint.SDK.BaseApp as BaseApp -import qualified Tendermint.SDK.Logger.Katip as KL - -data AppConfig = AppConfig - { baseAppContext :: BaseApp.Context - } - -makeAppConfig :: KL.LogConfig -> IO AppConfig -makeAppConfig logCfg = do - c <- BaseApp.makeContext logCfg - pure $ AppConfig { baseAppContext = c - } - --------------------------------------------------------------------------------- - -data AppError = AppError String deriving (Show) - -instance Exception AppError - -type EffR = - ( SimpleStorage - ': Error AppError - ': BaseApp.BaseApp - ) - -type Handler = Sem EffR - --- NOTE: this should probably go in the library -runHandler - :: AppConfig - -> Handler a - -> IO a -runHandler AppConfig{baseAppContext} m = do - eRes <- BaseApp.eval baseAppContext . - runError . - SimpleStorage.eval $ m - case eRes of - Left e -> throwM e - Right a -> pure a - diff --git a/hs-abci-examples/simple-storage/src/SimpleStorage/Handlers.hs b/hs-abci-examples/simple-storage/src/SimpleStorage/Handlers.hs deleted file mode 100644 index af3ef16a..00000000 --- a/hs-abci-examples/simple-storage/src/SimpleStorage/Handlers.hs +++ /dev/null @@ -1,107 +0,0 @@ -module SimpleStorage.Handlers where - -import Control.Lens (to, (&), (.~), (^.)) -import Data.ByteArray (convert) -import Data.Default.Class (def) -import Network.ABCI.Server.App (App (..), - MessageType (..), - Request (..), - Response (..)) -import qualified Network.ABCI.Types.Messages.Request as Req -import qualified Network.ABCI.Types.Messages.Response as Resp -import SimpleStorage.Application (Handler) -import SimpleStorage.Modules.SimpleStorage as SS -import SimpleStorage.Types (AppTxMessage (..), - UpdateCountTx (..), - decodeAppTxMessage) -import Tendermint.SDK.Application (defaultHandler) -import Tendermint.SDK.Events (withEventBuffer) -import Tendermint.SDK.Router (QueryApplication) - -echoH - :: Request 'MTEcho - -> Handler (Response 'MTEcho) -echoH (RequestEcho echo) = - pure . ResponseEcho $ def & Resp._echoMessage .~ echo ^. Req._echoMessage - -flushH - :: Request 'MTFlush - -> Handler (Response 'MTFlush) -flushH = defaultHandler - -infoH - :: Request 'MTInfo - -> Handler (Response 'MTInfo) -infoH = defaultHandler - -setOptionH - :: Request 'MTSetOption - -> Handler (Response 'MTSetOption) -setOptionH = defaultHandler - --- TODO: this one might be useful for initializing to 0 --- instead of doing that manually in code -initChainH - :: Request 'MTInitChain - -> Handler (Response 'MTInitChain) -initChainH = defaultHandler - -queryH - :: QueryApplication Handler - -> Request 'MTQuery - -> Handler (Response 'MTQuery) -queryH serveRoutes (RequestQuery query) = do - queryResp <- serveRoutes query - pure $ ResponseQuery queryResp - -beginBlockH - :: Request 'MTBeginBlock - -> Handler (Response 'MTBeginBlock) -beginBlockH = defaultHandler - --- only checks to see if the tx parses -checkTxH - :: Request 'MTCheckTx - -> Handler (Response 'MTCheckTx) -checkTxH (RequestCheckTx checkTx) = pure . ResponseCheckTx $ - case decodeAppTxMessage $ checkTx ^. Req._checkTxTx . to convert of - Left _ -> def & Resp._checkTxCode .~ 1 - Right (ATMUpdateCount _) -> def & Resp._checkTxCode .~ 0 - -deliverTxH - :: Request 'MTDeliverTx - -> Handler (Response 'MTDeliverTx) -deliverTxH (RequestDeliverTx deliverTx) = do - case decodeAppTxMessage $ deliverTx ^. Req._deliverTxTx . to convert of - Left _ -> return . ResponseDeliverTx $ - def & Resp._deliverTxCode .~ 1 - Right (ATMUpdateCount updateCountTx) -> do - let count = SS.Count $ updateCountTxCount updateCountTx - events <- withEventBuffer $ putCount count - return $ ResponseDeliverTx $ - def & Resp._deliverTxCode .~ 0 - & Resp._deliverTxEvents .~ events - -endBlockH - :: Request 'MTEndBlock - -> Handler (Response 'MTEndBlock) -endBlockH = defaultHandler - -commitH - :: Request 'MTCommit - -> Handler (Response 'MTCommit) -commitH = defaultHandler - -simpleStorageApp :: QueryApplication Handler -> App Handler -simpleStorageApp serveRoutes = App $ \case - msg@(RequestEcho _) -> echoH msg - msg@(RequestFlush _) -> flushH msg - msg@(RequestInfo _) -> infoH msg - msg@(RequestSetOption _) -> setOptionH msg - msg@(RequestInitChain _) -> initChainH msg - msg@(RequestQuery _) -> queryH serveRoutes msg - msg@(RequestBeginBlock _) -> beginBlockH msg - msg@(RequestCheckTx _) -> checkTxH msg - msg@(RequestDeliverTx _) -> deliverTxH msg - msg@(RequestEndBlock _) -> endBlockH msg - msg@(RequestCommit _) -> commitH msg diff --git a/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage.hs b/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage.hs deleted file mode 100644 index ebabcdb9..00000000 --- a/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module SimpleStorage.Modules.SimpleStorage - ( - -- * Component - SimpleStorage - , putCount - , getCount - - , Api - , server - , eval - , initialize - - -- * Store - , CountStoreContents - - -- * Types - , Count(..) - , CountKey(..) - - -- * Events - , CountSet - - ) where - -import Control.Lens (iso) -import Crypto.Hash (SHA256 (..), hashWith) -import qualified Data.Binary as Binary -import Data.ByteArray (convert) -import Data.ByteString (ByteString) -import Data.Int (Int32) -import Data.Maybe (fromJust) -import Data.Proxy -import Data.String.Conversions (cs) -import Polysemy (Member, Sem, interpret, makeSem) -import Polysemy.Output (Output) -import Servant.API ((:>)) -import Tendermint.SDK.BaseApp (HasBaseApp) -import Tendermint.SDK.Codec (HasCodec (..)) -import qualified Tendermint.SDK.Events as Events -import Tendermint.SDK.Router (EncodeQueryResult, FromQueryData, - Queryable (..), RouteT) -import Tendermint.SDK.Store (HasKey (..), RawStore, Root, get, - put) -import Tendermint.SDK.StoreQueries (QueryApi, storeQueryHandlers) - --------------------------------------------------------------------------------- --- Types --------------------------------------------------------------------------------- - -newtype Count = Count Int32 deriving (Eq, Show) - -data CountKey = CountKey - -instance HasCodec Count where - encode (Count c) = cs . Binary.encode $ c - decode = Right . Count . Binary.decode . cs - -instance HasKey Count where - type Key Count = CountKey - rawKey = iso (\_ -> cs countKey) (const CountKey) - where - countKey :: ByteString - countKey = convert . hashWith SHA256 . cs @_ @ByteString $ ("count" :: String) - -instance FromQueryData CountKey - -instance EncodeQueryResult Count - -instance Queryable Count where - type Name Count = "count" - --------------------------------------------------------------------------------- --- Events --------------------------------------------------------------------------------- - -data CountSet = CountSet { newCount :: Count } - -instance Events.IsEvent CountSet where - makeEventType _ = "count_set" - makeEventData CountSet{newCount} = [("new_count", encode newCount)] - --------------------------------------------------------------------------------- --- SimpleStorage Module --------------------------------------------------------------------------------- - -data SimpleStorage m a where - PutCount :: Count -> SimpleStorage m () - GetCount :: SimpleStorage m Count - -makeSem ''SimpleStorage - -eval - :: forall r. - HasBaseApp r - => forall a. (Sem (SimpleStorage ': r) a -> Sem r a) -eval = interpret (\case - PutCount count -> do - put CountKey count - Events.emit $ CountSet count - - GetCount -> fromJust <$> get (undefined :: Root) CountKey - ) - -initialize - :: HasBaseApp r - => Member (Output Events.Event) r - => Sem r () -initialize = eval $ do - putCount (Count 0) - --------------------------------------------------------------------------------- --- Query Api --------------------------------------------------------------------------------- - -type CountStoreContents = '[Count] - -type Api = "simple_storage" :> QueryApi CountStoreContents - -server :: Member RawStore r => RouteT Api (Sem r) -server = storeQueryHandlers (Proxy :: Proxy CountStoreContents) (Proxy :: Proxy (Sem r)) diff --git a/hs-abci-examples/simple-storage/src/SimpleStorage/Server.hs b/hs-abci-examples/simple-storage/src/SimpleStorage/Server.hs deleted file mode 100644 index 887bbff2..00000000 --- a/hs-abci-examples/simple-storage/src/SimpleStorage/Server.hs +++ /dev/null @@ -1,46 +0,0 @@ -module SimpleStorage.Server (makeAndServeApplication) where - -import Data.Foldable (fold) -import Data.Monoid (Endo (..)) -import Data.Proxy -import Network.ABCI.Server (serveApp) -import Network.ABCI.Server.App (Middleware) -import qualified Network.ABCI.Server.Middleware.RequestLogger as ReqLogger -import qualified Network.ABCI.Server.Middleware.ResponseLogger as ResLogger -import SimpleStorage.Application (AppConfig, - AppError, - Handler, - runHandler) -import SimpleStorage.Handlers (simpleStorageApp) -import qualified SimpleStorage.Modules.SimpleStorage as SS -import Tendermint.SDK.Application (MakeApplication (..), - createApplication) -import Tendermint.SDK.Router (QueryApplication, - serve) - -makeAndServeApplication :: AppConfig -> IO () -makeAndServeApplication cfg = do - let serveRoutes :: QueryApplication Handler - serveRoutes = serve (Proxy :: Proxy SS.Api) SS.server - makeApplication :: MakeApplication Handler AppError - makeApplication = MakeApplication - { transformer = runHandler cfg - , appErrorP = Proxy - , app = simpleStorageApp serveRoutes - , initialize = [SS.initialize] - } - putStrLn "Starting ABCI application..." - application <- createApplication makeApplication - serveApp =<< hookInMiddleware application - where - mkMiddleware :: IO (Middleware IO) - mkMiddleware = do - reqLogger <- ReqLogger.mkLogStdoutDev - resLogger <- ResLogger.mkLogStdoutDev - pure . appEndo . fold $ - [ Endo reqLogger - , Endo resLogger - ] - hookInMiddleware _app = do - middleware <- mkMiddleware - pure $ middleware _app diff --git a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs b/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs deleted file mode 100644 index cdeb1e37..00000000 --- a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs +++ /dev/null @@ -1,78 +0,0 @@ -module SimpleStorage.Test.E2ESpec where - -import Control.Lens (to, (^.)) -import Data.Aeson (ToJSON) -import Data.Aeson.Encode.Pretty (encodePretty) -import Data.Binary (decode, encode) -import Data.ByteArray.Base64String (Base64String) -import qualified Data.ByteArray.Base64String as Base64 -import qualified Data.ByteArray.HexString as Hex -import qualified Data.ByteString.Lazy as LBS -import Data.Default.Class (def) -import Data.Int (Int32) -import Data.String.Conversions (cs) -import qualified Network.ABCI.Types.Messages.Response as Resp -import qualified Network.ABCI.Types.Messages.Response as Response -import qualified Network.Tendermint.Client as RPC -import qualified SimpleStorage.Modules.SimpleStorage as SS -import SimpleStorage.Types (AppTxMessage (..), - UpdateCountTx (..), - encodeAppTxMessage) -import Tendermint.SDK.Store (rawKey) -import Test.Hspec - - -spec :: Spec -spec = do - describe "SimpleStorage E2E - via hs-tendermint-client" $ do - - it "Can query /health to make sure the node is alive" $ do - resp <- runRPC RPC.health - resp `shouldBe` RPC.ResultHealth - - it "Can query the count and make sure its initialized to 0" $ do - let queryReq = - def { RPC.requestABCIQueryPath = Just "simple_storage/count" - , RPC.requestABCIQueryData = SS.CountKey ^. rawKey . to Hex.fromBytes - - } - queryResp <- fmap RPC.resultABCIQueryResponse . runRPC $ - RPC.abciQuery queryReq - let foundCount = queryResp ^. Resp._queryValue . to decodeCount - foundCount `shouldBe` 0 - - it "Can submit a tx synchronously and make sure that the response code is 0 (success)" $ do - let tx = UpdateCountTx "irakli" 4 - txReq = RPC.RequestBroadcastTxCommit - { RPC.requestBroadcastTxCommitTx = Base64.fromBytes . encodeAppTxMessage $ ATMUpdateCount tx - } - deliverResp <- fmap RPC.resultBroadcastTxCommitDeliverTx . runRPC $ RPC.broadcastTxCommit txReq - let deliverRespCode = deliverResp ^. Response._deliverTxCode - deliverRespCode `shouldBe` 0 - - it "can make sure the synchronous tx transaction worked and the count is now 4" $ do - let queryReq = - def { RPC.requestABCIQueryPath = Just "simple_storage/count" - , RPC.requestABCIQueryData = SS.CountKey ^. rawKey . to Hex.fromBytes - } - queryResp <- fmap RPC.resultABCIQueryResponse . runRPC $ - RPC.abciQuery queryReq - let foundCount = queryResp ^. Resp._queryValue . to decodeCount - foundCount `shouldBe` 4 - - -encodeCount :: Int32 -> Base64String -encodeCount = Base64.fromBytes . LBS.toStrict . encode - -decodeCount :: Base64String -> Int32 -decodeCount = decode . LBS.fromStrict . Base64.toBytes - -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") diff --git a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/HandlersSpec.hs b/hs-abci-examples/simple-storage/test/SimpleStorage/Test/HandlersSpec.hs deleted file mode 100644 index d12610ac..00000000 --- a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/HandlersSpec.hs +++ /dev/null @@ -1,68 +0,0 @@ -module SimpleStorage.Test.HandlersSpec where - -import Control.Lens (to, (&), (.~), (^.)) -import Control.Lens.Wrapped (_Unwrapped', _Wrapped') -import Data.Binary (decode, encode) -import Data.ByteArray.Base64String (Base64String) -import qualified Data.ByteArray.Base64String as Base64 -import qualified Data.ByteString.Lazy as LBS -import Data.Int (Int32) -import Data.ProtoLens (defMessage) -import Data.ProtoLens.Encoding (encodeMessage) -import Data.Proxy -import Data.Text (pack) -import Network.ABCI.Server.App (Request (..), - Response (..)) -import qualified Network.ABCI.Types.Messages.Request as Req -import qualified Network.ABCI.Types.Messages.Response as Resp -import SimpleStorage.Application (AppConfig, makeAppConfig, - runHandler) -import SimpleStorage.Handlers (deliverTxH, queryH) -import qualified SimpleStorage.Modules.SimpleStorage as SS -import SimpleStorage.Types (UpdateCountTx (..)) -import Tendermint.SDK.Logger.Katip -import Tendermint.SDK.Router (serve) -import Tendermint.SDK.Store (rawKey) -import Test.Hspec -import Test.QuickCheck - - -spec :: Spec -spec = beforeAll beforeAction $ do - describe "SimpleStorage E2E - via handlers" $ do - let serveRoutes = serve (Proxy :: Proxy SS.Api) SS.server - it "Can update count and make sure it increments" $ \cfg -> do - genUsername <- pack . getPrintableString <$> generate arbitrary - genCount <- abs <$> generate arbitrary - let - handleDeliver = runHandler cfg . deliverTxH - handleQuery = runHandler cfg . queryH serveRoutes - updateTx = (defMessage ^. _Unwrapped') { updateCountTxUsername = genUsername - , updateCountTxCount = genCount - } - encodedUpdateTx = Base64.fromBytes $ encodeMessage (updateTx ^. _Wrapped') - (ResponseDeliverTx deliverResp) <- handleDeliver - ( RequestDeliverTx - $ defMessage - ^. _Unwrapped' - & Req._deliverTxTx - .~ encodedUpdateTx - ) - (deliverResp ^. Resp._deliverTxCode) `shouldBe` 0 - -- TODO: check for logs - (ResponseQuery queryResp) <- handleQuery - ( RequestQuery $ defMessage ^. _Unwrapped' - & Req._queryPath .~ "simple_storage/count" - & Req._queryData .~ SS.CountKey ^. rawKey . to Base64.fromBytes - ) - let foundCount = queryResp ^. Resp._queryValue . to decodeCount - foundCount `shouldBe` genCount - -beforeAction :: IO AppConfig -beforeAction = mkLogConfig "handler-spec" "SimpleStorage" >>= makeAppConfig - -encodeCount :: Int32 -> Base64String -encodeCount = Base64.fromBytes . LBS.toStrict . encode - -decodeCount :: Base64String -> Int32 -decodeCount = decode . LBS.fromStrict . Base64.toBytes diff --git a/hs-abci-extra/README.md b/hs-abci-extra/README.md index 6005d94e..589cb793 100644 --- a/hs-abci-extra/README.md +++ b/hs-abci-extra/README.md @@ -4,4 +4,4 @@ The goal here is to provide common features and example middleware implementatio ## Example using middleware -There is a small example using the RequestLogger middleware [here](https://github.com/f-o-a-m/hs-abci/tree/master/hs-abci-example). +There is a small example using the Logger middleware [here](https://github.com/f-o-a-m/kepler/tree/master/hs-abci-docs/simple-storage). diff --git a/hs-abci-extra/package.yaml b/hs-abci-extra/package.yaml index cd752d08..48c320e6 100644 --- a/hs-abci-extra/package.yaml +++ b/hs-abci-extra/package.yaml @@ -1,35 +1,19 @@ name: hs-abci-extra version: 0.1.0.0 -github: "https://github.com/f-o-a-m/hs-abci-server" -license: BSD3 -author: "Author name here" -maintainer: "example@example.com" -copyright: "2019 Author name here" +github: "https://github.com/f-o-a-m/kepler/hs-abci-server" +license: Apache +author: "Martin Allen" +maintainer: "martin@foam.space" +copyright: "2020 Martin Allen" extra-source-files: - README.md - ChangeLog.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 +description: Please see the README on GitHub at dependencies: - base >= 4.7 && < 5 -- katip -- hs-abci-server -- aeson -- aeson-casing -- unordered-containers -- memory -- text -- lens -- bytestring default-extensions: - NamedFieldPuns @@ -48,3 +32,21 @@ default-extensions: library: source-dirs: src + dependencies: + - aeson + - containers + - katip + - hs-abci-server + - hs-abci-types + - prometheus + - string-conversions + - time + - transformers + ghc-options: + - -Werror + - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wredundant-constraints diff --git a/hs-abci-extra/src/Network/ABCI/Server/Middleware/Logger.hs b/hs-abci-extra/src/Network/ABCI/Server/Middleware/Logger.hs new file mode 100644 index 00000000..31817203 --- /dev/null +++ b/hs-abci-extra/src/Network/ABCI/Server/Middleware/Logger.hs @@ -0,0 +1,121 @@ +module Network.ABCI.Server.Middleware.Logger + ( -- * Custom Loggers + mkLogger + , mkLoggerM + ) where + +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (lift) +import qualified Data.Aeson as A +import Data.ByteArray.HexString (HexString) +import Data.String (fromString) +import Katip +import Network.ABCI.Server.App (App (..), MessageType, Middleware, + Request (..), Response (..), + demoteRequestType, hashRequest, + msgTypeKey, transformApp) + +--------------------------------------------------------------------------- +-- Types +--------------------------------------------------------------------------- +-- | Loggable newtype wrapper +newtype Loggable a = Loggable a + +instance ToObject (Loggable (Request (t :: MessageType))) where + toObject (Loggable v) = case A.toJSON v of + A.Object o -> o + _ -> error "Contract violation: `toJSON` of any `Request t` must result with json object" + +instance LogItem (Loggable (Request (t :: MessageType))) where + payloadKeys V3 _ = AllKeys + payloadKeys _ _ = SomeKeys ["type"] + +instance ToObject (Loggable (Response (t :: MessageType))) where + toObject (Loggable v) = case A.toJSON v of + A.Object o -> o + _ -> error "Contract violation: `toJSON` of any `Response t` must result with json object" + +instance LogItem (Loggable (Response (t :: MessageType))) where + payloadKeys V3 _ = AllKeys + payloadKeys _ _ = SomeKeys ["type"] + +--------------------------------------------------------------------------- +-- mkLogger +--------------------------------------------------------------------------- +-- | Logger middleware for ABCI messages with custom 'Katip.LogEnv' +-- and 'Katip.Namespace'. This method makes it easy use various scribes such as +-- . +mkLogger + :: MonadIO m + => LogEnv + -> Namespace + -> Middleware m +mkLogger le ns = + transformApp (runKatipContextT le () ns) . mkLoggerM . transformApp lift + +--------------------------------------------------------------------------- +-- mkLoggerM +--------------------------------------------------------------------------- +-- | Logger middleware for ABCI messages in app with KatipContext. +-- Great for `App m` with a `KatipContext` instance. +mkLoggerM + :: KatipContext m + => Middleware m +mkLoggerM (App app) = App $ \ req -> do + let globalContext = GlobalMessageContext + { messageHash = hashRequest req + , messageType = demoteRequestType req + } + katipAddContext globalContext $ do + katipAddNamespace (fromString "server") $ + logRequest req + resp <- katipAddNamespace (fromString "application") $ + app req + katipAddNamespace (fromString "server") $ + logResponse resp + return resp + +--------------------------------------------------------------------------- +-- Common +--------------------------------------------------------------------------- + +data GlobalMessageContext = GlobalMessageContext + { messageHash :: HexString + , messageType :: MessageType + } + +instance A.ToJSON GlobalMessageContext where + toJSON GlobalMessageContext {..} = + A.object [ "message_type" A..= msgTypeKey messageType + , "message_hash" A..= messageHash + ] + +instance ToObject GlobalMessageContext + +instance LogItem GlobalMessageContext where + payloadKeys _ _ = AllKeys + +-- | Request logger function. +logRequest + :: KatipContext m + => Request t + -> m () +logRequest req = katipAddContext (Loggable req) $ + logFM logLevel "Request Received" + where + logLevel = case req of + RequestFlush _ -> DebugS + RequestEcho _ -> DebugS + _ -> InfoS + +logResponse + :: KatipContext m + => Response t + -> m () +logResponse resp = katipAddContext (Loggable resp) $ + logFM logLevel "Response Sent" + where + logLevel = case resp of + ResponseFlush _ -> DebugS + ResponseEcho _ -> DebugS + _ -> InfoS diff --git a/hs-abci-extra/src/Network/ABCI/Server/Middleware/Metrics.hs b/hs-abci-extra/src/Network/ABCI/Server/Middleware/Metrics.hs new file mode 100644 index 00000000..465b146f --- /dev/null +++ b/hs-abci-extra/src/Network/ABCI/Server/Middleware/Metrics.hs @@ -0,0 +1,126 @@ +module Network.ABCI.Server.Middleware.Metrics + ( defaultBuckets + , mkMetricsMiddleware + ) where + +import Control.Monad (forM_) +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.IORef as Ref +import qualified Data.Map.Strict as Map +import Data.String.Conversions (cs) +import Data.Time (diffUTCTime, + getCurrentTime) +import Network.ABCI.Server.App (App (..), + MessageType (..), + Middleware, + demoteRequestType, + msgTypeKey) +import qualified System.Metrics.Prometheus.Concurrent.Registry as Registry +import qualified System.Metrics.Prometheus.Metric.Counter as Counter +import qualified System.Metrics.Prometheus.Metric.Histogram as Histogram +import qualified System.Metrics.Prometheus.MetricId as MetricId + +--------------------------------------------------------------------------- +-- mkMetrics +--------------------------------------------------------------------------- +-- | Metrics logger middleware for ABCI server already within the KatipContext. +-- Great for `App m` with a `KatipContext` instance. + +mkMetricsMiddleware + :: MonadIO m + => [Histogram.UpperBound] + -> Registry.Registry + -> IO (Middleware m) +mkMetricsMiddleware buckets registry = do + Config{..} <- makeConfig buckets registry + return $ \(App app) -> App $ \ req -> do + startTime <- liftIO getCurrentTime + res <- app req + endTime <- liftIO getCurrentTime + let msgType = demoteRequestType req + duration = realToFrac $ diffUTCTime endTime startTime + liftIO $ do + incRequestCounter cfgCounterMap msgType + addToHistogram cfgHistogramMap msgType duration + pure res + where + + incRequestCounter counterMapRef msgType = do + counter <- do + counterMap <- Ref.readIORef counterMapRef + case Map.lookup msgType counterMap of + Nothing -> error $ "Impossible missing counter for " <> msgTypeKey msgType + Just c -> return c + Counter.inc counter + + addToHistogram histogramMapRef msgType duration = do + histogram <- do + histMap <- Ref.readIORef histogramMapRef + case Map.lookup msgType histMap of + Nothing -> error $ "Impossible missing histogram for " <> msgTypeKey msgType + Just c -> return c + Histogram.observe duration histogram + +data Config = Config + { cfgRegistry :: Registry.Registry + , cfgHistogramBuckets :: [Histogram.UpperBound] + , cfgCounterMap :: Ref.IORef (Map.Map MessageType Counter.Counter) + , cfgHistogramMap :: Ref.IORef (Map.Map MessageType Histogram.Histogram) + } + +makeConfig + :: [Histogram.UpperBound] + -> Registry.Registry + -> IO Config +makeConfig bounds registry = do + counterMap <- Ref.newIORef Map.empty + histMap <- Ref.newIORef Map.empty + let cfg = Config + { cfgRegistry = registry + , cfgHistogramBuckets = bounds + , cfgCounterMap = counterMap + , cfgHistogramMap = histMap + } + registerMetrics cfg + return cfg + +registerMetrics + :: Config + -> IO () +registerMetrics Config{..} = do + registerHistograms cfgHistogramBuckets cfgRegistry cfgHistogramMap + registerCounters cfgRegistry cfgCounterMap + where + + registerHistograms + :: [Histogram.UpperBound] + -> Registry.Registry + -> Ref.IORef (Map.Map MessageType Histogram.Histogram) + -> IO () + registerHistograms buckets registry histRef = + let histName = "abci_request_duration_seconds" + in forM_ [MTEcho .. MTCommit] $ \messageType -> do + let labels = MetricId.Labels . Map.fromList $ + [ ("message_type", cs $ msgTypeKey messageType) + ] + hist <- Registry.registerHistogram histName labels buckets registry + Ref.modifyIORef' histRef (Map.insert messageType hist) + + + registerCounters + :: Registry.Registry + -> Ref.IORef (Map.Map MessageType Counter.Counter) + -> IO () + registerCounters registry counterRef = + let counterName = "abci_request_total" + in forM_ [MTEcho .. MTCommit] $ \messageType -> do + let labels = MetricId.Labels . Map.fromList $ + [ ("message_type", cs $ msgTypeKey messageType) + ] + counter <- Registry.registerCounter counterName labels registry + Ref.modifyIORef' counterRef (Map.insert messageType counter) + +-- buckets with upper bounds [0.005, 0.01, 0.015 ... 5.0] +-- measured in seconds +defaultBuckets :: [Histogram.UpperBound] +defaultBuckets = [0.0001, 0.0005, 0.001, 0.005, 0.01, 0.05, 0.1, 0.5, 1.0, 5.0, 10.0] diff --git a/hs-abci-extra/src/Network/ABCI/Server/Middleware/RequestLogger.hs b/hs-abci-extra/src/Network/ABCI/Server/Middleware/RequestLogger.hs deleted file mode 100644 index 28263afd..00000000 --- a/hs-abci-extra/src/Network/ABCI/Server/Middleware/RequestLogger.hs +++ /dev/null @@ -1,83 +0,0 @@ -module Network.ABCI.Server.Middleware.RequestLogger - ( -- * Basic stdout logging - mkLogStdout - , mkLogStdoutDev - -- * Custom Loggers - , mkRequestLogger - , mkRequestLoggerM - ) where -import Control.Lens (at, (?~)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Data.Aeson as A -import qualified Data.HashMap.Strict as H -import Data.Text (Text) -import Katip -import Network.ABCI.Server.App (App (..), MessageType, Middleware, - Request (..)) -import System.IO (stdout) ---------------------------------------------------------------------------- --- Types ---------------------------------------------------------------------------- --- | Loggable newtype wrapper -newtype Loggable a = Loggable a - -instance ToObject (Loggable (Request (t :: MessageType))) where - toObject (Loggable v) = case A.toJSON v of - A.Object o -> o - _ -> error "Contract violation: `toJSON` of any `Request t` must result with json object" - -instance LogItem (Loggable (Request (t :: MessageType))) where - payloadKeys V0 _ = SomeKeys ["type"] - payloadKeys _ _ = AllKeys - ---------------------------------------------------------------------------- --- mkLogStdout --------------------------------------------------------------------------- --- | Creates a production request logger as middleware for ABCI requests. --- Uses lowest possible verbosity. -mkLogStdout :: (MonadIO m) => m (Middleware m) -mkLogStdout = do - handleScribe <- liftIO $ mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V0 - le <- liftIO (registerScribe "stdout" handleScribe defaultScribeSettings - =<< initLogEnv "ABCI" "production") - let ns = "Server" - pure $ mkRequestLogger le ns - ---------------------------------------------------------------------------- --- mkLogStdoutDev --------------------------------------------------------------------------- --- | Creates a request logger as middleware for ABCI requests. --- Uses highest possible verbosity. -mkLogStdoutDev :: (MonadIO m) => m (Middleware m) -mkLogStdoutDev = do - handleScribe <- liftIO $ mkHandleScribe ColorIfTerminal stdout (permitItem DebugS) V3 - le <- liftIO (registerScribe "stdout" handleScribe defaultScribeSettings - =<< initLogEnv "ABCI" "development") - let ns = "Server" - pure $ mkRequestLogger le ns - ---------------------------------------------------------------------------- --- mkRequestLogger ---------------------------------------------------------------------------- --- | Request logger middleware for ABCI requests with custom 'Katip.LogEnv' --- and 'Katip.Namespace'. This method makes it easy use various scribes such as --- . -mkRequestLogger :: (MonadIO m) => LogEnv -> Namespace -> Middleware m -mkRequestLogger le ns (App app) = App $ \ req -> do - runKatipContextT le () ns $ logRequest req - app req - ---------------------------------------------------------------------------- --- mkRequestLoggerM ---------------------------------------------------------------------------- --- | Request logger middleware for ABCI requests in app with KatipContext. --- Great for `App m` with a `KatipContext` instance. -mkRequestLoggerM :: (KatipContext m) => Middleware m -mkRequestLoggerM (App app) = App $ \ req -> logRequest req >> app req - ---------------------------------------------------------------------------- --- Common ---------------------------------------------------------------------------- --- | Request logger function. -logRequest :: (KatipContext m) => Request t -> m () -logRequest req = katipAddContext (Loggable req) $ logFM InfoS "Request Received" diff --git a/hs-abci-extra/src/Network/ABCI/Server/Middleware/ResponseLogger.hs b/hs-abci-extra/src/Network/ABCI/Server/Middleware/ResponseLogger.hs deleted file mode 100644 index 1a50fad4..00000000 --- a/hs-abci-extra/src/Network/ABCI/Server/Middleware/ResponseLogger.hs +++ /dev/null @@ -1,87 +0,0 @@ -module Network.ABCI.Server.Middleware.ResponseLogger - ( -- * Basic stdout logging - mkLogStdout - , mkLogStdoutDev - -- * Custom Loggers - , mkResponseLogger - , mkResponseLoggerM - ) where -import Control.Lens (at, (?~)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Data.Aeson as A -import qualified Data.HashMap.Strict as H -import Data.Text (Text) -import Katip -import Network.ABCI.Server.App (App (..), MessageType, Middleware, - Response (..)) -import System.IO (stdout) ---------------------------------------------------------------------------- --- Types ---------------------------------------------------------------------------- --- | Loggable newtype wrapper -newtype Loggable a = Loggable a - -instance ToObject (Loggable (Response (t :: MessageType))) where - toObject (Loggable v) = case A.toJSON v of - A.Object o -> o - _ -> error "Contract violation: `toJSON` of any `Response t` must result with json object" - -instance LogItem (Loggable (Response (t :: MessageType))) where - payloadKeys V0 _ = SomeKeys ["type"] - payloadKeys _ _ = AllKeys - ---------------------------------------------------------------------------- --- mkLogStdout --------------------------------------------------------------------------- --- | Creates a production request logger as middleware for ABCI requests. --- Uses Lowest possible verbosity. -mkLogStdout :: (MonadIO m) => m (Middleware m) -mkLogStdout = do - handleScribe <- liftIO $ mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V0 - le <- liftIO (registerScribe "stdout" handleScribe defaultScribeSettings - =<< initLogEnv "ABCI" "production") - let ns = "Server" - pure $ mkResponseLogger le ns - ---------------------------------------------------------------------------- --- mkLogStdoutDev --------------------------------------------------------------------------- --- | Creates a request logger as middleware for ABCI requests. --- Uses highest possible verbosity. -mkLogStdoutDev :: (MonadIO m) => m (Middleware m) -mkLogStdoutDev = do - handleScribe <- liftIO $ mkHandleScribe ColorIfTerminal stdout (permitItem DebugS) V3 - le <- liftIO (registerScribe "stdout" handleScribe defaultScribeSettings - =<< initLogEnv "ABCI" "development") - let ns = "Server" - pure $ mkResponseLogger le ns - ---------------------------------------------------------------------------- --- mkResponseLogger ---------------------------------------------------------------------------- --- | Response logger middleware for ABCI requests with custom 'Katip.LogEnv' --- and 'Katip.Namespace'. This method makes it easy use various scribes such as --- . -mkResponseLogger :: (MonadIO m) => LogEnv -> Namespace -> Middleware m -mkResponseLogger le ns (App app) = App $ \ req -> do - res <- app req - runKatipContextT le () ns $ logResponse res - pure res - ---------------------------------------------------------------------------- --- mkResponseLoggerM ---------------------------------------------------------------------------- --- | Response logger middleware for ABCI requests in app with KatipContext. --- Great for `App m` with a `KatipContext` instance. -mkResponseLoggerM :: (KatipContext m) => Middleware m -mkResponseLoggerM (App app) = App $ \ req -> do - res <- app req - logResponse res - pure res - ---------------------------------------------------------------------------- --- Common ---------------------------------------------------------------------------- --- | Response logger function. -logResponse :: (KatipContext m) => Response t -> m () -logResponse req = katipAddContext (Loggable req) $ logFM InfoS "Response Received" diff --git a/hs-abci-sdk/README.md b/hs-abci-sdk/README.md new file mode 100644 index 00000000..894308fc --- /dev/null +++ b/hs-abci-sdk/README.md @@ -0,0 +1,36 @@ +# hs-abci-sdk + +## Introduction +This package lays out an SDK for rapidly developing blockchain applications in haskell backed by the Tendermint replication engine. It relies on the [hs-abci-server](https://github.com/f-o-a-m/kepler/tree/master/hs-abci-server) to communicate to Tendermint core via the ABCI protocol. + +## Requirements + +### libsecp256k +You will need to have the `libsecp256k` `C` library installed on your machine to build this package, or anything depedning on it, as it is not statically linked to its haskell wrapper. You +can find instructions for this [here](https://github.com/f-o-a-m/kepler/tree/master/INSTALL.md#libsecp256k1). + +## Architecture + +The SDK makes heavy use of an effects system to separate different components of your application. Specifically it is using the [polysemy](https://hackage.haskell.org/package/polysemy) effects library in its implementation. + +### BaseApp Effects + +`BaseApp` is the set of effects that the SDK is written in. Every other module developed during the course of application development must eventually be compiled to this set of effects. As of now, `BaseApp` effects allows for things like access to storage, error handling, metrics logging, console logging, etc. + +### Application Specific Effects + +It is assumed that you will want to define your own application specific effects, for example +in the way that the [Nameservice example app](https://github.com/f-o-a-m/kepler/tree/master/hs-abci-docs/nameservice) does. Application specific effects are useful for defining module level storage capabilities, custom errors and handling, and explicit dependencies on other modules' effects. There are many hooks in this SDK to facilitate compiling application effects +to `BaseApp`. For examples, see `Tendermint.SDK.Errors` or `Tendermint.SDK.Store`. + +### Core Effects + +The `CoreEffects` system is what's used to interpret `BaseApp` to `IO`, which is where the application must end up at eventually. It provides things like a logging context (e.g. `Katip`), +a context for executing database transactions, and various buffers and vars to facilitate ABCI message handling. + +## Example Applications +There are currenlty two official example applications + +1. [Simple Storage](https://github.com/f-o-a-m/kepler/tree/master/hs-abci-docs/simple-storage): This is a trivial application developed around a single module that allows get and set operations on an integer value. + +2. [Nameservice](https://github.com/f-o-a-m/kepler/tree/master/hs-abci-docs/nameservice): This is an implementation of the official example application for the [cosmos-sdk](https://github.com/cosmos/sdk-tutorials/tree/master/nameservice). It is built to support a simple name resolution market place. diff --git a/hs-abci-sdk/Setup.hs b/hs-abci-sdk/Setup.hs index 44671092..c81784fa 100644 --- a/hs-abci-sdk/Setup.hs +++ b/hs-abci-sdk/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Data.ProtoLens.Setup +main = defaultMainGeneratingProtos "protos" diff --git a/hs-abci-sdk/package.yaml b/hs-abci-sdk/package.yaml index c9ed27fd..ae5cb5df 100644 --- a/hs-abci-sdk/package.yaml +++ b/hs-abci-sdk/package.yaml @@ -1,12 +1,21 @@ name: hs-abci-sdk version: 0.1.0.0 -github: "f-o-a-m/hs-abci/hs-abci-sdk" +github: "f-o-a-m/kepler/hs-abci-sdk" license: Apache author: Martin Allen maintainer: "martin@foam.space" -copyright: "2019 Martin Allen" +copyright: "2020 Martin Allen" -description: Please see the README on GitHub at +description: Please see the README on GitHub at + +extra-source-files: +- protos/**/*.proto + +custom-setup: + dependencies: + - base + - Cabal + - proto-lens-setup default-extensions: - DeriveGeneric @@ -33,68 +42,135 @@ default-extensions: - DeriveFunctor - StandaloneDeriving - ConstraintKinds - - -dependencies: -- async -- avl-auth -- base >= 4.7 && < 5 -- binary -- bytestring -- containers -- conduit -- cryptonite -- data-default-class -- errors -- exceptions -- free -- hs-abci-types -- hs-abci-server -- http-types -- katip -- lens -- memory -- mtl -- polysemy -- polysemy-plugin -- servant -- stm -- string-conversions -- text -- uri-bytestring + - PackageImports library: source-dirs: - src + dependencies: + - aeson + - aeson-casing + - avl-auth + - base >= 4.7 && < 5 + - bytestring + - containers + - cryptonite + - data-default-class + - errors + - hs-abci-server + - hs-abci-types + - hs-iavl-client + - http-api-data + - http-types + - http2-client + - http2-client-grpc + - katip + - lens + - memory + - mtl + - polysemy + - polysemy-plugin + - polysemy-zoo + - prometheus + - proto-lens + - proto-lens-runtime + - proto3-suite + - proto3-wire + - secp256k1-haskell + - servant + - string-conversions + - text + - time + - validation ghc-options: - -fplugin=Polysemy.Plugin - - -Werror - -Wall + - -Werror + - -Wcompat + - -Widentities + - -Wincomplete-uni-patterns + - -Wredundant-constraints exposed-modules: - - Tendermint.SDK.Store - - Tendermint.SDK.Codec - - Tendermint.SDK.StoreQueries - - Tendermint.SDK.Subscription - - Tendermint.SDK.AuthTreeStore - - Tendermint.SDK.Router.Types - - Tendermint.SDK.Router.Class - - Tendermint.SDK.Router - - Tendermint.SDK.BaseApp - - Tendermint.SDK.Logger - - Tendermint.SDK.Logger.Katip - Tendermint.SDK.Application - - Tendermint.SDK.Events + - Tendermint.SDK.Application.App + - Tendermint.SDK.Application.Module + - Tendermint.SDK.Application.Handlers + - Tendermint.SDK.Application.AnteHandler + - Tendermint.SDK.BaseApp + - Tendermint.SDK.BaseApp.Effects + - Tendermint.SDK.BaseApp.Effects.BaseEffs + - Tendermint.SDK.BaseApp.Effects.CoreEffs + - Tendermint.SDK.BaseApp.Effects.PureCoreEffs + - Tendermint.SDK.BaseApp.Errors + - Tendermint.SDK.BaseApp.Events + - Tendermint.SDK.BaseApp.Gas + - Tendermint.SDK.BaseApp.Logger + - Tendermint.SDK.BaseApp.Logger.Katip + - Tendermint.SDK.BaseApp.Metrics + - Tendermint.SDK.BaseApp.Metrics.Prometheus + - Tendermint.SDK.BaseApp.Query + - Tendermint.SDK.BaseApp.Query.Router + - Tendermint.SDK.BaseApp.Query.Store + - Tendermint.SDK.BaseApp.Query.Types + - Tendermint.SDK.BaseApp.Router.Delayed + - Tendermint.SDK.BaseApp.Router.Types + - Tendermint.SDK.BaseApp.Router.Router + - Tendermint.SDK.BaseApp.Store + - Tendermint.SDK.BaseApp.Store.Array + - Tendermint.SDK.BaseApp.Store.IAVLStore + - Tendermint.SDK.BaseApp.Store.List + - Tendermint.SDK.BaseApp.Store.Map + - Tendermint.SDK.BaseApp.Store.MemoryStore + - Tendermint.SDK.BaseApp.Store.RawStore + - Tendermint.SDK.BaseApp.Store.Var + - Tendermint.SDK.BaseApp.Transaction + - Tendermint.SDK.BaseApp.Transaction.AnteHandler + - Tendermint.SDK.BaseApp.Transaction.Cache + - Tendermint.SDK.BaseApp.Transaction.Checker + - Tendermint.SDK.BaseApp.Transaction.Effect + - Tendermint.SDK.BaseApp.Transaction.Router + - Tendermint.SDK.BaseApp.Transaction.Types + - Tendermint.SDK.Codec + - Tendermint.SDK.Crypto + - Tendermint.SDK.Modules.Auth + - Tendermint.SDK.Modules.Bank + - Tendermint.SDK.Modules.Bank.Messages + - Tendermint.SDK.Modules.Bank.Types + - Tendermint.SDK.Modules.Bank.Keeper + - Tendermint.SDK.Modules.Bank.Query + - Tendermint.SDK.Modules.Bank.Router + - Tendermint.SDK.Types.Address + - Tendermint.SDK.Types.Effects + - Tendermint.SDK.Types.Message + - Tendermint.SDK.Types.Transaction + - Tendermint.SDK.Types.TxResult + + generated-exposed-modules: + - Proto.Modules.Auth + - Proto.Modules.Auth_Fields + - Proto.Modules.Bank + - Proto.Modules.Bank_Fields + - Proto.Types.Transaction + - Proto.Types.Transaction_Fields tests: hs-abci-sdk-test: main: Spec.hs source-dirs: test other-modules: - - Tendermint.SDK.Test.AuthTreeStoreSpec - # - Tendermint.SDK.Test.StoreExampleSpec - - Tendermint.SDK.Test.ModuleSpec + - Tendermint.SDK.Test.IAVLStoreSpec + - Tendermint.SDK.Test.CryptoSpec + - Tendermint.SDK.Test.GasSpec + - Tendermint.SDK.Test.MetricsSpec + - Tendermint.SDK.Test.SimpleStorage + - Tendermint.SDK.Test.ArraySpec + - Tendermint.SDK.Test.ListSpec + - Tendermint.SDK.Test.MapSpec + - Tendermint.SDK.Test.VarSpec + - Tendermint.SDK.Test.QuerySpec ghc-options: + - -fplugin=Polysemy.Plugin - -Werror - -Wall - -threaded @@ -102,12 +178,27 @@ tests: - -with-rtsopts=-N dependencies: - - generic-arbitrary - - hs-abci-server + - base >= 4.7 && < 5 + - bytestring + - cereal + - cereal-text + - containers + - cryptonite + - cereal - hs-abci-sdk + - hs-abci-types - hspec - hspec-core - hspec-discover - - binary - - QuickCheck - - quickcheck-instances + - http2-client-grpc + - lens + - memory + - polysemy + - polysemy-plugin + - polysemy-zoo + - prometheus + - secp256k1-haskell + - servant + - string-conversions + - text + - validation diff --git a/hs-abci-sdk/protos/modules/auth.proto b/hs-abci-sdk/protos/modules/auth.proto new file mode 100644 index 00000000..929af1b0 --- /dev/null +++ b/hs-abci-sdk/protos/modules/auth.proto @@ -0,0 +1,20 @@ +syntax = "proto3"; +package Auth; + +message CoinId { + string id = 1; +} + +message Amount { + uint64 amount = 1; +} + +message Coin { + CoinId id = 1; + Amount amount = 2; +} + +message Account { + repeated Coin coins = 1; + uint64 nonce = 2; +} \ No newline at end of file diff --git a/hs-abci-sdk/protos/modules/bank.proto b/hs-abci-sdk/protos/modules/bank.proto new file mode 100644 index 00000000..fc6c1d7e --- /dev/null +++ b/hs-abci-sdk/protos/modules/bank.proto @@ -0,0 +1,15 @@ +syntax = "proto3"; +package Bank; + +message Transfer { + bytes to = 1; + bytes from = 2; + string cid = 3; + uint64 amount = 4; +} + +message Burn { + bytes address = 1; + string cid = 2; + uint64 amount = 3; +} \ No newline at end of file diff --git a/hs-abci-sdk/protos/types/transaction.proto b/hs-abci-sdk/protos/types/transaction.proto new file mode 100644 index 00000000..f069828b --- /dev/null +++ b/hs-abci-sdk/protos/types/transaction.proto @@ -0,0 +1,15 @@ +syntax = "proto3"; +package Transaction; + +message RawTransaction { + TypedMessage data = 1; + int64 gas = 2; + bytes signature = 3; + string route = 4; + uint64 nonce = 5; +} + +message TypedMessage { + string type = 1; + bytes data = 2; +} \ No newline at end of file diff --git a/hs-abci-sdk/src/Tendermint/SDK/Application.hs b/hs-abci-sdk/src/Tendermint/SDK/Application.hs index d478377c..47da4d10 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/Application.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/Application.hs @@ -1,52 +1,18 @@ module Tendermint.SDK.Application - ( MakeApplication(..) - , createApplication - , defaultHandler + ( ModuleList(..) + , Module(..) + , Component + , Eval(..) + , ModuleEffs + , HandlersContext(..) + , baseAppAnteHandler + , createIOApp + , makeApp ) where -import Control.Exception -import Control.Lens ((&), (.~)) -import Data.Default.Class (Default (..)) -import Data.Proxy -import Data.String.Conversions (cs) -import Network.ABCI.Server.App (App, MessageType, - Response (..), - transformApp) -import qualified Network.ABCI.Types.Messages.Response as Resp +import Tendermint.SDK.Application.AnteHandler +import Tendermint.SDK.Application.App +import Tendermint.SDK.Application.Handlers +import Tendermint.SDK.Application.Module -data MakeApplication m e = MakeApplication - { app :: App m - , transformer :: forall a. m a -> IO a - , appErrorP :: Proxy e - , initialize :: [m ()] - } -defaultHandler - :: ( Default a - , Applicative m - ) - => b - -> m a -defaultHandler = const $ pure def - -transformResponse - :: forall e m. - Exception e - => MakeApplication m e - -> (forall (t :: MessageType). m (Response t) -> IO (Response t)) -transformResponse MakeApplication{transformer} m = do - eRes :: Either e (Response t) <- try $ transformer m - case eRes of - Left e -> pure $ ResponseException $ - def & Resp._exceptionError .~ cs (displayException e) - Right a -> pure a - -createApplication - :: ( Exception e - , Monad m - ) - => MakeApplication m e - -> IO (App IO) -createApplication ma@MakeApplication{app, transformer, initialize} = do - transformer $ sequence_ initialize - pure $ transformApp (transformResponse ma) app diff --git a/hs-abci-sdk/src/Tendermint/SDK/Application/AnteHandler.hs b/hs-abci-sdk/src/Tendermint/SDK/Application/AnteHandler.hs new file mode 100644 index 00000000..ea52939b --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Application/AnteHandler.hs @@ -0,0 +1,65 @@ +module Tendermint.SDK.Application.AnteHandler + ( module Tendermint.SDK.Application.AnteHandler + -- Re-Exports + , AnteHandler + ) where + +import Control.Monad (unless, void) +import Data.Foldable (fold) +import Data.Monoid (Endo (..)) +import Polysemy +import Polysemy.Error (Error) +import Tendermint.SDK.BaseApp.Errors (AppError, SDKError (..), + throwSDKError) +import Tendermint.SDK.BaseApp.Transaction (AnteHandler, + RoutingTx (..)) +import qualified Tendermint.SDK.Modules.Auth as A +import Tendermint.SDK.Types.Message (Msg (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) + + +createAccountAnteHandler + :: Members A.AuthEffs r + => AnteHandler r +createAccountAnteHandler = Endo $ + \txApplication tx@(RoutingTx Tx{..}) -> do + let Msg{msgAuthor} = txMsg + mAcnt <- A.getAccount msgAuthor + case mAcnt of + Nothing -> void $ A.createAccount msgAuthor + _ -> pure () + txApplication tx >>= pure + +nonceAnteHandler + :: Members A.AuthEffs r + => Member (Error AppError) r + => AnteHandler r +nonceAnteHandler = Endo $ + \txApplication tx@(RoutingTx Tx{..}) -> do + let Msg{msgAuthor} = txMsg + preMAcnt <- A.getAccount msgAuthor + case preMAcnt of + Just A.Account{accountNonce} -> do + let expectedNonce = accountNonce + 1 + unless (txNonce == expectedNonce) $ + throwSDKError (NonceException expectedNonce txNonce) + Nothing -> throwSDKError (UnknownAccountError msgAuthor) + result <- txApplication tx + postMAcnt <- A.getAccount msgAuthor + case postMAcnt of + Just A.Account{accountNonce} -> do + A.updateAccount msgAuthor $ \a -> + a { A.accountNonce = accountNonce + 1} + -- @NOTE: no-op when no nonce is availble to update + Nothing -> pure () + pure result + +baseAppAnteHandler + :: Members A.AuthEffs r + => Member (Error AppError) r + => AnteHandler r +baseAppAnteHandler = fold $ + -- @NOTE: antehandlers in this list are applied top to bottom + [ createAccountAnteHandler + , nonceAnteHandler + ] diff --git a/hs-abci-sdk/src/Tendermint/SDK/Application/App.hs b/hs-abci-sdk/src/Tendermint/SDK/Application/App.hs new file mode 100644 index 00000000..35b950c2 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Application/App.hs @@ -0,0 +1,29 @@ +module Tendermint.SDK.Application.App + ( createIOApp + ) where + +import Control.Exception +import Control.Lens ((&), (.~)) +import Data.Default.Class (Default (..)) +import Data.String.Conversions (cs) +import Network.ABCI.Server.App (App (..), MessageType, + Response (..), + transformApp) +import qualified Network.ABCI.Types.Messages.Response as Resp +import Polysemy (Sem) +import Tendermint.SDK.BaseApp.Errors (AppError) + +createIOApp + :: forall r. + (forall a. (Sem r) a -> IO a) + -> App (Sem r) + -> App IO +createIOApp nat app = transformApp transformResponse app + where + transformResponse :: (forall (t :: MessageType). Sem r (Response t) -> IO (Response t)) + transformResponse (resp :: Sem r (Response t)) = do + eRes :: Either AppError (Response t) <- try $ nat $ resp + case eRes of + Left e -> pure $ ResponseException $ + def & Resp._exceptionError .~ cs (displayException e) + Right a -> pure a diff --git a/hs-abci-sdk/src/Tendermint/SDK/Application/Handlers.hs b/hs-abci-sdk/src/Tendermint/SDK/Application/Handlers.hs new file mode 100644 index 00000000..625659ff --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Application/Handlers.hs @@ -0,0 +1,206 @@ +module Tendermint.SDK.Application.Handlers + ( Handler + , HandlersContext(..) + , makeApp + ) where + +import Control.Lens (from, to, (&), (.~), + (^.)) +import Crypto.Hash (Digest) +import Crypto.Hash.Algorithms (SHA256) +import qualified Data.ByteArray.Base64String as Base64 +import Data.Default.Class (Default (..)) +import Data.Proxy +import Network.ABCI.Server.App (App (..), + MessageType (..), + Request (..), + Response (..), + transformApp) +import qualified Network.ABCI.Types.Messages.Request as Req +import qualified Network.ABCI.Types.Messages.Response as Resp +import Polysemy +import Polysemy.Error (catch) +import qualified Tendermint.SDK.Application.Module as M +import qualified Tendermint.SDK.BaseApp as BA +import Tendermint.SDK.BaseApp.Errors (SDKError (..), + queryAppError, + throwSDKError, + txResultAppError) +import qualified Tendermint.SDK.BaseApp.Query as Q +import qualified Tendermint.SDK.BaseApp.Store as Store +import Tendermint.SDK.BaseApp.Transaction as T +import Tendermint.SDK.BaseApp.Transaction.Cache (writeCache) +import Tendermint.SDK.Crypto (RecoverableSignatureSchema, + SignatureSchema (..)) +import Tendermint.SDK.Types.Transaction (parseTx) +import Tendermint.SDK.Types.TxResult (checkTxTxResult, + deliverTxTxResult) + +type Handler mt r = Request mt -> Sem r (Response mt) + +data Handlers r = Handlers + { info :: Handler 'MTInfo r + , setOption :: Handler 'MTSetOption r + , initChain :: Handler 'MTInitChain r + , query :: Handler 'MTQuery r + , checkTx :: Handler 'MTCheckTx r + , beginBlock :: Handler 'MTBeginBlock r + , deliverTx :: Handler 'MTDeliverTx r + , endBlock :: Handler 'MTEndBlock r + , commit :: Handler 'MTCommit r + } + +defaultHandlers :: forall r. Handlers r +defaultHandlers = Handlers + { info = defaultHandler + , setOption = defaultHandler + , initChain = defaultHandler + , query = defaultHandler + , checkTx = defaultHandler + , beginBlock = defaultHandler + , deliverTx = defaultHandler + , endBlock = defaultHandler + , commit = defaultHandler + } + where + defaultHandler + :: Default a + => Applicative m + => b + -> m a + defaultHandler = const $ pure def + + +data HandlersContext alg ms core = HandlersContext + { signatureAlgP :: Proxy alg + , modules :: M.ModuleList ms (M.Effs ms core) + , anteHandler :: BA.AnteHandler (M.Effs ms core) + , compileToCore :: forall a. Sem (BA.BaseAppEffs core) a -> Sem core a + } + +-- Common function between checkTx and deliverTx +makeHandlers + :: forall alg ms core. + RecoverableSignatureSchema alg + => Message alg ~ Digest SHA256 + => M.ToApplication ms (M.Effs ms core) + => T.HasTxRouter (M.ApplicationC ms) (M.Effs ms core) 'Store.QueryAndMempool + => T.HasTxRouter (M.ApplicationC ms) (BA.BaseAppEffs core) 'Store.QueryAndMempool + => T.HasTxRouter (M.ApplicationD ms) (M.Effs ms core) 'Store.Consensus + => T.HasTxRouter (M.ApplicationD ms) (BA.BaseAppEffs core) 'Store.Consensus + => Q.HasQueryRouter (M.ApplicationQ ms) (M.Effs ms core) + => Q.HasQueryRouter (M.ApplicationQ ms) (BA.BaseAppEffs core) + => M.Eval ms core + -- => M.Effs ms core ~ (BA.AppEffs (M.ModulesEffs ms) core) + => HandlersContext alg ms core + -> Handlers (BA.BaseAppEffs core) +makeHandlers (HandlersContext{..} :: HandlersContext alg ms core) = + let + + cProxy :: Proxy core + cProxy = Proxy + + rProxy :: Proxy (BA.BaseAppEffs core) + rProxy = Proxy + + app :: M.Application (M.ApplicationC ms) (M.ApplicationD ms) (M.ApplicationQ ms) + (T.TxEffs BA.:& BA.BaseAppEffs core) (Q.QueryEffs BA.:& BA.BaseAppEffs core) + app = M.makeApplication cProxy anteHandler modules + + txParser bs = case parseTx signatureAlgP bs of + Left err -> throwSDKError $ ParseError err + Right tx -> pure $ T.RoutingTx tx + + checkServer :: T.TransactionApplication (Sem (BA.BaseAppEffs core)) + checkServer = + T.serveTxApplication (Proxy @(M.ApplicationC ms)) rProxy (Proxy @'Store.QueryAndMempool) $ M.applicationTxChecker app + + deliverServer :: T.TransactionApplication (Sem (BA.BaseAppEffs core)) + deliverServer = + T.serveTxApplication (Proxy @(M.ApplicationD ms)) rProxy (Proxy @'Store.Consensus) $ M.applicationTxDeliverer app + + queryServer :: Q.QueryApplication (Sem (BA.BaseAppEffs core)) + queryServer = Q.serveQueryApplication (Proxy @(M.ApplicationQ ms)) rProxy $ M.applicationQuerier app + + query (RequestQuery q) = + --Store.applyScope $ + catch + (do + queryResp <- queryServer q + pure $ ResponseQuery queryResp + ) + (\(err :: BA.AppError) -> + return . ResponseQuery $ def & queryAppError .~ err + ) + + checkTx (RequestCheckTx _checkTx) = do + res <- catch + ( let txBytes = _checkTx ^. Req._checkTxTx . to Base64.toBytes + in do + (res, _) <- txParser txBytes >>= checkServer + pure res + ) + (\(err :: BA.AppError) -> + return $ def & txResultAppError .~ err + ) + return . ResponseCheckTx $ res ^. from checkTxTxResult + + deliverTx (RequestDeliverTx _deliverTx) = do + res <- catch @BA.AppError + ( let txBytes = _deliverTx ^. Req._deliverTxTx . to Base64.toBytes + in do + (res, cache) <- txParser txBytes >>= deliverServer + maybe (pure ()) writeCache cache + pure res + ) + (\(err :: BA.AppError) -> + return $ def & txResultAppError .~ err + ) + return . ResponseDeliverTx $ res ^. from deliverTxTxResult + + commit :: Handler 'MTCommit (BA.BaseAppEffs core) + commit _ = do + _ <- Store.commit + rootHash <- Store.commitBlock + return . ResponseCommit $ def + & Resp._commitData .~ Base64.fromBytes rootHash + + in defaultHandlers + { query = query + , checkTx = checkTx + , deliverTx = deliverTx + , commit = commit + } + +makeApp + :: forall alg ms core. + + RecoverableSignatureSchema alg + => Message alg ~ Digest SHA256 + => M.ToApplication ms (M.Effs ms core) + => T.HasTxRouter (M.ApplicationC ms) (M.Effs ms core) 'Store.QueryAndMempool + => T.HasTxRouter (M.ApplicationC ms) (BA.BaseAppEffs core) 'Store.QueryAndMempool + => T.HasTxRouter (M.ApplicationD ms) (M.Effs ms core) 'Store.Consensus + => T.HasTxRouter (M.ApplicationD ms) (BA.BaseAppEffs core) 'Store.Consensus + => Q.HasQueryRouter (M.ApplicationQ ms) (M.Effs ms core) + => Q.HasQueryRouter (M.ApplicationQ ms) (BA.BaseAppEffs core) + => M.Eval ms core + -- => M.Effs ms (BA.BaseAppEffs core) ~ (BA.AppEffs (M.ModulesEffs ms) core) + => HandlersContext alg ms core + -> App (Sem core) +makeApp handlersContext@HandlersContext{compileToCore} = + let Handlers{..} = makeHandlers handlersContext :: Handlers (BA.BaseAppEffs core) + in transformApp compileToCore $ App $ \case + RequestEcho echo -> + pure . ResponseEcho $ def + & Resp._echoMessage .~ echo ^. Req._echoMessage + RequestFlush _ -> pure def + msg@(RequestInfo _) -> info msg + msg@(RequestSetOption _) -> setOption msg + msg@(RequestInitChain _) -> initChain msg + msg@(RequestQuery _) -> query msg + msg@(RequestBeginBlock _) -> beginBlock msg + msg@(RequestCheckTx _) -> checkTx msg + msg@(RequestDeliverTx _) -> deliverTx msg + msg@(RequestEndBlock _) -> endBlock msg + msg@(RequestCommit _) -> commit msg diff --git a/hs-abci-sdk/src/Tendermint/SDK/Application/Module.hs b/hs-abci-sdk/src/Tendermint/SDK/Application/Module.hs new file mode 100644 index 00000000..c9373180 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Application/Module.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Tendermint.SDK.Application.Module + ( Module(..) + , Component + , ModuleEffs + , ModuleList(..) + , Application(..) + , ToApplication(..) + , hoistApplication + , Eval(..) + , makeApplication + , applyAnteHandler + + ) where + +import Data.Kind (Type) +import Data.Proxy +import GHC.TypeLits (ErrorMessage (..), Symbol, + TypeError) +import Polysemy (EffectRow, Members, Sem) +import Servant.API ((:<|>) (..), (:>)) +import Tendermint.SDK.BaseApp ((:&), BaseAppEffs, + BaseEffs) +import qualified Tendermint.SDK.BaseApp.Query as Q +import Tendermint.SDK.BaseApp.Store (Scope (..)) +import qualified Tendermint.SDK.BaseApp.Transaction as T + +type Component = EffectRow -> Type + +-- NOTE: This does not pull in transitive dependencies on purpose to avoid +-- unintended enlarged scope +type family DependencyEffs (ms :: [Component]) :: EffectRow where + DependencyEffs '[] = '[] + DependencyEffs (Module _ _ _ _ es deps ': rest) = es :& DependencyEffs rest + DependencyEffs _ = TypeError ('Text "DependencyEffs is a partial function defined only on partially applied Modules") + +data Module (name :: Symbol) (check :: *) (deliver :: *) (query :: *) (es :: EffectRow) (deps :: [Component]) (r :: EffectRow) = Module + { moduleTxChecker :: T.RouteTx check r + , moduleTxDeliverer :: T.RouteTx deliver r + , moduleQuerier :: Q.RouteQ query r + , moduleEval :: forall s. (Members T.TxEffs s, Members BaseEffs s, Members (DependencyEffs deps) s) => forall a. Sem (es :& s) a -> Sem s a + } + +type family ModuleEffs (m :: Component) :: EffectRow where + ModuleEffs (Module _ _ _ _ es deps) = es :& DependencyEffs deps :& T.TxEffs :& BaseEffs + ModuleEffs _ = TypeError ('Text "ModuleEffs is a partial function defined only on Component") + +data ModuleList (ms :: [Component]) r where + NilModules :: ModuleList '[] r + (:+) :: Module name check deliver query es deps r + -> ModuleList ms r + -> ModuleList (Module name check deliver query es deps ': ms) r + +infixr 5 :+ + +data Application check deliver query r s = Application + { applicationTxChecker :: T.RouteTx check r + , applicationTxDeliverer :: T.RouteTx deliver r + , applicationQuerier :: Q.RouteQ query s + } + +class ToApplication ms r where + type ApplicationC ms :: * + type ApplicationD ms :: * + type ApplicationQ ms :: * + + toApplication :: ModuleList ms r -> Application (ApplicationC ms) (ApplicationD ms) (ApplicationQ ms) r r + +instance ToApplication '[Module name check deliver query es deps] r where + type ApplicationC '[Module name check deliver query es deps] = name :> check + type ApplicationD '[Module name check deliver query es deps] = name :> deliver + type ApplicationQ '[Module name check deliver query es deps] = name :> query + + toApplication (Module{..} :+ NilModules) = + Application + { applicationTxChecker = moduleTxChecker + , applicationTxDeliverer = moduleTxDeliverer + , applicationQuerier = moduleQuerier + } + +instance ToApplication (m' ': ms) r => ToApplication (Module name check deliver query es deps ': m' ': ms) r where + type ApplicationC (Module name check deliver query es deps ': m' ': ms) = (name :> check) :<|> ApplicationC (m' ': ms) + type ApplicationD (Module name check deliver query es deps ': m' ': ms) = (name :> deliver) :<|> ApplicationD (m' ': ms) + type ApplicationQ (Module name check deliver query es deps ': m' ': ms) = (name :> query) :<|> ApplicationQ (m' ': ms) + + toApplication (Module{..} :+ rest) = + let app = toApplication rest + in Application + { applicationTxChecker = moduleTxChecker :<|> applicationTxChecker app + , applicationTxDeliverer = moduleTxDeliverer :<|> applicationTxDeliverer app + , applicationQuerier = moduleQuerier :<|> applicationQuerier app + } + +hoistApplication + :: T.HasTxRouter check r 'QueryAndMempool + => T.HasTxRouter deliver r 'Consensus + => Q.HasQueryRouter query s + => (forall a. Sem r a -> Sem r' a) + -> (forall a. Sem s a -> Sem s' a) + -> Application check deliver query r s + -> Application check deliver query r' s' +hoistApplication natT natQ (app :: Application check deliver query r s) = + Application + { applicationTxChecker = T.hoistTxRouter (Proxy @check) (Proxy @r) (Proxy @'QueryAndMempool) natT $ applicationTxChecker app + , applicationTxDeliverer = T.hoistTxRouter (Proxy @deliver) (Proxy @r) (Proxy @'Consensus) natT $ applicationTxDeliverer app + , applicationQuerier = Q.hoistQueryRouter (Proxy @query) (Proxy @s) natQ $ applicationQuerier app + } + +class Eval ms (core :: EffectRow) where + type Effs ms core :: EffectRow + eval + :: proxy core + -> ModuleList ms r + -> forall a. + Sem (Effs ms core) a + -> Sem (T.TxEffs :& BaseAppEffs core) a + +instance (DependencyEffs deps ~ '[]) => Eval '[Module name check deliver query es deps] core where + type Effs '[Module name check deliver query es deps] core = es :& T.TxEffs :& BaseAppEffs core + eval _ (m :+ NilModules) = moduleEval m + +instance ( Members (DependencyEffs deps) (Effs (m' ': ms) s) + , Members T.TxEffs (Effs (m' ': ms) s) + , Members BaseEffs (Effs (m' ': ms) s) + , Eval (m' ': ms) s + ) => Eval (Module name check deliver query es deps ': m' ': ms) s where + type Effs (Module name check deliver query es deps ': m' ': ms) s = es :& (Effs (m': ms)) s + eval pcore (m :+ rest) = eval pcore rest . moduleEval m + +makeApplication + :: Eval ms core + => ToApplication ms (Effs ms core) + => T.HasTxRouter (ApplicationC ms) (Effs ms core) 'QueryAndMempool + => T.HasTxRouter (ApplicationD ms) (Effs ms core) 'Consensus + => Q.HasQueryRouter (ApplicationQ ms) (Effs ms core) + => Proxy core + -> T.AnteHandler (Effs ms core) + -> ModuleList ms (Effs ms core) + -> Application (ApplicationC ms) (ApplicationD ms) (ApplicationQ ms) (T.TxEffs :& BaseAppEffs core) (Q.QueryEffs :& BaseAppEffs core) +makeApplication p@(Proxy :: Proxy core) ah (ms :: ModuleList ms (Effs ms core)) = + let app = applyAnteHandler ah $ toApplication ms :: Application (ApplicationC ms) (ApplicationD ms) (ApplicationQ ms) (Effs ms core) (Effs ms core) + -- WEIRD: if you move the eval into a separate let binding then it doesn't typecheck... + in hoistApplication (eval @ms @core p ms) (T.evalReadOnly . eval @ms @core p ms) app + +applyAnteHandler + :: T.HasTxRouter check r 'QueryAndMempool + => T.HasTxRouter deliver r 'Consensus + => T.AnteHandler r + -> Application check deliver query r s + -> Application check deliver query r s +applyAnteHandler ah (app :: Application check deliver query r s) = + app { applicationTxChecker = T.applyAnteHandler (Proxy @check) (Proxy @r) (Proxy @'QueryAndMempool) ah $ + applicationTxChecker app + , applicationTxDeliverer = T.applyAnteHandler (Proxy @deliver) (Proxy @r) (Proxy @'Consensus) ah $ + applicationTxDeliverer app + } diff --git a/hs-abci-sdk/src/Tendermint/SDK/AuthTreeStore.hs b/hs-abci-sdk/src/Tendermint/SDK/AuthTreeStore.hs deleted file mode 100644 index 903eb350..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/AuthTreeStore.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Tendermint.SDK.AuthTreeStore where - -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TVar -import Control.Monad.IO.Class -import qualified Crypto.Data.Auth.Tree as AT -import qualified Crypto.Data.Auth.Tree.Class as AT -import qualified Crypto.Data.Auth.Tree.Cryptonite as Cryptonite -import qualified Crypto.Hash as Cryptonite -import Data.ByteArray (convert) -import Data.ByteString (ByteString) -import Polysemy (Embed, Member, Sem, - interpret) -import Tendermint.SDK.Store (RawStore (..), Root (..)) --------------------------------------------------------------------------------- --- --------------------------------------------------------------------------------- - -newtype AuthTreeHash = AuthTreeHash (Cryptonite.Digest Cryptonite.SHA256) - -instance AT.MerkleHash AuthTreeHash where - emptyHash = AuthTreeHash Cryptonite.emptyHash - hashLeaf k v = AuthTreeHash $ Cryptonite.hashLeaf k v - concatHashes (AuthTreeHash a) (AuthTreeHash b) = AuthTreeHash $ Cryptonite.concatHashes a b - -data AuthTreeDriver = AuthTreeDriver - { treeVar :: TVar (AT.Tree ByteString ByteString) - } - -initAuthTreeDriver :: IO AuthTreeDriver -initAuthTreeDriver = AuthTreeDriver <$> newTVarIO AT.empty - -interpretAuthTreeStore - :: Member (Embed IO) r - => AuthTreeDriver - -> Sem (RawStore ': r) a - -> Sem r a -interpretAuthTreeStore AuthTreeDriver{treeVar} = - interpret - (\case - RawStorePut k v -> liftIO . atomically $ do - tree <- readTVar treeVar - writeTVar treeVar $ AT.insert k v tree - RawStoreGet _ k -> liftIO . atomically $ do - tree <- readTVar treeVar - pure $ AT.lookup k tree - RawStoreProve _ _ -> pure Nothing - RawStoreRoot -> liftIO . atomically $ do - tree <- readTVar treeVar - let AuthTreeHash r = AT.merkleHash tree :: AuthTreeHash - pure $ Root $ convert r - ) diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs index b395e6dc..8eb48605 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs @@ -1,83 +1,109 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +module Tendermint.SDK.BaseApp + ( -- * BaseApp + BaseEffs + , defaultCompileToCore + , defaultCompileToPureCore + , BaseAppEffs + , (:&) -module Tendermint.SDK.BaseApp where + -- * Core Effects + , CoreEffs + , Context(..) + , contextLogConfig + , contextPrometheusEnv + , contextVersions + , makeContext + , runCoreEffs -import Control.Lens (over, view) -import qualified Katip as K -import Polysemy (Embed, Member, Members, Sem, - runM) -import Polysemy.Output (Output) -import Polysemy.Reader (Reader, asks, local, runReader) -import Polysemy.Resource (Resource, resourceToIO) -import Tendermint.SDK.AuthTreeStore (AuthTreeDriver, - initAuthTreeDriver, - interpretAuthTreeStore) -import Tendermint.SDK.Events (Event, EventBuffer, - evalWithBuffer, newEventBuffer) -import Tendermint.SDK.Logger (Logger) -import qualified Tendermint.SDK.Logger.Katip as KL -import Tendermint.SDK.Store (RawStore) + -- * Pure Effects + , PureCoreEffs + , PureContext(..) + , pureContextLogConfig + , pureContextVersions + , pureContextDB + , makePureContext + , runPureCoreEffs -type HasBaseApp r = - ( Member Logger r - , Member RawStore r - , Member (Output Event) r - , Member Resource r - ) + -- * Store + , ReadStore + , WriteStore + , RawKey(..) + , StoreKey(..) + , IsKey(..) + , Store + , KeyRoot(..) + , makeStore + , put + , get + , delete -data Context = Context - { contextLogConfig :: KL.LogConfig - , contextEventBuffer :: EventBuffer - , contextAuthTreeDriver :: AuthTreeDriver - } + -- * Query Routes + , Leaf + , QA + , StoreLeaf -type CoreEff = - '[ Reader KL.LogConfig - , Embed IO - ] + -- * Errors + , AppError(..) + , IsAppError(..) -type BaseApp = - ( Output Event - ': RawStore - ': Logger - ': Resource - ': Reader EventBuffer - ': CoreEff - ) + -- * Events + , Event(..) + , ToEvent(..) + , ContextEvent(..) + , emit + , logEvent -instance (Members CoreEff r) => K.Katip (Sem r) where - getLogEnv = asks $ view KL.logEnv - localLogEnv f m = local (over KL.logEnv f) m + -- * Gas + , GasMeter + , withGas -instance (Members CoreEff r) => K.KatipContext (Sem r) where - getKatipContext = asks $ view KL.logContext - localKatipContext f m = local (over KL.logContext f) m - getKatipNamespace = asks $ view KL.logNamespace - localKatipNamespace f m = local (over KL.logNamespace f) m + -- * Logger + , Logger + , Tendermint.SDK.BaseApp.Logger.log + , LogSelect(..) + , addContext + , Severity(..) + , Select(..) + , Verbosity(..) + -- * Metrics + , Metrics + , incCount + , withTimer + , CountName(..) + , HistogramName(..) -makeContext :: KL.LogConfig -> IO Context -makeContext logCfg = do - authTreeD <- initAuthTreeDriver - eb <- newEventBuffer - pure $ Context - { contextLogConfig = logCfg - , contextEventBuffer = eb - , contextAuthTreeDriver = authTreeD - } + -- * Transaction + , AnteHandler + , RoutingTx(..) + , RouteTx + , RouteContext(..) + , Return + , (:~>) + , TypedMessage + , TxEffs + , EmptyTxServer(..) + , DefaultCheckTx(..) + , VoidReturn --- NOTE: Do we need this step? I think so because of the logger. --- You don't want to run against a fresh katip context every time. -eval - :: Context - -> Sem BaseApp a - -> IO a -eval Context{..} action = - runM . - runReader contextLogConfig . - runReader contextEventBuffer . - resourceToIO . - KL.evalKatip . - interpretAuthTreeStore contextAuthTreeDriver . - evalWithBuffer $ action + -- * Query + , QueryEffs + , QueryData(..) + , RouteQ + , QueryResult(..) + , storeQueryHandler + , EmptyQueryServer(..) + , RouterError(ResourceNotFound) + ) where + +import Tendermint.SDK.BaseApp.Effects +import Tendermint.SDK.BaseApp.Errors +import Tendermint.SDK.BaseApp.Events +import Tendermint.SDK.BaseApp.Gas +import Tendermint.SDK.BaseApp.Logger +import Tendermint.SDK.BaseApp.Metrics +import Tendermint.SDK.BaseApp.Query +import Tendermint.SDK.BaseApp.Router (RouterError (ResourceNotFound)) +import Tendermint.SDK.BaseApp.Store +import Tendermint.SDK.BaseApp.Transaction +import Tendermint.SDK.Types.Effects ((:&)) diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects.hs new file mode 100644 index 00000000..56300bfd --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects.hs @@ -0,0 +1,34 @@ +module Tendermint.SDK.BaseApp.Effects + ( BaseAppEffs + , defaultCompileToCore + , defaultCompileToPureCore + , module Tendermint.SDK.BaseApp.Effects.BaseEffs + , module Tendermint.SDK.BaseApp.Effects.CoreEffs + , module Tendermint.SDK.BaseApp.Effects.PureCoreEffs + ) where + +import Polysemy (Sem) +import Tendermint.SDK.BaseApp.Effects.BaseEffs +import Tendermint.SDK.BaseApp.Effects.CoreEffs +import Tendermint.SDK.BaseApp.Effects.PureCoreEffs +import Tendermint.SDK.BaseApp.Store (StoreEffs) +import qualified Tendermint.SDK.BaseApp.Store.IAVLStore as IAVL +import qualified Tendermint.SDK.BaseApp.Store.MemoryStore as Memory +import Tendermint.SDK.Types.Effects ((:&)) + + + + +type BaseAppEffs core = StoreEffs :& BaseEffs :& core + +defaultCompileToCore + :: forall a. + Sem (BaseAppEffs CoreEffs) a + -> Sem CoreEffs a +defaultCompileToCore = evalBaseEffs . IAVL.evalStoreEffs + +defaultCompileToPureCore + :: forall a. + Sem (BaseAppEffs PureCoreEffs) a + -> Sem PureCoreEffs a +defaultCompileToPureCore = evalBaseEffsPure . Memory.evalStoreEffs diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects/BaseEffs.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects/BaseEffs.hs new file mode 100644 index 00000000..5bcea832 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects/BaseEffs.hs @@ -0,0 +1,56 @@ +module Tendermint.SDK.BaseApp.Effects.BaseEffs + ( BaseEffs + , evalBaseEffs + , evalBaseEffsPure + ) where + +import Control.Exception (throwIO) +import Control.Monad.IO.Class (liftIO) +import Polysemy (Embed, Members, Sem) +import Polysemy.Error (Error, runError) +import Polysemy.Reader (Reader) +import Polysemy.Resource (Resource, + resourceToIO) +import Tendermint.SDK.BaseApp.Errors (AppError) +import Tendermint.SDK.BaseApp.Logger (Logger) +import qualified Tendermint.SDK.BaseApp.Logger.Katip as KL +import Tendermint.SDK.BaseApp.Metrics (Metrics) +import qualified Tendermint.SDK.BaseApp.Metrics.Prometheus as Prometheus +import Tendermint.SDK.Types.Effects ((:&)) + +-- | Concrete row of effects for the BaseApp. Note that because there does +-- | not exist an interpreter for an untagged 'RawStore', you must scope +-- | these effects before they can be interpreted. +type BaseEffs = + [ Metrics + , Logger + , Resource + , Error AppError + ] + +-- | An intermediary interpeter, bringing 'BaseApp' down to 'CoreEff'. +evalBaseEffs + :: Members [Embed IO, Reader KL.LogConfig, Reader (Maybe Prometheus.PrometheusEnv)] core + => forall a. + Sem (BaseEffs :& core) a + -> Sem core a +evalBaseEffs action = do + eRes <- runError . + resourceToIO . + KL.evalKatip . + Prometheus.evalWithMetrics $ + action + either (liftIO . throwIO) return eRes + +evalBaseEffsPure + :: Members [Embed IO, Reader KL.LogConfig] core + => forall a. + Sem (BaseEffs :& core) a + -> Sem core a +evalBaseEffsPure action = do + eRes <- runError . + resourceToIO . + KL.evalKatip . + Prometheus.evalNothing $ + action + either (liftIO . throwIO) return eRes diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects/CoreEffs.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects/CoreEffs.hs new file mode 100644 index 00000000..c07460e1 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects/CoreEffs.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tendermint.SDK.BaseApp.Effects.CoreEffs + ( CoreEffs + , Context(..) + , contextLogConfig + , contextPrometheusEnv + , contextVersions + , contextGrpcClient + , makeContext + , runCoreEffs + ) where + +import Control.Lens (makeLenses) +import Data.Text (Text) +import qualified Katip as K +import Polysemy (Embed, Sem, runM) +import Polysemy.Reader (Reader, runReader) +import qualified Tendermint.SDK.BaseApp.Logger.Katip as KL +import qualified Tendermint.SDK.BaseApp.Metrics.Prometheus as P +import qualified Tendermint.SDK.BaseApp.Store.IAVLStore as IAVL + +-- | CoreEffs is one level below BaseAppEffs, and provides one possible +-- | interpretation for its effects to IO. +type CoreEffs = + '[ Reader KL.LogConfig + , Reader (Maybe P.PrometheusEnv) + , Reader IAVL.IAVLVersions + , Reader IAVL.GrpcClient + , Embed IO + ] + +-- | 'Context' is the environment required to run 'CoreEffs' to 'IO' +data Context = Context + { _contextLogConfig :: KL.LogConfig + , _contextPrometheusEnv :: Maybe P.PrometheusEnv + , _contextGrpcClient :: IAVL.GrpcClient + , _contextVersions :: IAVL.IAVLVersions + } + +makeLenses ''Context + +makeContext + :: KL.InitialLogNamespace + -> Maybe P.MetricsScrapingConfig + -> IAVL.IAVLVersions + -> IAVL.GrpcConfig + -> IO Context +makeContext KL.InitialLogNamespace{..} scrapingCfg versions rpcConf = do + metCfg <- case scrapingCfg of + Nothing -> pure Nothing + Just scfg -> P.emptyState >>= \es -> + pure . Just $ P.PrometheusEnv es scfg + logCfg <- mkLogConfig _initialLogEnvironment _initialLogProcessName + grpc <- IAVL.initGrpcClient rpcConf + pure $ Context + { _contextLogConfig = logCfg + , _contextPrometheusEnv = metCfg + , _contextVersions = versions + , _contextGrpcClient = grpc + } + where + mkLogConfig :: Text -> Text -> IO KL.LogConfig + mkLogConfig env pName = do + let mkLogEnv = K.initLogEnv (K.Namespace [pName]) (K.Environment env) + le <- mkLogEnv + return $ KL.LogConfig + { _logNamespace = mempty + , _logContext = mempty + , _logEnv = le + } + +-- | The standard interpeter for 'CoreEffs'. +runCoreEffs + :: Context + -> forall a. Sem CoreEffs a -> IO a +runCoreEffs Context{..} = + runM . + runReader _contextGrpcClient . + runReader _contextVersions . + runReader _contextPrometheusEnv . + runReader _contextLogConfig diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects/PureCoreEffs.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects/PureCoreEffs.hs new file mode 100644 index 00000000..7d2de79a --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Effects/PureCoreEffs.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Tendermint.SDK.BaseApp.Effects.PureCoreEffs + ( PureCoreEffs + , PureContext(..) + , pureContextLogConfig + , pureContextVersions + , pureContextDB + , makePureContext + , runPureCoreEffs + ) where + +import Control.Lens (makeLenses) +import Data.Text (Text) +import qualified Katip as K +import Polysemy (Embed, Sem, runM) +import Polysemy.Error (Error, runError) +import Polysemy.Reader (Reader, runReader) +import Tendermint.SDK.BaseApp.Errors (AppError) +import qualified Tendermint.SDK.BaseApp.Logger.Katip as KL +import qualified Tendermint.SDK.BaseApp.Store.MemoryStore as Memory + +-- | CoreEffs is one level below BaseAppEffs, and provides one possible +-- | interpretation for its effects to IO. +type PureCoreEffs = + '[ Reader KL.LogConfig + , Reader Memory.DBVersions + , Reader Memory.DB + , Error AppError + , Embed IO + ] + +-- | 'Context' is the environment required to run 'CoreEffsPure' to 'IO' +data PureContext = PureContext + { _pureContextLogConfig :: KL.LogConfig + , _pureContextDB :: Memory.DB + , _pureContextVersions :: Memory.DBVersions + } + +makeLenses ''PureContext + +makePureContext + :: KL.InitialLogNamespace + -> IO PureContext +makePureContext KL.InitialLogNamespace{..} = do + logCfg <- mkLogConfig _initialLogEnvironment _initialLogProcessName + versions <- Memory.initDBVersions + db <- Memory.initDB + pure $ PureContext + { _pureContextLogConfig = logCfg + , _pureContextVersions = versions + , _pureContextDB = db + } + where + mkLogConfig :: Text -> Text -> IO KL.LogConfig + mkLogConfig env pName = do + let mkLogEnv = K.initLogEnv (K.Namespace [pName]) (K.Environment env) + le <- mkLogEnv + return $ KL.LogConfig + { _logNamespace = mempty + , _logContext = mempty + , _logEnv = le + } + +-- | The standard interpeter for 'PureCoreEffs'. +runPureCoreEffs + :: PureContext + -> forall a. Sem PureCoreEffs a -> IO (Either AppError a) +runPureCoreEffs PureContext{..} = + runM . + runError . + runReader _pureContextDB . + runReader _pureContextVersions . + runReader _pureContextLogConfig diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Errors.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Errors.hs new file mode 100644 index 00000000..f37a284a --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Errors.hs @@ -0,0 +1,158 @@ +module Tendermint.SDK.BaseApp.Errors + ( AppError(..) + , IsAppError(..) + , queryAppError + , txResultAppError + , SDKError(..) + , throwSDKError + ) where + +import Control.Exception (Exception) +import Control.Lens (Lens', lens) +import Data.String.Conversions (cs) +import Data.Text (Text, intercalate) +import Data.Word (Word32, Word64) +import qualified Network.ABCI.Types.Messages.Response as Response +import Polysemy +import Polysemy.Error (Error, throw) +import Tendermint.SDK.Types.Address (Address) +import Tendermint.SDK.Types.TxResult (TxResult (..)) + +-- | This type represents a common error response for the query, checkTx, +-- | and deliver tx abci-messages. +data AppError = AppError + { appErrorCode :: Word32 + , appErrorCodespace :: Text + , appErrorMessage :: Text + } deriving (Eq, Show) + +instance Exception AppError + +-- | Allows for custom application error types to be coerced into the +-- standard error resposne. +class IsAppError e where + makeAppError :: e -> AppError + +-- | This lens is used to set the 'AppError' data into the appropriate +-- | response fields for the query abci-message. +queryAppError :: Lens' Response.Query AppError +queryAppError = lens g s + where + g Response.Query{..} = AppError + { appErrorCode = queryCode + , appErrorCodespace = queryCodespace + , appErrorMessage = queryLog + } + s query AppError{..} = query + { Response.queryCode = appErrorCode + , Response.queryCodespace = appErrorCodespace + , Response.queryLog = appErrorMessage + } + +-- | This lens is used to set the 'AppError' data into the appropriate +-- | response fields for the checkTx/deliverTx abci-message. +txResultAppError :: Lens' TxResult AppError +txResultAppError = lens g s + where + g TxResult{..} = AppError + { appErrorCode = _txResultCode + , appErrorCodespace = _txResultCodespace + , appErrorMessage = _txResultLog + } + s txResult AppError{..} = txResult + { _txResultCode = appErrorCode + , _txResultCodespace = appErrorCodespace + , _txResultLog = appErrorMessage + } + +-------------------------------------------------------------------------------- +-- Stock SDK Errors +-------------------------------------------------------------------------------- + +-- | These errors originate from the SDK itself. The "sdk" namespace is reserved +-- | for this error type and should not be used in modules or applications. +data SDKError = + InternalError Text + -- ^ Something went wrong and we have no idea what. + | ParseError Text + -- ^ Parsing errors for SDK specific types, e.g. 'RawTransaction' or 'Msg', etc. + | UnmatchedRoute Text + -- ^ The name of the route that failed to match. + | OutOfGasException + | MessageValidation [Text] + | SignatureRecoveryError Text + | NonceException Word64 Word64 + | StoreError Text + | GrpcError Text + | UnknownAccountError Address + deriving (Show) + +-- | As of right now it's not expected that one can recover from an 'SDKError', +-- | so we are throwing them as 'AppError's directly. +throwSDKError + :: Member (Error AppError) r + => SDKError + -> Sem r a +throwSDKError = throw . makeAppError + +instance IsAppError SDKError where + makeAppError (InternalError msg) = AppError + { appErrorCode = 1 + , appErrorCodespace = "sdk" + , appErrorMessage = "Internal Error: " <> msg + } + + makeAppError (ParseError msg) = AppError + { appErrorCode = 2 + , appErrorCodespace = "sdk" + , appErrorMessage = msg + } + + makeAppError (UnmatchedRoute route) = AppError + { appErrorCode = 3 + , appErrorCodespace = "sdk" + , appErrorMessage = "Route not recognized: " <> route <> "." + } + + makeAppError OutOfGasException = AppError + { appErrorCode = 4 + , appErrorCodespace = "sdk" + , appErrorMessage = "Out of gas exception" + } + + makeAppError (MessageValidation errors) = AppError + { appErrorCode = 5 + , appErrorCodespace = "sdk" + , appErrorMessage = "Message failed validation: " <> intercalate "\n" errors + } + + makeAppError (SignatureRecoveryError msg) = AppError + { appErrorCode = 6 + , appErrorCodespace = "sdk" + , appErrorMessage = "Signature Recovery Error: " <> msg + } + + makeAppError (NonceException expected found) = AppError + { appErrorCode = 7 + , appErrorCodespace = "sdk" + , appErrorMessage = "Incorrect Transaction Nonce: Expected " <> (cs . show $ toInteger expected) <> + " but got " <> (cs . show $ toInteger found) <> "." + } + + makeAppError (StoreError msg) = AppError + { appErrorCode = 8 + , appErrorCodespace = "sdk" + , appErrorMessage = "Store Error: " <> msg + } + + makeAppError (GrpcError msg) = AppError + { appErrorCode = 9 + , appErrorCodespace = "sdk" + , appErrorMessage = "Grpc error: \n" <> msg + } + + makeAppError (UnknownAccountError addr) = AppError + { appErrorCode = 10 + , appErrorCodespace = "sdk" + , appErrorMessage = "Unknown account at " <> (cs . show $ addr) + } diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Events.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Events.hs new file mode 100644 index 00000000..8c5b0421 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Events.hs @@ -0,0 +1,96 @@ +module Tendermint.SDK.BaseApp.Events + ( + -- * Class + ToEvent(..) + , ContextEvent(..) + + -- * Effect + , emit + , logEvent + + -- * Re-Exports + , Event(..) + ) where + +import qualified Data.Aeson as A +import qualified Data.ByteArray.Base64String as Base64 +import qualified Data.ByteString as BS +import Data.Char (toLower) +import Data.String.Conversions (cs) +import GHC.Generics +import Network.ABCI.Types.Messages.FieldTypes (Event (..), + KVPair (..)) +import Polysemy (Member, Sem) +import Polysemy.Output (Output, output) +import qualified Tendermint.SDK.BaseApp.Logger as Log +import Tendermint.SDK.Codec (HasCodec (..)) + +{- +TODO : These JSON instances are fragile but convenient. We +should come up with a custom solution. +-} + +class GToNamedEventPrimatives f where + gtoNamedEventPrimatives :: f a -> [(BS.ByteString, BS.ByteString)] + +instance (GToNamedEventPrimatives f) => GToNamedEventPrimatives (C1 c f) where + gtoNamedEventPrimatives = gtoNamedEventPrimatives . unM1 + +instance (Selector s, HasCodec a) => GToNamedEventPrimatives (S1 s (K1 i a)) where + gtoNamedEventPrimatives m1@(M1 x) = + let name = cs $ selName m1 + val = encode $ unK1 x + in [(name, val)] + +instance (GToNamedEventPrimatives a, GToNamedEventPrimatives b) => GToNamedEventPrimatives (a :*: b) where + gtoNamedEventPrimatives (a :*: b) = gtoNamedEventPrimatives a <> gtoNamedEventPrimatives b + +class GToEvent f where + gmakeEvent :: f p -> Event + +instance (GToNamedEventPrimatives f, Datatype d) => GToEvent (D1 d f) where + gmakeEvent m1@(M1 x) = Event + { eventType = cs . lowerFirst $ datatypeName m1 + , eventAttributes = (\(k, v) -> KVPair (Base64.fromBytes k) (Base64.fromBytes v)) <$> gtoNamedEventPrimatives x + } + where + lowerFirst [] = [] + lowerFirst (y : ys) = toLower y : ys + +-- | A class representing a type that can be emitted as an event in the +-- | event logs for the deliverTx response. +class ToEvent e where + toEvent :: e -> Event + + default toEvent :: (Generic e, GToEvent (Rep e)) => e -> Event + toEvent = gmakeEvent . from + +emit + :: ToEvent e + => Member (Output Event) r + => e + -> Sem r () +emit e = output $ toEvent e + + + +-- | Special event wrapper to add contextual event_type info +newtype ContextEvent t = ContextEvent t +instance (A.ToJSON a, ToEvent a) => A.ToJSON (ContextEvent a) where + toJSON (ContextEvent a) = + let Event{eventType} = toEvent a + in A.object [ "event_type" A..= eventType + , "event" A..= A.toJSON a + ] +instance Log.Select a => Log.Select (ContextEvent a) where + select v (ContextEvent a) = Log.select v a + +logEvent + :: forall e r. + (A.ToJSON e, ToEvent e, Log.Select e) + => Member Log.Logger r + => e + -> Sem r () +logEvent event = Log.addContext (ContextEvent event) $ + let Event{eventType} = toEvent event + in Log.log Log.Info eventType diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Gas.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Gas.hs new file mode 100644 index 00000000..5ed39654 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Gas.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE TemplateHaskell #-} +module Tendermint.SDK.BaseApp.Gas + ( + -- * Effect + GasMeter(..) + , GasAmount(..) + , withGas + -- * Eval + , eval + , doNothing + ) where + +import Data.Int (Int64) +import Polysemy (Members, Sem, interpretH, + makeSem, raise, runT) +import Polysemy.Error (Error) +import Polysemy.State (State, get, put) +import Tendermint.SDK.BaseApp.Errors (AppError, + SDKError (OutOfGasException), + throwSDKError) + +newtype GasAmount = GasAmount { unGasAmount :: Int64 } deriving (Eq, Show, Num, Ord) + +data GasMeter m a where + WithGas :: forall m a. GasAmount -> m a -> GasMeter m a + +makeSem ''GasMeter + + +eval + :: Members [Error AppError, State GasAmount] r + => Sem (GasMeter ': r) a + -> Sem r a +eval = interpretH (\case + WithGas gasCost action -> do + remainingGas <- get + let balanceAfterAction = remainingGas - gasCost + if balanceAfterAction < 0 + then throwSDKError OutOfGasException + else do + put balanceAfterAction + a <- runT action + raise $ eval a + ) + +doNothing + :: forall r. + forall a. + Sem (GasMeter ': r) a + -> Sem r a +doNothing = interpretH (\case + WithGas _ action -> do + a <- runT action + raise $ doNothing a + ) diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Logger.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Logger.hs new file mode 100644 index 00000000..00fc14fc --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Logger.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tendermint.SDK.BaseApp.Logger + ( + -- * Effects + Logger(..) + , Tendermint.SDK.BaseApp.Logger.log + , Select(..) + , addContext + + -- * Types + , LogSelect(..) + , Severity(..) + , Verbosity(..) + ) where + +import Data.Aeson (ToJSON (..)) +import Data.Text (Text) +import Polysemy (makeSem) + +data Severity = Debug | Info | Warning | Error | Exception deriving (Eq, Ord) +data LogSelect = All | Some [Text] +data Verbosity = V0 | V1 | V2 | V3 + +-- | Class for selecting object keys for contextual logging +class Select a where + select :: Verbosity -> a -> LogSelect + default select :: Verbosity -> a -> LogSelect + select _ _ = All + +-- | Effect allowing for console logging. +data Logger m a where + Log :: Severity -> Text -> Logger m () + AddContext :: (Select x, ToJSON x) => x -> m a -> Logger m a + +makeSem ''Logger diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Logger/Katip.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Logger/Katip.hs new file mode 100644 index 00000000..e8966aa5 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Logger/Katip.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Tendermint.SDK.BaseApp.Logger.Katip + ( + -- * Setup and Config + LogConfig(..) + , logNamespace + , logContext + , logEnv + , InitialLogNamespace(..) + , initialLogEnvironment + , initialLogProcessName + + -- * Eval + , evalKatip + ) where + +import Control.Lens (over, view) +import Control.Lens.TH (makeLenses) +import qualified Data.Aeson as A +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Katip as K +import Polysemy (Embed, Members, Sem, interpretH, + pureT, raise, runT) +import Polysemy.Reader (Reader, asks, local) +import Tendermint.SDK.BaseApp.Logger + +newtype Object a = Object a + +instance Select a => Select (Object a) where + select v (Object x) = select v x + +instance A.ToJSON a => K.ToObject (Object a) where + toObject (Object a) = case A.toJSON a of + A.Object o -> o + _ -> mempty + +instance (A.ToJSON a, Select a) => K.LogItem (Object a) where + payloadKeys = interpretFromSelect + where + interpretFromSelect kVerbosity obj = + let selectRes = select (kVerbToVerb kVerbosity) obj + in case selectRes of + All -> K.AllKeys + Some ts -> K.SomeKeys ts + kVerbToVerb K.V0 = V0 + kVerbToVerb K.V1 = V1 + kVerbToVerb K.V2 = V2 + kVerbToVerb K.V3 = V3 + +data LogConfig = LogConfig + { _logNamespace :: K.Namespace + , _logContext :: K.LogContexts + , _logEnv :: K.LogEnv + } +makeLenses ''LogConfig + +data InitialLogNamespace = InitialLogNamespace + { _initialLogEnvironment :: Text + , _initialLogProcessName :: Text + } + +makeLenses ''InitialLogNamespace + +instance (Members [Embed IO, Reader LogConfig] r) => K.Katip (Sem r) where + getLogEnv = asks $ view logEnv + localLogEnv f m = local (over logEnv f) m + +instance (Members [Embed IO, Reader LogConfig] r) => K.KatipContext (Sem r) where + getKatipContext = asks $ view logContext + localKatipContext f m = local (over logContext f) m + getKatipNamespace = asks $ view logNamespace + localKatipNamespace f m = local (over logNamespace f) m + +evalKatip + :: forall r a. + K.KatipContext (Sem r) + => Sem (Logger ': r) a + -> Sem r a +evalKatip = do + interpretH (\case + Log severity msg -> do + raise $ + K.logFM (coerceSeverity severity) (fromString . cs $ msg) + pureT () + AddContext obj action -> do + a <- runT action + raise $ K.katipAddContext (Object obj) (evalKatip a) + ) + where + coerceSeverity :: Severity -> K.Severity + coerceSeverity = \case + Debug -> K.DebugS + Info -> K.InfoS + Warning -> K.WarningS + Error -> K.ErrorS + Exception -> K.CriticalS diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Metrics.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Metrics.hs new file mode 100644 index 00000000..38c0f484 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Metrics.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tendermint.SDK.BaseApp.Metrics where + +import Data.String (IsString (..)) +import Data.Text (Text) +import Polysemy + +data CountName = CountName + { countName :: Text + , countLabels :: [(Text, Text)] + } deriving (Eq, Ord) + +instance IsString CountName where + fromString s = CountName (fromString s) mempty + +data HistogramName = HistogramName + { histogramName :: Text + , histogramLabels :: [(Text, Text)] + , histogramBuckets :: [Double] + } deriving (Eq, Ord) + +instance IsString HistogramName where + fromString s = HistogramName (fromString s) mempty defaultBuckets + where defaultBuckets = [0.0001, 0.001, 0.01, 0.1, 0.25, 0.5, 0.75, 1, 10, 100] + +data Metrics m a where + -- | Increments the count of a specific message + IncCount :: CountName -> Metrics m () + -- | Times an action and records it in a histogram + WithTimer :: HistogramName -> m a -> Metrics m a + +makeSem ''Metrics diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Metrics/Prometheus.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Metrics/Prometheus.hs new file mode 100644 index 00000000..2ff0406f --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Metrics/Prometheus.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tendermint.SDK.BaseApp.Metrics.Prometheus + ( + -- | Config and Setup + MetricsScrapingConfig(..) + , prometheusPort + , MetricsState(..) + , metricsRegistry + , metricsCounters + , metricsHistograms + , PrometheusEnv(..) + , envMetricsState + , envMetricsScrapingConfig + , emptyState + , forkMetricsServer + + -- * Utils + , mkPrometheusMetricId + , metricIdStorable + , countToIdentifier + , histogramToIdentifier + + -- * Eval + , evalWithMetrics + , evalNothing + , evalMetrics + ) where + +import Control.Arrow ((***)) +import Control.Concurrent (ThreadId, + forkIO) +import Control.Concurrent.MVar (MVar, + modifyMVar_, + newMVar) +import Control.Lens (makeLenses) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Map.Strict (Map, insert) +import qualified Data.Map.Strict as Map +import Data.String (IsString, + fromString) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (diffUTCTime, + getCurrentTime) +import Polysemy (Embed, Member, + Sem, interpretH, + pureT, raise, + runT) +import Polysemy.Reader (Reader (..), + ask) +import qualified System.Metrics.Prometheus.Concurrent.Registry as Registry +import qualified System.Metrics.Prometheus.Http.Scrape as Http +import qualified System.Metrics.Prometheus.Metric.Counter as Counter +import qualified System.Metrics.Prometheus.Metric.Histogram as Histogram +import qualified System.Metrics.Prometheus.MetricId as MetricId +import Tendermint.SDK.BaseApp.Metrics (CountName (..), HistogramName (..), + Metrics (..)) +-------------------------------------------------------------------------------- +-- Metrics Types +-------------------------------------------------------------------------------- + +-- | Core metrics state +type MetricsMap a = Map (Text, MetricId.Labels) a + +data MetricsState = MetricsState + { _metricsRegistry :: Registry.Registry + , _metricsCounters :: MVar (MetricsMap Counter.Counter) + , _metricsHistograms :: MVar (MetricsMap Histogram.Histogram) + } +makeLenses ''MetricsState + +-- | Intermediary prometheus registry index key +data MetricIdentifier = MetricIdentifier + { metricIdName :: Text + , metricIdLabels :: MetricId.Labels + , metricIdHistoBuckets :: [Double] + } + +instance IsString MetricIdentifier where + fromString s = MetricIdentifier (fromString s) mempty mempty + +fixMetricName :: Text -> Text +fixMetricName = Text.map fixer + where fixer c = if c `elem` validChars then c else '_' + validChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" + +-- indexes + +countToIdentifier :: CountName -> MetricIdentifier +countToIdentifier (CountName name labels) = MetricIdentifier + { metricIdName = fixMetricName name + , metricIdLabels = MetricId.fromList labels + , metricIdHistoBuckets = [] + } + +histogramToIdentifier :: HistogramName -> MetricIdentifier +histogramToIdentifier (HistogramName name labels buckets) = MetricIdentifier + { metricIdName = fixMetricName name + , metricIdLabels = MetricId.fromList labels + , metricIdHistoBuckets = buckets + } + +-- | Prometheus registry index key +mkPrometheusMetricId :: MetricIdentifier -> MetricId.MetricId +mkPrometheusMetricId MetricIdentifier{..} = + MetricId.MetricId (MetricId.Name metricIdName) metricIdLabels + +-- | Index key for storing metrics +metricIdStorable :: MetricIdentifier -> (Text, MetricId.Labels) +metricIdStorable c = (fixMetricName $ metricIdName c, fixMetricLabels $ metricIdLabels c) + where fixMetricLabels = + MetricId.fromList . + map (fixMetricName *** fixMetricName) . + MetricId.toList + + +-------------------------------------------------------------------------------- +-- Config +-------------------------------------------------------------------------------- + +-- | Core metrics config +data MetricsScrapingConfig = MetricsScrapingConfig + { _prometheusPort :: Int + } + +makeLenses ''MetricsScrapingConfig + +data PrometheusEnv = PrometheusEnv + { _envMetricsState :: MetricsState + , _envMetricsScrapingConfig :: MetricsScrapingConfig + } + +makeLenses ''PrometheusEnv + +emptyState :: IO MetricsState +emptyState = do + counters <- newMVar Map.empty + histos <- newMVar Map.empty + registry <- Registry.new + return $ MetricsState registry counters histos + +forkMetricsServer + :: MonadIO m + => PrometheusEnv + -> m ThreadId +forkMetricsServer metCfg = liftIO $ + let PrometheusEnv{..} = metCfg + port = _prometheusPort $ _envMetricsScrapingConfig + MetricsState{..} = _envMetricsState + in forkIO $ Http.serveHttpTextMetrics port ["metrics"] (Registry.sample _metricsRegistry) + +-------------------------------------------------------------------------------- +-- eval +-------------------------------------------------------------------------------- + +evalWithMetrics + :: Member (Embed IO) r + => Member (Reader (Maybe PrometheusEnv)) r + => Sem (Metrics ': r) a + -> Sem r a +evalWithMetrics action = do + mCfg <- ask + case mCfg of + Nothing -> evalNothing action + Just cfg -> evalMetrics (_envMetricsState cfg) action + +evalNothing + :: Sem (Metrics ': r) a + -> Sem r a +evalNothing = do + interpretH (\case + IncCount _ -> pureT () + WithTimer _ action -> do + a <- runT action + raise $ evalNothing a + ) + +-- | Increments existing count, if it doesn't exist, creates a new +-- | counter and increments it. +evalMetrics + :: Member (Embed IO) r + => MetricsState + -> Sem (Metrics ': r) a + -> Sem r a +evalMetrics state@MetricsState{..} = do + interpretH (\case + IncCount ctrName -> do + let c@MetricIdentifier{..} = countToIdentifier ctrName + cid = metricIdStorable c + cMetricIdName = MetricId.Name metricIdName + liftIO $ modifyMVar_ _metricsCounters $ \counterMap -> + case Map.lookup cid counterMap of + Nothing -> do + newCtr <- liftIO $ + Registry.registerCounter cMetricIdName metricIdLabels _metricsRegistry + let newCounterMap = insert cid newCtr counterMap + liftIO $ Counter.inc newCtr + pure newCounterMap + Just ctr -> do + liftIO $ Counter.inc ctr + pure counterMap + pureT () + + -- Updates a histogram with the time it takes to do an action + -- If histogram doesn't exist, creates a new one and observes it. + WithTimer histName action -> do + start <- liftIO $ getCurrentTime + a <- runT action + end <- liftIO $ getCurrentTime + let time = realToFrac (end `diffUTCTime` start) + observeHistogram state histName time + raise $ evalMetrics state a + ) + +-- | Updates a histogram with an observed value +observeHistogram :: MonadIO m => MetricsState -> HistogramName -> Double -> m () +observeHistogram MetricsState{..} histName val = liftIO $ do + let h@MetricIdentifier{..} = histogramToIdentifier histName + hid = metricIdStorable h + hMetricIdName = MetricId.Name metricIdName + modifyMVar_ _metricsHistograms $ \histMap -> + case Map.lookup hid histMap of + Nothing -> do + newHist <- + Registry.registerHistogram hMetricIdName metricIdLabels metricIdHistoBuckets _metricsRegistry + let newHistMap = insert hid newHist histMap + Histogram.observe val newHist + pure $ newHistMap + Just hist -> do + Histogram.observe val hist + pure histMap diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query.hs new file mode 100644 index 00000000..d6a64060 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query.hs @@ -0,0 +1,45 @@ +module Tendermint.SDK.BaseApp.Query + ( serveQueryApplication + -- * Re-Exports + , HasQueryRouter(..) + , StoreLeaf + , storeQueryHandler + , QueryEffs + , module Tendermint.SDK.BaseApp.Query.Types + ) where + +import Control.Lens ((&), (.~)) +import Data.Default.Class (def) +import Data.Proxy +import qualified Network.ABCI.Types.Messages.Response as Response +import Polysemy (Sem) +import Tendermint.SDK.BaseApp.Errors (makeAppError, + queryAppError) +import Tendermint.SDK.BaseApp.Query.Effect (QueryEffs) +import Tendermint.SDK.BaseApp.Query.Router (HasQueryRouter (..)) +import Tendermint.SDK.BaseApp.Query.Store +import Tendermint.SDK.BaseApp.Query.Types +import Tendermint.SDK.BaseApp.Router.Delayed (emptyDelayed) +import Tendermint.SDK.BaseApp.Router.Router (runRouter) +import Tendermint.SDK.BaseApp.Router.Types (Application, + RouteResult (..)) +import Tendermint.SDK.Types.Effects ((:&)) + +serveQueryApplication + :: HasQueryRouter layout r + => Proxy layout + -> Proxy r + -> RouteQ layout (QueryEffs :& r) + -> QueryApplication (Sem r) +serveQueryApplication pl pr server = + toQueryApplication (runRouter (routeQ pl pr (emptyDelayed (Route server))) ()) + +toQueryApplication + :: Application (Sem r) QueryRequest Response.Query + -> QueryApplication (Sem r) +toQueryApplication ra query = do + res <- ra $ parseQueryRequest query + case res of + Fail e -> pure $ def & queryAppError .~ makeAppError e + FailFatal e -> pure $ def & queryAppError .~ makeAppError e + Route a -> pure a diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Effect.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Effect.hs new file mode 100644 index 00000000..d79703f4 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Effect.hs @@ -0,0 +1,47 @@ +module Tendermint.SDK.BaseApp.Query.Effect + ( QueryEffs + , runQuery + ) where + +import Control.Lens ((&), (.~)) +import Data.ByteArray.Base64String (fromBytes) +import Data.Default.Class (def) +import Network.ABCI.Types.Messages.FieldTypes (WrappedVal (..)) +import qualified Network.ABCI.Types.Messages.Response as Response +import Polysemy (Member, Sem) +import Polysemy.Error (Error, runError) +import Polysemy.Tagged (Tagged, tag) +import Tendermint.SDK.BaseApp.Errors (AppError, + queryAppError) +import Tendermint.SDK.BaseApp.Query.Types +import Tendermint.SDK.BaseApp.Store (ReadStore, Scope (..)) +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Effects ((:&)) + +type QueryEffs = + '[ ReadStore + , Error AppError + ] + +runQuery + :: HasCodec a + => Member (Tagged 'QueryAndMempool ReadStore) r + => Sem (QueryEffs :& r) (QueryResult a) + -> Sem r Response.Query +runQuery query = do + eRes <- eval query + pure $ case eRes of + Left e -> def & queryAppError .~ e + Right QueryResult{..} -> + def + & Response._queryIndex .~ WrappedVal queryResultIndex + & Response._queryKey .~ queryResultKey + & Response._queryValue .~ fromBytes (encode queryResultData) + & Response._queryProof .~ queryResultProof + & Response._queryHeight .~ WrappedVal queryResultHeight + +eval + :: Member (Tagged 'QueryAndMempool ReadStore) r + => Sem (QueryEffs :& r) (QueryResult a) + -> Sem r (Either AppError (QueryResult a)) +eval = runError . tag diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Router.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Router.hs new file mode 100644 index 00000000..2d01948a --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Router.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE UndecidableInstances #-} +module Tendermint.SDK.BaseApp.Query.Router + ( HasQueryRouter(..) + , methodRouter + ) where + +import Control.Monad (join) +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Text (Text) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.ABCI.Types.Messages.Response as Response +import Network.HTTP.Types.URI (QueryText, + parseQueryText) +import Polysemy (Member, Sem) +import Polysemy.Tagged (Tagged) +import Servant.API +import Servant.API.Modifiers (FoldLenient, + FoldRequired, + RequestArgument, + unfoldRequestArgument) +import Tendermint.SDK.BaseApp.Query.Effect (QueryEffs, runQuery) +import Tendermint.SDK.BaseApp.Query.Types (EmptyQueryServer (..), + Leaf, QA, QueryArgs (..), + QueryData (..), + QueryRequest (..), + QueryResult (..)) +import qualified Tendermint.SDK.BaseApp.Router as R +import Tendermint.SDK.BaseApp.Store (ReadStore, Scope (..)) +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Effects ((:&)) +import Web.HttpApiData (FromHttpApiData (..), + parseUrlPieceMaybe) + + +-------------------------------------------------------------------------------- + +-- | This class is used to construct a router given a 'layout' type. The layout +-- | is constructed using the combinators that appear in the instances here, no other +-- | Servant combinators are recognized. +class HasQueryRouter layout r where + -- | A routeQ handler. + type RouteQ layout r :: * + -- | Transform a routeQ handler into a 'Router'. + routeQ + :: Proxy layout + -> Proxy r + -> R.Delayed (Sem r) env QueryRequest (RouteQ layout (QueryEffs :& r)) + -> R.Router env r QueryRequest Response.Query + + hoistQueryRouter :: Proxy layout -> Proxy r -> (forall a. Sem s a -> Sem s' a) -> RouteQ layout s -> RouteQ layout s' + +instance (HasQueryRouter a r, HasQueryRouter b r) => HasQueryRouter (a :<|> b) r where + type RouteQ (a :<|> b) r = RouteQ a r :<|> RouteQ b r + + routeQ _ pr server = + R.choice (routeQ (Proxy @a) pr ((\ (a :<|> _) -> a) <$> server)) + (routeQ (Proxy @b) pr ((\ (_ :<|> b) -> b) <$> server)) + hoistQueryRouter _ pr nat (a :<|> b) = + hoistQueryRouter (Proxy @a) pr nat a :<|> hoistQueryRouter (Proxy @b) pr nat b + +instance (HasQueryRouter sublayout r, KnownSymbol path) => HasQueryRouter (path :> sublayout) r where + + type RouteQ (path :> sublayout) r = RouteQ sublayout r + + routeQ _ pr subserver = + R.pathRouter (cs (symbolVal proxyPath)) (routeQ (Proxy :: Proxy sublayout) pr subserver) + where proxyPath = Proxy :: Proxy path + + hoistQueryRouter _ pr nat = hoistQueryRouter (Proxy @sublayout) pr nat + +instance ( HasQueryRouter sublayout r, KnownSymbol sym, FromHttpApiData a + , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) + ) => HasQueryRouter (QueryParam' mods sym a :> sublayout) r where + + type RouteQ (QueryParam' mods sym a :> sublayout) r = RequestArgument mods a -> RouteQ sublayout r + + routeQ _ pr subserver = + let querytext :: QueryRequest -> Network.HTTP.Types.URI.QueryText + querytext q = parseQueryText . cs $ queryRequestParamString q + paramname = cs $ symbolVal (Proxy :: Proxy sym) + parseParam q = unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev + where + mev :: Maybe (Either Text a) + mev = fmap parseQueryParam $ join $ lookup paramname $ querytext q + errReq = R.delayedFail $ R.InvalidRequest ("Query parameter " <> cs paramname <> " is required.") + errSt e = R.delayedFail $ R.InvalidRequest ("Error parsing query param " <> cs paramname <> " " <> cs e <> ".") + delayed = R.addParameter subserver $ R.withRequest parseParam + in routeQ (Proxy :: Proxy sublayout) pr delayed + + hoistQueryRouter _ pr nat f = hoistQueryRouter (Proxy @sublayout) pr nat . f + +instance (FromHttpApiData a, HasQueryRouter sublayout r) => HasQueryRouter (Capture' mods capture a :> sublayout) r where + + type RouteQ (Capture' mods capture a :> sublayout) r = a -> RouteQ sublayout r + + routeQ _ pr subserver = + R.CaptureRouter $ + routeQ (Proxy :: Proxy sublayout) + pr + (R.addCapture subserver $ \ txt -> case parseUrlPieceMaybe txt of + Nothing -> R.delayedFail R.PathNotFound + Just v -> return v + ) + hoistQueryRouter _ pr nat f = hoistQueryRouter (Proxy @sublayout) pr nat . f + +instance (QueryData a, HasQueryRouter sublayout r) => HasQueryRouter (QA a :> sublayout) r where + + type RouteQ (QA a :> sublayout) r = QueryArgs a -> RouteQ sublayout r + + routeQ _ pr subserver = + let parseQueryArgs QueryRequest{..} = case fromQueryData queryRequestData of + Left e -> R.delayedFail $ R.InvalidRequest ("Error parsing query data, " <> cs e <> ".") + Right a -> pure QueryArgs + { queryArgsData = a + , queryArgsHeight = queryRequestHeight + , queryArgsProve = queryRequestProve + } + delayed = R.addBody subserver $ R.withRequest parseQueryArgs + in routeQ (Proxy :: Proxy sublayout) pr delayed + + hoistQueryRouter _ pr nat f = hoistQueryRouter (Proxy @sublayout) pr nat . f + +instance (Member (Tagged 'QueryAndMempool ReadStore) r, HasCodec a) => HasQueryRouter (Leaf a) r where + + type RouteQ (Leaf a) r = Sem r (QueryResult a) + routeQ _ _ = methodRouter + hoistQueryRouter _ _ = ($) + +instance HasQueryRouter EmptyQueryServer r where + type RouteQ EmptyQueryServer r = EmptyQueryServer + routeQ _ _ _ = R.StaticRouter mempty mempty + hoistQueryRouter _ _ _ = id + +-------------------------------------------------------------------------------- + +methodRouter + :: HasCodec a + => Member (Tagged 'QueryAndMempool ReadStore) r + => R.Delayed (Sem r) env req (Sem (QueryEffs :& r) (QueryResult a)) + -> R.Router env r req Response.Query +methodRouter action = + let route' env q = R.runAction (runQuery <$> action) env q (pure . R.Route) + in R.leafRouter route' diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Store.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Store.hs new file mode 100644 index 00000000..0234ee9a --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Store.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Tendermint.SDK.BaseApp.Query.Store + ( StoreLeaf + , storeQueryHandler + --, StoreQueryHandlers(..) + ) where + +--import Control.Lens (to, (^.)) +import Data.ByteArray.Base64String (fromBytes) +import Data.Proxy +--import Data.String.Conversions (cs) +import Data.Word (Word64) +--import GHC.TypeLits (KnownSymbol, symbolVal) +import Polysemy (Member, Members, Sem) +import Polysemy.Error (throw) +import Polysemy.Tagged (Tagged) +import Servant.API ((:>)) +import Tendermint.SDK.BaseApp.Errors (makeAppError) +import Tendermint.SDK.BaseApp.Query.Effect (QueryEffs) +import Tendermint.SDK.BaseApp.Query.Router (HasQueryRouter (..)) +import Tendermint.SDK.BaseApp.Query.Types (Leaf, QA, QueryArgs (..), + QueryData, + QueryResult (..)) +import Tendermint.SDK.BaseApp.Router (RouterError (..)) +import Tendermint.SDK.BaseApp.Store (RawKey (..), ReadStore, + Scope (..), makeKeyBytes) +import qualified Tendermint.SDK.BaseApp.Store.Array as A +import qualified Tendermint.SDK.BaseApp.Store.List as L +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import qualified Tendermint.SDK.BaseApp.Store.Var as V +import Tendermint.SDK.Codec (HasCodec) + +{- + +"account" :> StoreLeaf (Map Address Account) :<|> + + "count" :> StoreLeaf (Var Count) :<|> + + "counts" :> StoreLeaf (Array Count) + +-} + + +data StoreLeaf a + +instance (QueryData k, HasCodec v, Member (Tagged 'QueryAndMempool ReadStore) r) => HasQueryRouter (StoreLeaf (M.Map k v)) r where + + type RouteQ (StoreLeaf (M.Map k v)) r = RouteQ (QA k :> Leaf v) r + routeQ _ = routeQ (Proxy @(QA k :> Leaf v)) + hoistQueryRouter _ pr nat f = hoistQueryRouter (Proxy @(QA k :> Leaf v)) pr nat f + +instance (HasCodec a, Member (Tagged 'QueryAndMempool ReadStore) r) => HasQueryRouter (StoreLeaf (V.Var a)) r where + + type RouteQ (StoreLeaf (V.Var a)) r = RouteQ (QA () :> Leaf a) r + routeQ _ = routeQ (Proxy @(QA () :> Leaf a)) + hoistQueryRouter _ pr nat f = hoistQueryRouter (Proxy @(QA () :> Leaf a)) pr nat f + +instance (HasCodec a, Member (Tagged 'QueryAndMempool ReadStore) r) => HasQueryRouter (StoreLeaf (A.Array a)) r where + + type RouteQ (StoreLeaf (A.Array a)) r = RouteQ (QA Word64 :> Leaf a) r + routeQ _ = routeQ (Proxy @(QA Word64 :> Leaf a)) + hoistQueryRouter _ pr nat f = hoistQueryRouter (Proxy @(QA Word64 :> Leaf a)) pr nat f + +class StoreQueryHandler ns h where + storeQueryHandler :: ns -> h + +instance + ( RawKey k + , HasCodec v + , Members QueryEffs r + ) + => StoreQueryHandler (M.Map k v) (QueryArgs k -> Sem r (QueryResult v)) where + storeQueryHandler m QueryArgs{..} = do + let key = queryArgsData + mRes <- M.lookup key m + case mRes of + Nothing -> throw . makeAppError $ ResourceNotFound + Just (res :: v) -> pure $ QueryResult + -- TODO: actually handle proofs + { queryResultData = res + , queryResultIndex = 0 + , queryResultKey = fromBytes . makeKeyBytes . M.makeFullStoreKey m $ key + , queryResultProof = Nothing + , queryResultHeight = 0 + } + +instance + ( HasCodec a + , Members QueryEffs r + ) + => StoreQueryHandler (A.Array a) (QueryArgs Word64 -> Sem r (QueryResult a)) where + storeQueryHandler as QueryArgs{..} = do + let i = queryArgsData + mRes <- as A.!! i + case mRes of + Nothing -> throw . makeAppError $ ResourceNotFound + Just (res :: a) -> pure $ QueryResult + -- TODO: actually handle proofs + { queryResultData = res + , queryResultIndex = 0 + , queryResultKey = fromBytes . makeKeyBytes . A.makeFullStoreKey as $ i + , queryResultProof = Nothing + , queryResultHeight = 0 + } + +instance + ( HasCodec a + , Members QueryEffs r + ) + => StoreQueryHandler (L.List a) (QueryArgs Word64 -> Sem r (QueryResult a)) where + storeQueryHandler as QueryArgs{..} = do + let i = queryArgsData + mRes <- as L.!! i + case mRes of + Nothing -> throw . makeAppError $ ResourceNotFound + Just (res :: a) -> pure $ QueryResult + -- TODO: actually handle proofs + { queryResultData = res + , queryResultIndex = 0 + , queryResultKey = fromBytes . makeKeyBytes . L.makeFullStoreKey as $ i + , queryResultProof = Nothing + , queryResultHeight = 0 + } + +instance + ( HasCodec a + , Members QueryEffs r + ) + => StoreQueryHandler (V.Var a) (QueryArgs () -> Sem r (QueryResult a)) where + storeQueryHandler var QueryArgs{..} = do + mRes <- V.takeVar var + case mRes of + Nothing -> throw . makeAppError $ ResourceNotFound + Just (res :: a) -> pure $ QueryResult + -- TODO: actually handle proofs + { queryResultData = res + , queryResultIndex = 0 + , queryResultKey = fromBytes . makeKeyBytes . V.makeFullStoreKey $ var + , queryResultProof = Nothing + , queryResultHeight = 0 + } + +--class StoreQueryHandlers ns r where +-- type QueryApi kvs :: * +-- storeQueryHandlers :: Proxy kvs -> Store ns -> Proxy r -> RouteQ (QueryApi kvs) r +-- +--instance +-- ( IsKey k ns +-- , a ~ Value k ns +-- , HasCodec a +-- , Members QueryEffs r +-- ) => StoreQueryHandlers ns r where +-- type QueryApi (s :> StoreLeaf (M.Map k v)) = s :> QA k :> StoreLeaf a +-- storeQueryHandlers _ store _ = storeQueryHandler (Proxy :: Proxy a) store + +--instance +-- ( IsKey k ns +-- , a ~ Value k ns +-- , HasCodec a +-- , StoreQueryHandlers ((k', a') ': as) ns r +-- , Members QueryEffs r +-- ) => StoreQueryHandlers ((k,a) ': (k', a') : as) ns r where +-- type (QueryApi ((k, a) ': (k', a') : as)) = (QA k :> StoreLeaf a) :<|> QueryApi ((k', a') ': as) +-- storeQueryHandlers _ store pr = +-- storeQueryHandler (Proxy :: Proxy a) store :<|> +-- storeQueryHandlers (Proxy :: Proxy ((k', a') ': as)) store pr +-- diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Types.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Types.hs new file mode 100644 index 00000000..9eb9ec9a --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Types.hs @@ -0,0 +1,114 @@ +module Tendermint.SDK.BaseApp.Query.Types + ( + -- * Server combinators + Leaf + , QA + , EmptyQueryServer(..) + , QueryData(..) + + -- * Query Application + , QueryApplication + , QueryRequest(..) + , parseQueryRequest + , QueryArgs(..) + , defaultQueryArgs + , QueryResult(..) + + ) where + +import Control.Lens (from, lens, to, (^.)) +import Data.ByteArray.Base64String (Base64String, + fromBytes, toBytes) +import Data.Int (Int64) +import Data.Text (Text, breakOn, uncons) +import Data.Word (Word64) +import Network.ABCI.Types.Messages.FieldTypes (Proof, WrappedVal (..)) +import qualified Network.ABCI.Types.Messages.Request as Request +import qualified Network.ABCI.Types.Messages.Response as Response +import Tendermint.SDK.BaseApp.Router.Types (HasPath (..)) +import Tendermint.SDK.BaseApp.Store (RawKey (..)) +import Tendermint.SDK.Types.Address (Address) + +data Leaf (a :: *) + +data QA (a :: *) + +-------------------------------------------------------------------------------- + +type QueryApplication m = Request.Query -> m Response.Query + +-------------------------------------------------------------------------------- + +data QueryRequest = QueryRequest + { queryRequestPath :: Text + , queryRequestParamString :: Text + , queryRequestData :: Base64String + , queryRequestProve :: Bool + , queryRequestHeight :: Int64 + } deriving (Eq, Show) + +parseQueryRequest + :: Request.Query + -> QueryRequest +parseQueryRequest Request.Query{..} = + let (p, queryStrQ) = breakOn "?" queryPath + queryStr = case Data.Text.uncons queryStrQ of + Nothing -> "" + Just ('?', rest) -> rest + _ -> error "Impossible result parsing query string from path." + in QueryRequest + { queryRequestPath = p + , queryRequestParamString = queryStr + , queryRequestData = queryData + , queryRequestProve = queryProve + , queryRequestHeight = unWrappedVal queryHeight + } + +instance HasPath QueryRequest where + path = lens queryRequestPath (\q p -> q {queryRequestPath = p}) + +-------------------------------------------------------------------------------- + +data QueryArgs a = QueryArgs + { queryArgsProve :: Bool + , queryArgsData :: a + , queryArgsHeight :: Int64 + } deriving Functor + +-- wrap data with default query fields +defaultQueryArgs :: QueryArgs () +defaultQueryArgs = QueryArgs + { queryArgsData = () + , queryArgsHeight = -1 + , queryArgsProve = False + } + +data QueryResult a = QueryResult + { queryResultData :: a + , queryResultIndex :: Int64 + , queryResultKey :: Base64String + , queryResultProof :: Maybe Proof + , queryResultHeight :: Int64 + } deriving (Eq, Show, Functor) + +-------------------------------------------------------------------------------- + +-- | This class is used to parse the 'data' field of the query request message. +-- | The default method assumes that the 'data' is simply the key for the +-- | value being queried. +class QueryData a where + fromQueryData :: Base64String -> Either String a + toQueryData :: a -> Base64String + + default fromQueryData :: RawKey a => Base64String -> Either String a + fromQueryData bs = Right (toBytes bs ^. from rawKey) + + default toQueryData :: RawKey a => a -> Base64String + toQueryData k = k ^. rawKey . to fromBytes + +instance QueryData Address +instance QueryData Text +instance QueryData Word64 +instance QueryData () + +data EmptyQueryServer = EmptyQueryServer diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router.hs new file mode 100644 index 00000000..8bbca1a6 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router.hs @@ -0,0 +1,9 @@ +module Tendermint.SDK.BaseApp.Router + ( module Tendermint.SDK.BaseApp.Router.Types + , module Tendermint.SDK.BaseApp.Router.Router + , module Tendermint.SDK.BaseApp.Router.Delayed + ) where + +import Tendermint.SDK.BaseApp.Router.Delayed +import Tendermint.SDK.BaseApp.Router.Router +import Tendermint.SDK.BaseApp.Router.Types diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router/Delayed.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router/Delayed.hs new file mode 100644 index 00000000..9feeb877 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router/Delayed.hs @@ -0,0 +1,128 @@ +module Tendermint.SDK.BaseApp.Router.Delayed + ( Delayed + , runAction + , delayedFail + , addBody + , addCapture + , addParameter + , emptyDelayed + , withRequest + ) where + +import Control.Monad.Reader (MonadReader, ReaderT, ask, + runReaderT) +import Control.Monad.Trans (MonadTrans (..)) +import Polysemy (Sem) +import Tendermint.SDK.BaseApp.Router.Types (RouteResult (..), + RouteResultT (..), + RouterError (..)) + +-------------------------------------------------------------------------------- +-- NOTE: most of this was vendored and repurposed from servant + + +newtype DelayedM m req a = + DelayedM { runDelayedM' :: ReaderT req (RouteResultT m) a } + deriving (Functor, Applicative, Monad, MonadReader req) + +liftRouteResult :: Monad m => RouteResult a -> DelayedM m req a +liftRouteResult x = DelayedM $ lift $ RouteResultT . return $ x + +runDelayedM :: DelayedM m req a -> req -> m (RouteResult a) +runDelayedM m req = runRouteResultT $ runReaderT (runDelayedM' m) req + +-------------------------------------------------------------------------------- + +data Delayed m env req a where + Delayed :: { delayedCaptures :: env -> DelayedM m req captures + , delayedBody :: DelayedM m req body + , delayedParams :: DelayedM m req params + , delayedHandler :: captures -> body -> params -> req -> RouteResult a + } -> Delayed m env req a + +instance Functor m => Functor (Delayed m env req) where + fmap f Delayed{..} = + Delayed { delayedHandler = \captures body params req -> f <$> delayedHandler captures body params req + , .. + } + +runDelayed + :: Monad m + => Delayed m env req a + -> env + -> req + -> m (RouteResult a) +runDelayed Delayed{..} env = runDelayedM (do + req <- ask + captures <- delayedCaptures env + body <- delayedBody + params <- delayedParams + liftRouteResult $ delayedHandler captures body params req + ) + +runAction + :: Delayed (Sem r) env req (Sem r a) + -> env + -> req + -> (a -> Sem r (RouteResult b)) + -> Sem r (RouteResult b) +runAction action env req k = do + res <- runDelayed action env req + case res of + Route a -> k =<< a + Fail e -> pure $ Fail e + FailFatal e -> pure $ FailFatal e + +-- | Fail with the option to recover. +delayedFail :: Monad m => RouterError -> DelayedM m req a +delayedFail err = liftRouteResult $ Fail err + +addBody + :: Monad m + => Delayed m env req (a -> b) + -> DelayedM m req a + -> Delayed m env req b +addBody Delayed{..} newBody = + Delayed + { delayedBody = (,) <$> delayedBody <*> newBody + , delayedHandler = \caps (body, bodyNew) p req -> ($ bodyNew) <$> delayedHandler caps body p req + , .. + } + +addCapture + :: Monad m + => Delayed m env req (a -> b) + -> (captured -> DelayedM m req a) + -> Delayed m (captured, env) req b +addCapture Delayed{..} new = + Delayed + { delayedCaptures = \ (txt, env) -> (,) <$> delayedCaptures env <*> new txt + , delayedHandler = \ (x, v) body p query -> ($ v) <$> delayedHandler x body p query + , .. + } -- Note [Existential Record Update] + +addParameter + :: Monad m + => Delayed m env req (a -> b) + -> DelayedM m req a + -> Delayed m env req b +addParameter Delayed {..} new = + Delayed + { delayedParams = (,) <$> delayedParams <*> new + , delayedHandler = \caps body (p, pNew) query -> ($ pNew) <$> delayedHandler caps body p query + , .. + } + +emptyDelayed :: Monad m => RouteResult a -> Delayed m b req a +emptyDelayed response = + let r = pure () + in Delayed (const r) r r $ \_ _ _ _ -> response + +-- | Gain access to the incoming request. +withRequest + :: Monad m + => (req -> DelayedM m req a) + -> DelayedM m req a +withRequest f = do + req <- ask + f req diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router/Router.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router/Router.hs new file mode 100644 index 00000000..32689af3 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router/Router.hs @@ -0,0 +1,95 @@ +module Tendermint.SDK.BaseApp.Router.Router + ( Router + , Router'(..) + , runRouter + , pathRouter + , leafRouter + , choice + ) where + +import Control.Lens ((&), (.~), (^.)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Types (decodePathSegments) +import Polysemy (Sem) +import Tendermint.SDK.BaseApp.Router.Types (Application, HasPath (..), + RouteResult (..), + RouterError (..)) + + +-- NOTE: most of this was vendored and repurposed from servant + +data Router' env a = + StaticRouter (Map Text (Router' env a)) [env -> a] + | CaptureRouter (Router' (Text, env) a) + | Choice (Router' env a) (Router' env a) + + +type Router env r req res = Router' env (Application (Sem r) req res) + +pathRouter + :: Text + -> Router' env a + -> Router' env a +pathRouter t r = StaticRouter (M.singleton t r) [] + +leafRouter + :: (env -> a) + -> Router' env a +leafRouter l = StaticRouter M.empty [l] + +choice + :: Router' env a + -> Router' env a + -> Router' env a +choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) = + StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2) +choice (CaptureRouter router1) (CaptureRouter router2) = + CaptureRouter (choice router1 router2) +choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3 +choice router1 router2 = Choice router1 router2 + +runRouter + :: HasPath req + => Router env r req res + -> env + -> Application (Sem r) req res +runRouter router env req = + case router of + StaticRouter table ls -> + case decodePathSegments . T.encodeUtf8 $ req ^. path of + [] -> runChoice ls env req + -- This case is to handle trailing slashes. + [""] -> runChoice ls env req + first : rest | Just router' <- M.lookup first table + -> let req' = req & path .~ T.intercalate "/" rest + in runRouter router' env req' + _ -> pure $ Fail PathNotFound + CaptureRouter router' -> + case decodePathSegments . T.encodeUtf8 $ req ^. path of + [] -> pure $ Fail PathNotFound + -- This case is to handle trailing slashes. + [""] -> pure $ Fail PathNotFound + first : rest + -> let req' = req & path .~ T.intercalate "/" rest + in runRouter router' (first, env) req' + Choice r1 r2 -> + runChoice [runRouter r1, runRouter r2] env req + +runChoice + :: [env -> Application (Sem r) req res] + -> env + -> Application (Sem r) req res +runChoice ls = + case ls of + [] -> \ _ _ -> pure $ Fail PathNotFound + [r] -> r + (r : rs) -> + \ env query -> do + response1 <- r env query + case response1 of + Fail _ -> runChoice rs env query + _ -> pure response1 diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router/Types.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router/Types.hs new file mode 100644 index 00000000..ea18cd7d --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Router/Types.hs @@ -0,0 +1,94 @@ +module Tendermint.SDK.BaseApp.Router.Types + ( Application + , RouterError(..) + , RouteResult(..) + , RouteResultT(..) + , HasPath(..) + ) where + +import Control.Lens (Lens') +import Control.Monad (ap) +import Control.Monad.Trans (MonadTrans (..)) +import Data.Text (Text) +import Tendermint.SDK.BaseApp.Errors (AppError (..), IsAppError (..)) + +-------------------------------------------------------------------------------- + +type Application m req res = req -> m (RouteResult res) + +-------------------------------------------------------------------------------- + +data RouterError = + PathNotFound + | ResourceNotFound + | InvalidRequest Text + | InternalError Text + deriving (Show) + +instance IsAppError RouterError where + makeAppError PathNotFound = + AppError + { appErrorCode = 1 + , appErrorCodespace = "router" + , appErrorMessage = "Path not found." + } + makeAppError ResourceNotFound = + AppError + { appErrorCode = 2 + , appErrorCodespace = "router" + , appErrorMessage = "Resource not found." + } + makeAppError (InvalidRequest msg) = + AppError + { appErrorCode = 3 + , appErrorCodespace = "router" + , appErrorMessage = "Invalid request: " <> msg + } + makeAppError (InternalError _) = + AppError + { appErrorCode = 4 + , appErrorCodespace = "router" + , appErrorMessage = "Internal error." + } + +-------------------------------------------------------------------------------- +-- NOTE: most of this was vendored and repurposed from servant. + +data RouteResult a = + Fail RouterError + | FailFatal RouterError + | Route a + deriving (Functor) + +instance Applicative RouteResult where + pure = return + (<*>) = ap + +instance Monad RouteResult where + return = Route + (>>=) m f = case m of + Route a -> f a + Fail e -> Fail e + FailFatal e -> FailFatal e + +data RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) } + deriving (Functor) + +instance MonadTrans RouteResultT where + lift m = RouteResultT $ fmap Route m + +instance Monad m => Applicative (RouteResultT m) where + pure = return + (<*>) = ap + +instance Monad m => Monad (RouteResultT m) where + return = RouteResultT . return . Route + (>>=) m f = RouteResultT $ do + a <- runRouteResultT m + case a of + Route a' -> runRouteResultT $ f a' + Fail e -> return $ Fail e + FailFatal e -> return $ FailFatal e + +class HasPath t where + path :: Lens' t Text diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store.hs new file mode 100644 index 00000000..893112e6 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store.hs @@ -0,0 +1,5 @@ +module Tendermint.SDK.BaseApp.Store + ( module Tendermint.SDK.BaseApp.Store.RawStore + ) where + +import Tendermint.SDK.BaseApp.Store.RawStore diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/Array.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/Array.hs new file mode 100644 index 00000000..830e82b1 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/Array.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Tendermint.SDK.BaseApp.Store.Array + ( Array + , makeArray + , makeFullStoreKey + , append + , modifyAtIndex + , deleteWhen + , (!!) + , elemIndex + , toList + ) where + +import Control.Lens (iso, (^.)) +import qualified Data.ByteArray.HexString as Hex +import qualified Data.ByteString as BS +import Data.Maybe (fromMaybe) +import Data.String.Conversions (cs) +import Data.Word (Word64) +import Polysemy +import Polysemy.Error (Error) +import Prelude hiding (foldl, length, + (!!)) +import qualified Prelude as P (length) +import Tendermint.SDK.BaseApp.Errors (AppError, + SDKError (InternalError), + throwSDKError) +import Tendermint.SDK.BaseApp.Store.RawStore as S +import Tendermint.SDK.Codec (HasCodec (..)) + + + +-- | A 'Array a' is an appendable list whose elements can be accessed +-- | by their index. You can also delete from the list, in which case accessing +-- | that index will result in a `Nothing`. +data Array (a :: *) = Array + { arrayStore :: S.Store (Array a) } + +-- | Represents an index into a list +newtype Idx = Idx {unIdx :: Word64} deriving (Eq, Show, Ord, Num) + +instance S.RawKey Idx where + rawKey = iso elementKey unElementKey + +instance S.IsKey Idx (Array a) where + type Value Idx (Array a) = a + +-- Internal, used for accessing list length. +data LengthKey = LengthKey + +instance S.RawKey LengthKey where + rawKey = iso (const lengthKey) unLengthKey + +instance S.IsKey LengthKey (Array a) where + type Value LengthKey (Array a) = Word64 + +-- | Smart constuctor to make sure we're making a 'Array' from +-- | the appropriate key type. +makeArray + :: S.IsKey k ns + => S.Value k ns ~ Array a + => k + -> S.Store ns + -> S.Value k ns +makeArray k store = + let skr :: S.KeyRoot (Array a) + skr = S.KeyRoot $ k ^. S.rawKey + in Array $ S.nestStore store (S.makeStore skr) + +makeFullStoreKey + :: Array a + -> Word64 + -> S.StoreKey +makeFullStoreKey Array{..} i = + S.makeStoreKey arrayStore (Idx i) + +-- | Add an item to the end of the list. +append + :: Members [Error AppError, S.ReadStore, S.WriteStore] r + => HasCodec a + => a + -> Array a + -> Sem r () +append a as@Array{..} = do + n <- length as + writeAt (Idx n) a as + S.put arrayStore LengthKey (n + 1) + +-- | Access an item directly by its index. +(!!) + :: Members [Error AppError, S.ReadStore] r + => HasCodec a + => Array a + -> Word64 + -> Sem r (Maybe a) +as@Array{..} !! i = do + let n = Idx i + len <- length as + if Idx (len - 1) < n + then pure Nothing + else S.get arrayStore n + +infixl 9 !! + +-- | Modify a list at a particular index, return the +-- | updated value if the element was found. +modifyAtIndex + :: Members [Error AppError, S.ReadStore, S.WriteStore] r + => HasCodec a + => Word64 + -> (a -> a) + -> Array a + -> Sem r (Maybe a) +modifyAtIndex i f as = do + mRes <- as !! i + case mRes of + Nothing -> pure Nothing + Just res -> do + let a' = f res + writeAt (Idx i) a' as + pure (Just a') + +-- | Delete when the predicate evaluates to true. +deleteWhen + :: Members [Error AppError, S.ReadStore, S.WriteStore] r + => HasCodec a + => (a -> Bool) + -> Array a + -> Sem r () +deleteWhen p as@Array{..} = do + len <- length as + delete' 0 (len - 1) + where + delete' n end = + if n > end + then pure () + else do + mRes <- as !! n + case mRes of + Nothing -> delete' (n + 1) end + Just res -> + if p res + then do + S.delete arrayStore (Idx n) + delete' (n + 1) end + else delete' (n + 1) end + +-- | Get the first index where an element appears in the list. +elemIndex + :: Members [Error AppError, S.ReadStore] r + => HasCodec a + => Eq a + => a + -> Array a + -> Sem r (Maybe Word64) +elemIndex a as = do + len <- length as + elemIndex' 0 len + where + elemIndex' n len + | n == len = pure Nothing + | otherwise = do + mRes <- as !! n + let keepLooking = elemIndex' (n + 1) len + case mRes of + Nothing -> keepLooking + Just a' -> if a == a' then pure $ Just n else keepLooking + +foldl + :: Members [Error AppError, S.ReadStore] r + => HasCodec a + => (b -> a -> b) + -> b + -> Array a + -> Sem r b +foldl f b as = do + len <- length as + foldl' 0 len b + where + foldl' currentIndex end accum + | currentIndex == end = pure accum + | currentIndex < end = do + ma <- as !! currentIndex + case ma of + Nothing -> foldl' (currentIndex + 1) end accum + Just a -> foldl' (currentIndex + 1) end $! f accum a + | otherwise = error "Impossible case in Array foldl!" + +-- | View the 'Array' as a 'Array'. +toList + :: Members [Error AppError, S.ReadStore] r + => HasCodec a + => Array a + -> Sem r [a] +toList = foldl (flip (:)) [] + +-------------------------------------------------------------------------------- +-- Internal functions +-------------------------------------------------------------------------------- + +-- NOTE: Many things in this module are completely ad hoc, but tries to follow +-- the patterns set in https://github.com/cosmos/cosmos-sdk/blob/master/store/list/list.go +-- for future compatability, and because this ad-hoc-ness doesn't leak out. + +lengthKey :: BS.ByteString +lengthKey = Hex.toBytes "0x00" + +unLengthKey :: BS.ByteString -> LengthKey +unLengthKey bs + | bs == Hex.toBytes "0x00" = LengthKey + | otherwise = error $ "Couldn't parse LengthKey bytes: " <> cs bs + +elementKey + :: Idx + -> BS.ByteString +elementKey (Idx k) = + let padToNChars n a = + let nZeros = n - P.length a + in replicate nZeros '0' <> a + in Hex.toBytes "0x01" <> cs (padToNChars 20 $ show k) + +unElementKey + :: BS.ByteString + -> Idx +unElementKey bs = + let str = cs $ fromMaybe (error "Idx missing 0x01 prefix") $ + BS.stripPrefix (Hex.toBytes "0x01") bs + in Idx . read . dropWhile (== '0') $ str + +length + :: Members [Error AppError, S.ReadStore] r + => Array a + -> Sem r Word64 +length Array{..} = do + mLen <- S.get arrayStore LengthKey + pure $ fromMaybe 0 mLen + +writeAt + :: Members [Error AppError, S.ReadStore, S.WriteStore] r + => HasCodec a + => Idx + -> a + -> Array a + -> Sem r () +writeAt idx@(Idx i) a as@Array{..} = do + len <- length as + writeAt' len + where + writeAt' len + | i == len = do + S.put arrayStore idx a + S.put arrayStore LengthKey i + | i < len = + S.put arrayStore idx a + | otherwise = throwSDKError $ InternalError "Cannot write past list length index." diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/IAVLStore.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/IAVLStore.hs new file mode 100644 index 00000000..3fb90455 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/IAVLStore.hs @@ -0,0 +1,158 @@ +module Tendermint.SDK.BaseApp.Store.IAVLStore + ( + -- * Environment + IAVLVersions(..) + , initIAVLVersions + -- * Eval + , evalStoreEffs + -- * Re-Exports + , GrpcClient + , GrpcConfig(..) + , initGrpcClient + ) where + +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (void) +import Control.Monad.IO.Class +import Data.ByteArray.Base64String (fromBytes) +import Data.IORef (IORef, newIORef, + readIORef, writeIORef) +import Data.ProtoLens.Message (defMessage) +import Data.Text (pack) +import qualified Database.IAVL.RPC as IAVL +import Database.IAVL.RPC.Types (GrpcConfig (..), + initGrpcClient) +import Network.GRPC.Client (RawReply) +import Network.GRPC.Client.Helpers (GrpcClient) +import Network.HTTP2.Client (ClientIO, + TooMuchConcurrency, + runClientIO) +import Polysemy (Embed, Member, Members, + Sem, interpret) +import Polysemy.Error (Error) +import Polysemy.Reader (Reader, ask) +import Polysemy.Tagged (untag) +import qualified Proto.Iavl.Api_Fields as Api +import Tendermint.SDK.BaseApp.Errors (AppError, SDKError (..)) +import Tendermint.SDK.BaseApp.Store.RawStore (CommitBlock (..), + CommitResponse (..), + ReadStore (..), + StoreEffs, + Transaction (..), + Version (..), + WriteStore (..), + makeKeyBytes) +import Tendermint.SDK.Types.Effects ((:&)) + +data IAVLVersions = IAVLVersions + { latest :: IORef Version + , committed :: IORef Version + } + +initIAVLVersions :: IO IAVLVersions +initIAVLVersions = IAVLVersions <$> newIORef Latest <*> newIORef Genesis + +evalWrite + :: Member (Embed IO) r + => GrpcClient + -> forall a. Sem (WriteStore ': r) a -> Sem r a +evalWrite gc m = + interpret + (\case + StorePut k v -> do + let setReq = defMessage & Api.key .~ makeKeyBytes k + & Api.value .~ v + void . liftIO . runGrpc $ IAVL.set gc setReq + StoreDelete k -> + let remReq = defMessage & Api.key .~ makeKeyBytes k + in void . liftIO . runGrpc $ IAVL.remove gc remReq + ) m + +evalRead + :: Member (Embed IO) r + => GrpcClient + -> IORef Version + -> forall a. Sem (ReadStore ': r) a -> Sem r a +evalRead gc iavlVersion m = do + interpret + (\case + StoreGet k -> do + version <- liftIO $ readIORef iavlVersion + case version of + Latest -> do + let getReq = defMessage & Api.key .~ makeKeyBytes k + res <- liftIO . runGrpc $ IAVL.get gc getReq + case res ^. Api.value of + "" -> pure Nothing + val -> pure $ Just val + Version v -> do + let getVerReq = defMessage & Api.key .~ makeKeyBytes k + & Api.version .~ fromInteger (toInteger v) + res <- liftIO . runGrpc $ IAVL.getVersioned gc getVerReq + case res ^. Api.value of + "" -> pure Nothing + val -> pure $ Just val + Genesis -> pure Nothing + StoreProve _ -> pure Nothing + ) m + +evalTransaction + :: Members [Embed IO, Error AppError] r + => GrpcClient + -> forall a. Sem (Transaction ': r) a -> Sem r a +evalTransaction gc m = do + interpret + (\case + -- NOTICE :: Currently unnecessary with the DB commit/version implementation. + BeginTransaction -> pure () + Rollback -> void . liftIO . runGrpc $ IAVL.rollback gc + Commit -> do + resp <- liftIO . runGrpc $ IAVL.saveVersion gc + pure $ CommitResponse + { rootHash = fromBytes (resp ^. Api.rootHash) + , newVersion = fromInteger . toInteger $ resp ^. Api.version + } + ) m + +evalCommitBlock + :: Members [Embed IO, Error AppError] r + => GrpcClient + -> IAVLVersions + -> forall a. Sem (CommitBlock ': r) a -> Sem r a +evalCommitBlock gc IAVLVersions{committed} = do + interpret + (\case + CommitBlock -> do + versionResp <- liftIO . runGrpc $ IAVL.version gc + let version = Version . fromInteger . toInteger $ versionResp ^. Api.version + liftIO $ writeIORef committed version + hashResp <- liftIO . runGrpc $ IAVL.hash gc + pure . fromBytes $ hashResp ^. Api.rootHash + ) + +evalStoreEffs + :: Members [Embed IO, Reader IAVLVersions, Error AppError, Reader GrpcClient] r + => forall a. + Sem (StoreEffs :& r) a + -> Sem r a +evalStoreEffs action = do + vs@IAVLVersions{..} <- ask + grpc <- ask + evalCommitBlock grpc vs . + evalTransaction grpc . + evalWrite grpc . + untag . + evalRead grpc committed . + untag . + evalRead grpc latest . + untag $ action + +runGrpc + :: ClientIO (Either TooMuchConcurrency (RawReply a)) + -> IO a +runGrpc f = runClientIO f >>= \case + Right (Right (Right (_, _, Right res))) -> pure $ res + Right (Right (Right (_, _, Left err))) -> error . show $ GrpcError (pack $ show err) + Right (Right (Left err)) -> error . show $ GrpcError (pack $ show err) + Right (Left err) -> error . show $ GrpcError (pack $ show err) + Left err -> error . show $ GrpcError (pack $ show err) diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/List.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/List.hs new file mode 100644 index 00000000..7b3e9770 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/List.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Tendermint.SDK.BaseApp.Store.List + ( List + , makeList + , makeFullStoreKey + , append + , delete + , deleteWhen + , foldl + , toList + , length + , elemIndex + , (!!) + ) where + +import Control.Lens (from, iso, to, view, + (^.)) +import Control.Monad (when) +import qualified Data.ByteArray.HexString as Hex +import Data.String.Conversions (cs) +import Data.Word (Word64) +import Polysemy (Members, Sem) +import Polysemy.Error (Error) +import Prelude hiding (foldl, length, + (!!)) +import Tendermint.SDK.BaseApp.Errors (AppError, + SDKError (InternalError), + throwSDKError) +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import qualified Tendermint.SDK.BaseApp.Store.RawStore as S +import Tendermint.SDK.Codec (HasCodec (..)) + +data List (a :: *) = List + { listStore :: S.Store (List a) + } + +newtype Idx = Idx {unIdx :: Word64} deriving (Eq, Show, Ord, Num) + +instance S.RawKey Idx where + rawKey = iso (\(Idx ma) -> ma ^. S.rawKey) + (\bs -> bs ^. from S.rawKey . to Idx) + +instance HasCodec Idx where + encode = view S.rawKey + decode = Right . view (from S.rawKey) + +data IdxKey = IdxKey + +instance S.RawKey IdxKey where + rawKey = + let k = Hex.toBytes "0x00" + in iso (const k) + (\bs -> if bs == k + then IdxKey + else error "Error parsing IdxKey" + ) + +instance S.IsKey IdxKey (List a) where + type Value IdxKey (List a) = M.Map Idx Idx + +data ValueKey = ValueKey + +instance S.RawKey ValueKey where + rawKey = + let k = Hex.toBytes "0x01" + in iso (const k) + (\bs -> if bs == k + then ValueKey + else error "Error parsing ValueKey" + ) + +instance S.IsKey ValueKey (List a) where + type Value ValueKey (List a) = M.Map Idx a + + +instance S.IsKey Idx (List a) where + type Value Idx (List a) = a + +makeList + :: S.IsKey key ns + => S.Value key ns ~ List a + => key + -> S.Store ns + -> S.Value key ns +makeList key store = + List $ S.nestStore store $ + S.makeStore . S.KeyRoot $ key ^. S.rawKey + +makeFullStoreKey + :: List a + -> Word64 + -> S.StoreKey +makeFullStoreKey List{..} i = + S.makeStoreKey listStore (Idx i) + +getIdxMap + :: List a + -> M.Map Idx Idx +getIdxMap List{..} = + M.makeMap IdxKey listStore + +getValueMap + :: List a + -> M.Map Idx a +getValueMap List{..} = + M.makeMap ValueKey listStore + +data HeadKey = HeadKey + +instance S.RawKey HeadKey where + rawKey = + let k = Hex.toBytes "0x02" + in iso (const k) + (\bs -> if bs == k + then HeadKey + else error "Error parsing HeadKey" + ) + +instance S.IsKey HeadKey (List a) where + type Value HeadKey (List a) = Idx + +append + :: Members [Error AppError, S.ReadStore, S.WriteStore] r + => HasCodec a + => a + -> List a + -> Sem r () +append a l@List{..} = do + mhd <- S.get listStore HeadKey + let valueMap = getValueMap l + case mhd of + Nothing -> do + S.put listStore HeadKey 0 + M.insert 0 a valueMap + Just hd -> do + let hd' = hd + 1 + idxMap = getIdxMap l + M.insert hd' hd idxMap + M.insert hd' a valueMap + S.put listStore HeadKey hd' + +-- | Delete the first occurence in the list. +delete + :: Members [Error AppError, S.ReadStore, S.WriteStore] r + => HasCodec a + => Eq a + => a + -> List a + -> Sem r () +delete a l@List{..} = do + mhd <- S.get listStore HeadKey + case mhd of + -- the list looks like [] + Nothing -> pure () + -- the list looks like (? : as) + Just hd -> do + let valueMap = getValueMap l + idxMap = getIdxMap l + a' <- assertLookup hd valueMap + mNext <- M.lookup hd idxMap + if a'== a + -- the list looks like (a : as) + then deleteHead l + -- the list looks like (b : as) + else delete' hd mNext + where + delete' prevIdx mcurrIdx = + case mcurrIdx of + Nothing -> pure () + Just currIdx -> do + let valueMap = getValueMap l + idxMap = getIdxMap l + a' <- assertLookup currIdx valueMap + mNext <- M.lookup currIdx idxMap + if a == a' + then snipNode prevIdx currIdx l + else delete' currIdx mNext + +-- | Delete an element whenever the predicate evaluates to 'True' +deleteWhen + :: Members [Error AppError, S.ReadStore, S.WriteStore] r + => HasCodec a + => (a -> Bool) + -> List a + -> Sem r () +deleteWhen p l@List{..} = do + mhd <- S.get listStore HeadKey + case mhd of + Nothing -> pure () + Just hd -> do + let valueMap = getValueMap l + a <- assertLookup hd valueMap + if p a + then do + deleteHead l + deleteWhen p l + else do + let idxMap = getIdxMap l + mNext <- M.lookup hd idxMap + deleteWhen' hd mNext + where + deleteWhen' prevIdx mcurrIdx = + case mcurrIdx of + Nothing -> pure () + Just currIdx -> do + let valueMap = getValueMap l + idxMap = getIdxMap l + a <- assertLookup currIdx valueMap + mNext <- M.lookup currIdx idxMap + when (p a) $ + snipNode prevIdx currIdx l + deleteWhen' currIdx mNext + +foldl + :: Members [Error AppError, S.ReadStore] r + => HasCodec a + => (b -> a -> b) + -> b + -> List a + -> Sem r b +foldl f b l@List{..} = do + mhd <- S.get listStore HeadKey + foldl' mhd b + where + foldl' mcurrentHead acc = + case mcurrentHead of + Nothing -> pure acc + Just hd -> do + let valMap = getValueMap l + idxMap = getIdxMap l + a <- assertLookup hd valMap + mNext <- M.lookup hd idxMap + foldl' mNext $! f acc a + +-- | View the 'List' as a 'List'. +toList + :: Members [Error AppError, S.ReadStore] r + => HasCodec a + => List a + -> Sem r [a] +toList = fmap reverse . foldl (flip (:)) [] + +length + :: Members [Error AppError, S.ReadStore] r + => HasCodec a + => List a + -> Sem r Word64 +length = foldl (\n _ -> n + 1) 0 + +elemIndex + :: Members [Error AppError, S.ReadStore] r + => HasCodec a + => Eq a + => a + -> List a + -> Sem r (Maybe Word64) +elemIndex a l@List{..} = do + mhd <- S.get listStore HeadKey + elemIndex' 0 mhd + where + elemIndex' i mcurrentHead = + case mcurrentHead of + Nothing -> pure Nothing + Just hd -> do + let valMap = getValueMap l + a' <- assertLookup hd valMap + if a == a' + then pure $ Just $ unIdx i + else do + let idxMap = getIdxMap l + mNext <- M.lookup hd idxMap + elemIndex' (i + 1) mNext + +(!!) + :: Members [Error AppError, S.ReadStore] r + => HasCodec a + => List a + -> Word64 + -> Sem r (Maybe a) +l@List{..} !! idx = do + mhd <- S.get listStore HeadKey + getAtIndex 0 mhd + where + getAtIndex currPos mhd = + case mhd of + Nothing -> pure Nothing + Just hd -> + if idx == currPos + then + let valMap = getValueMap l + in Just <$> assertLookup hd valMap + else do + let idxMap = getIdxMap l + mNext <- M.lookup hd idxMap + getAtIndex (currPos + 1) mNext + +infixl 9 !! + +-------------------------------------------------------------------------------- + +snipNode + :: Members [Error AppError, S.ReadStore, S.WriteStore] r + => Idx + -- ^ previous index + -> Idx + -- ^ current index (node to delete) + -> List a + -> Sem r () +snipNode prevIdx currIdx l = do + let idxMap = getIdxMap l + mNext <- M.lookup currIdx idxMap + case mNext of + -- (n) - (a) - [] ~> [] + Nothing -> M.delete prevIdx idxMap + -- (n) - (a) - rest ~> (n) ~> rest + Just next -> do + M.insert prevIdx next idxMap + deleteDetachedNode currIdx l + +deleteHead + :: Members [Error AppError, S.ReadStore, S.WriteStore] r + => List a + -> Sem r () +deleteHead l@List{..} = do + mhd <- S.get listStore HeadKey + case mhd of + Nothing -> pure () + Just hd -> do + let idxMap = getIdxMap l + mNext <- M.lookup hd idxMap + case mNext of + Nothing -> do + S.delete listStore HeadKey + Just next -> do + S.put listStore HeadKey next + deleteDetachedNode hd l + +deleteDetachedNode + :: Members [Error AppError, S.ReadStore, S.WriteStore] r + => Idx + -> List a + -> Sem r () +deleteDetachedNode idx l = + let valueMap = getValueMap l + idxMap = getIdxMap l + in do + M.delete idx valueMap + M.delete idx idxMap + +assertLookup + :: Members [S.ReadStore, Error AppError] r + => S.RawKey k + => HasCodec v + => k + -> M.Map k v + -> Sem r v +assertLookup k m = do + mRes <- M.lookup k m + case mRes of + Nothing -> throwSDKError $ + InternalError $ "Database integrity failed, lookup miss: " <> cs (k ^. S.rawKey) + Just res -> pure res diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/Map.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/Map.hs new file mode 100644 index 00000000..05cb26ae --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/Map.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Tendermint.SDK.BaseApp.Store.Map + ( Map + , makeMap + , makeFullStoreKey + , insert + , lookup + , delete + , update + ) where + +import Control.Lens ((^.)) +import Polysemy (Member, Members, Sem) +import Polysemy.Error (Error) +import Prelude hiding (lookup) +import Tendermint.SDK.BaseApp.Errors (AppError) +import qualified Tendermint.SDK.BaseApp.Store.RawStore as S +import Tendermint.SDK.Codec (HasCodec (..)) + +data Map (k :: *) (v :: *) = Map + { mapStore :: S.Store (Map k v) + } + +instance S.RawKey k => S.IsKey k (Map k v) where + type Value k (Map k v) = v + +makeMap + :: S.IsKey key ns + => S.Value key ns ~ Map k v + => key + -> S.Store ns + -> S.Value key ns +makeMap key store = + let skr :: S.KeyRoot (Map k v) + skr = S.KeyRoot $ key ^. S.rawKey + in Map $ S.nestStore store (S.makeStore skr) + +makeFullStoreKey + :: S.RawKey k + => Map k v + -> k + -> S.StoreKey +makeFullStoreKey Map{..} = + S.makeStoreKey mapStore + +insert + :: Member S.WriteStore r + => S.RawKey k + => HasCodec v + => k + -> v + -> Map k v + -> Sem r () +insert k v Map{..} = + S.put mapStore k v + +lookup + :: Members [Error AppError, S.ReadStore] r + => S.RawKey k + => HasCodec v + => k + -> Map k v + -> Sem r (Maybe v) +lookup k Map{..} = + S.get mapStore k + +delete + :: Member S.WriteStore r + => S.RawKey k + => k + -> Map k v + -> Sem r () +delete k Map{..} = + S.delete mapStore k + +update + :: Members [Error AppError, S.ReadStore, S.WriteStore] r + => S.RawKey k + => HasCodec v + => (v -> Maybe v) + -> k + -> Map k v + -> Sem r () +update f k store = do + mv <- lookup k store + case mv of + Nothing -> pure () + Just v -> maybe (delete k store) (\a -> insert k a store) (f v) diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/MemoryStore.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/MemoryStore.hs new file mode 100644 index 00000000..c41bb446 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/MemoryStore.hs @@ -0,0 +1,199 @@ +module Tendermint.SDK.BaseApp.Store.MemoryStore + ( + -- * Environment + DBVersions(..) + , initDBVersions + , DB + , initDB + -- * Eval + , evalStoreEffs + , evalRead + , evalWrite + ) where + + +import Control.Monad.IO.Class (liftIO) +import qualified Crypto.Data.Auth.Tree as AT +import qualified Crypto.Data.Auth.Tree.Class as AT +import qualified Crypto.Data.Auth.Tree.Cryptonite as Cryptonite +import qualified Crypto.Hash as Cryptonite +import Data.ByteArray (convert) +import qualified Data.ByteArray.Base64String as Base64 +import Data.ByteString (ByteString) +import Data.IORef +import Data.List (sortOn) +import Data.Ord (Down (..)) +import Numeric.Natural (Natural) +import Polysemy +import Polysemy.Reader (Reader, ask) +import Polysemy.Tagged (untag) +import Tendermint.SDK.BaseApp.Store.RawStore (CommitBlock (..), + CommitResponse (..), + ReadStore (..), + StoreEffs, + Transaction (..), + Version (..), + WriteStore (..), + makeKeyBytes) +import Tendermint.SDK.Types.Effects ((:&)) + + + +newtype AuthTreeHash = AuthTreeHash (Cryptonite.Digest Cryptonite.SHA256) + +instance AT.MerkleHash AuthTreeHash where + emptyHash = AuthTreeHash Cryptonite.emptyHash + hashLeaf k v = AuthTreeHash $ Cryptonite.hashLeaf k v + concatHashes (AuthTreeHash a) (AuthTreeHash b) = AuthTreeHash $ Cryptonite.concatHashes a b + +data DB = DB + { dbCommitted :: IORef (AT.Tree Natural (AT.Tree ByteString ByteString)) + , dbLatest :: IORef (AT.Tree ByteString ByteString) + } + +initDB :: IO DB +initDB = + DB <$> newIORef AT.empty + <*> newIORef AT.empty + +evalWrite + :: Member (Embed IO) r + => DB + -> forall a. Sem (WriteStore ': r) a -> Sem r a +evalWrite DB{dbLatest} m = + interpret + (\case + StorePut k v -> + liftIO . modifyIORef dbLatest $ AT.insert (makeKeyBytes k) v + StoreDelete k -> + liftIO . modifyIORef dbLatest $ AT.delete (makeKeyBytes k) + ) m + +evalRead + :: Member (Embed IO) r + => DB + -> IORef Version + -> forall a. Sem (ReadStore ': r) a -> Sem r a +evalRead DB{dbCommitted,dbLatest} iavlVersion m = do + interpret + (\case + StoreGet k -> do + version <- liftIO $ readIORef iavlVersion + case version of + Latest -> do + tree <- liftIO $ readIORef dbLatest + pure $ AT.lookup (makeKeyBytes k) tree + Version v -> do + tree <- liftIO $ readIORef dbCommitted + pure (AT.lookup v tree >>= AT.lookup (makeKeyBytes k)) + Genesis -> pure Nothing + StoreProve _ -> pure Nothing + ) m + +evalTransaction + :: Member (Embed IO) r + => DB + -> forall a. Sem (Transaction ': r) a -> Sem r a +evalTransaction db@DB{..} m = do + interpret + (\case + -- NOTICE :: Currently unnecessary with the DB commit/version implementation. + BeginTransaction -> pure () + Rollback -> liftIO $ do + c <- getRecentCommit db + writeIORef dbLatest c + Commit -> liftIO $ do + l <- readIORef dbLatest + v <- makeCommit db l + root <- getRootHash db + pure $ CommitResponse + { rootHash = Base64.fromBytes root + , newVersion = fromInteger . toInteger $ v + } + ) m + +evalCommitBlock + :: Member (Embed IO) r + => DB + -> DBVersions + -> forall a. Sem (CommitBlock ': r) a -> Sem r a +evalCommitBlock db DBVersions{..} = do + interpret + (\case + CommitBlock -> liftIO $ do + mv <- getVersion db + writeIORef committed $ case mv of + Nothing -> Genesis + Just v -> Version v + root <- getRootHash db + pure . Base64.fromBytes $ root + ) + +data DBVersions = DBVersions + { latest :: IORef Version + , committed :: IORef Version + } + +initDBVersions :: IO DBVersions +initDBVersions = DBVersions <$> newIORef Latest <*> newIORef Genesis + +evalStoreEffs + :: Members [Embed IO, Reader DBVersions, Reader DB] r + => forall a. + Sem (StoreEffs :& r) a + -> Sem r a +evalStoreEffs action = do + vs@DBVersions{..} <- ask + db <- ask + evalCommitBlock db vs . + evalTransaction db . + evalWrite db . + untag . + evalRead db committed . + untag . + evalRead db latest . + untag $ action + +getRootHash + :: DB + -> IO ByteString +getRootHash db@DB{dbCommitted} = do + mcv <- getVersion db + case mcv of + Nothing -> pure "" + Just v -> do + c <- readIORef dbCommitted + case AT.lookup v c of + Nothing -> pure "" + Just tree -> + let AuthTreeHash hash = AT.merkleHash tree + in pure $ convert hash + +getVersion + :: DB + -> IO (Maybe Natural) +getVersion DB{..}= do + c <- readIORef dbCommitted + pure $ + if c == AT.empty + then Nothing + else Just $ maximum $ map fst $ AT.toList c + +getRecentCommit + :: DB + -> IO (AT.Tree ByteString ByteString) +getRecentCommit DB{..} = do + c <- readIORef dbCommitted + case sortOn (Down . fst) $ AT.toList c of + [] -> pure AT.empty + a : _ -> pure $ snd a + +makeCommit + :: DB + -> AT.Tree ByteString ByteString + -> IO Natural +makeCommit db@DB{dbCommitted} commit = do + mv <- getVersion db + let v = maybe 0 (+1) mv + modifyIORef dbCommitted $ AT.insert v commit + pure v diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/RawStore.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/RawStore.hs new file mode 100644 index 00000000..83b302d6 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/RawStore.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tendermint.SDK.BaseApp.Store.RawStore + ( + -- * Effects + StoreEffs + , Scope(..) + , ReadStore(..) + , storeGet + , get + , prove + , WriteStore(..) + , put + , storePut + , delete + , storeDelete + , CommitBlock(..) + , commitBlock + , Transaction(..) + , beginTransaction + , withSandbox + , withTransaction + , commit + + -- * Types + , RawKey(..) + , IsKey(..) + , StoreKey(..) + , KeyRoot(..) + , makeKeyBytes + , CommitResponse(..) + , Store + , nestStore + , makeStore + , makeStoreKey + + , Version(..) + ) where + +import Control.Lens (Iso', iso, (^.)) +import Data.ByteArray.Base64String (Base64String) +import qualified Data.ByteString as BS +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Text +import Data.Word (Word64) +import Numeric.Natural (Natural) +import Polysemy (Member, Members, Sem, makeSem) +import Polysemy.Error (Error, catch, throw) +import Polysemy.Resource (Resource, finally, onException) +import Polysemy.Tagged (Tagged) +import Tendermint.SDK.BaseApp.Errors (AppError, SDKError (ParseError), + throwSDKError) +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Address (Address, addressFromBytes, + addressToBytes) + +-------------------------------------------------------------------------------- +-- | Keys +-------------------------------------------------------------------------------- + +class RawKey k where + rawKey :: Iso' k BS.ByteString + +instance RawKey Text where + rawKey = iso cs cs + +instance RawKey Address where + rawKey = iso addressToBytes addressFromBytes + +instance RawKey Word64 where + rawKey = iso encode (either (error "Error decoding Word64 RawKey") id . decode) + +instance RawKey () where + rawKey = iso (const "") (const ()) + +class RawKey k => IsKey k ns where + type Value k ns :: * + prefix :: Proxy k -> Proxy ns -> BS.ByteString + + default prefix :: Proxy k -> Proxy ns -> BS.ByteString + prefix _ _ = "" + +data StoreKey = StoreKey + { skPathFromRoot :: [BS.ByteString] + , skKey :: BS.ByteString + } deriving (Eq, Show, Ord) + +makeKeyBytes :: StoreKey -> BS.ByteString +makeKeyBytes StoreKey{..} = mconcat skPathFromRoot <> skKey + +-------------------------------------------------------------------------------- +-- | Store +-------------------------------------------------------------------------------- + +newtype KeyRoot ns = + KeyRoot BS.ByteString deriving (Eq, Show) + +data Store ns = Store + { storePathFromRoot :: [BS.ByteString] + } + +makeStore :: KeyRoot ns -> Store ns +makeStore (KeyRoot ns) = Store + { storePathFromRoot = [ns] + } + +nestStore :: Store parentns -> Store childns -> Store childns +nestStore (Store parentPath) (Store childPath) = + Store + { storePathFromRoot = parentPath ++ childPath + } + +makeStoreKey + :: forall k ns. + IsKey k ns + => Store ns + -> k + -> StoreKey +makeStoreKey (Store path) k = + StoreKey + { skKey = prefix (Proxy @k) (Proxy @ns) <> k ^. rawKey + , skPathFromRoot = path + } + + +-------------------------------------------------------------------------------- +-- | Read and Write Effects +-------------------------------------------------------------------------------- + + +data ReadStore m a where + StoreGet :: StoreKey -> ReadStore m (Maybe BS.ByteString) + StoreProve :: StoreKey -> ReadStore m (Maybe BS.ByteString) + +makeSem ''ReadStore + +data WriteStore m a where + StorePut :: StoreKey -> BS.ByteString -> WriteStore m () + StoreDelete :: StoreKey -> WriteStore m () + +makeSem ''WriteStore + +put + :: forall k r ns. + IsKey k ns + => HasCodec (Value k ns) + => Member WriteStore r + => Store ns + -> k + -> Value k ns + -> Sem r () +put store k a = + let key = makeStoreKey store k + val = encode a + in storePut key val + +get + :: forall k r ns. + IsKey k ns + => HasCodec (Value k ns) + => Members [ReadStore, Error AppError] r + => Store ns + -> k + -> Sem r (Maybe (Value k ns)) +get store k = do + let key = makeStoreKey store k + mRes <- storeGet key + case mRes of + Nothing -> pure Nothing + Just raw -> case decode raw of + Left e -> throwSDKError (ParseError $ "Impossible codec error: " <> cs e) + Right a -> pure $ Just a + +delete + :: forall k ns r. + IsKey k ns + => Member WriteStore r + => Store ns + -> k + -> Sem r () +delete store k = + let key = makeStoreKey store k + in storeDelete key + +prove + :: forall k ns r. + IsKey k ns + => Member ReadStore r + => Store ns + -> k + -> Sem r (Maybe BS.ByteString) +prove store k = + let key = makeStoreKey store k + in storeProve key + +-------------------------------------------------------------------------------- +-- | Consensus Effects +-------------------------------------------------------------------------------- + +data CommitBlock m a where + CommitBlock :: CommitBlock m Base64String + +makeSem ''CommitBlock + +data CommitResponse = CommitResponse + { rootHash :: Base64String + , newVersion :: Natural + } deriving (Eq, Show) + +data Transaction m a where + -- transact + BeginTransaction :: Transaction m () + Rollback :: Transaction m () + Commit :: Transaction m CommitResponse + +makeSem ''Transaction + +withTransaction + :: forall r a. + Members [Transaction, Resource, Error AppError] r + => Sem r a + -> Sem r (a, CommitResponse) +withTransaction m = + let tryTx = m `catch` (\e -> rollback *> throw e) + actionWithCommit = do + res <- tryTx + c <- commit + pure (res, c) + in do + onException actionWithCommit rollback + +withSandbox + :: forall r a. + Members [Transaction, Resource, Error AppError] r + => Sem r a + -> Sem r a +withSandbox m = + let tryTx = m `catch` (\e -> rollback *> throw e) + in finally (tryTx <* rollback) rollback + +data Version = + Genesis + | Version Natural + | Latest + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- | Store Effects +-------------------------------------------------------------------------------- + +data Scope = Consensus | QueryAndMempool + +type StoreEffs = + [ Tagged 'Consensus ReadStore + , Tagged 'QueryAndMempool ReadStore + , Tagged 'Consensus WriteStore + , Transaction + , CommitBlock + ] diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/Var.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/Var.hs new file mode 100644 index 00000000..30978d8e --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Store/Var.hs @@ -0,0 +1,72 @@ +module Tendermint.SDK.BaseApp.Store.Var + ( Var + , makeVar + , makeFullStoreKey + , takeVar + , unsafeTakeVar + , putVar + , deleteVar + ) where + +import Control.Lens ((^.)) +import Polysemy (Member, Members, Sem) +import Polysemy.Error (Error) +import Tendermint.SDK.BaseApp.Errors (AppError, + SDKError (StoreError), + throwSDKError) +import qualified Tendermint.SDK.BaseApp.Store.RawStore as S +import Tendermint.SDK.Codec (HasCodec (..)) + +data Var (a :: *) = Var + { varStore :: S.Store (Var a) } + +instance S.IsKey () (Var a) where + type Value () (Var a) = a + +makeVar + :: S.IsKey k ns + => S.Value k ns ~ Var a + => k + -> S.Store ns + -> S.Value k ns +makeVar key store = + Var $ S.nestStore store $ + S.makeStore . S.KeyRoot $ key ^. S.rawKey + +makeFullStoreKey + :: Var a + -> S.StoreKey +makeFullStoreKey Var{..} = + S.makeStoreKey varStore () + +takeVar + :: Members [S.ReadStore, Error AppError] r + => HasCodec a + => Var a + -> Sem r (Maybe a) +takeVar Var{..} = S.get varStore () + +unsafeTakeVar + :: Members [S.ReadStore, Error AppError] r + => HasCodec a + => Var a + -> Sem r a +unsafeTakeVar Var{..} = do + mRes <- S.get varStore () + case mRes of + Just a -> pure a + Nothing -> throwSDKError $ StoreError "Var key not found." + +putVar + :: Member S.WriteStore r + => HasCodec a + => a + -> Var a + -> Sem r () +putVar a Var{..} = S.put varStore () a + +deleteVar + :: Member S.WriteStore r + => Var a + -> Sem r () +deleteVar Var{..} = S.delete varStore () diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction.hs new file mode 100644 index 00000000..5637dec9 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction.hs @@ -0,0 +1,50 @@ +module Tendermint.SDK.BaseApp.Transaction + ( serveTxApplication + -- * Re-Exports + , module Tendermint.SDK.BaseApp.Transaction.Types + , HasTxRouter(..) + , emptyTxServer + , DefaultCheckTx(..) + , VoidReturn + , TxEffs + , evalReadOnly + , AnteHandler + ) where + +import Control.Lens ((&), (.~)) +import Data.ByteString (ByteString) +import Data.Default.Class (def) +import Data.Proxy +import Polysemy (Sem) +import Tendermint.SDK.BaseApp.Errors (makeAppError, txResultAppError) +import Tendermint.SDK.BaseApp.Router (Application, RouteResult (..), + emptyDelayed, + runRouter) +import Tendermint.SDK.BaseApp.Transaction.AnteHandler +import Tendermint.SDK.BaseApp.Transaction.Cache (Cache) +import Tendermint.SDK.BaseApp.Transaction.Checker +import Tendermint.SDK.BaseApp.Transaction.Effect +import Tendermint.SDK.BaseApp.Transaction.Router +import Tendermint.SDK.BaseApp.Transaction.Types +import Tendermint.SDK.Types.Effects ((:&)) +import Tendermint.SDK.Types.TxResult (TxResult) + +serveTxApplication + :: HasTxRouter layout r scope + => Proxy layout + -> Proxy r + -> Proxy scope + -> RouteTx layout (TxEffs :& r) + -> TransactionApplication (Sem r) +serveTxApplication pl pr ps server = + toTxApplication (runRouter (routeTx pl pr ps (emptyDelayed (Route server))) ()) + +toTxApplication + :: Application (Sem r) (RoutingTx ByteString) (TxResult, Maybe Cache) + -> TransactionApplication (Sem r) +toTxApplication ra tx = do + res <- ra tx + case res of + Fail e -> pure (def & txResultAppError .~ makeAppError e, Nothing) + FailFatal e -> pure (def & txResultAppError .~ makeAppError e, Nothing) + Route a -> pure a diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/AnteHandler.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/AnteHandler.hs new file mode 100644 index 00000000..b8ff6b08 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/AnteHandler.hs @@ -0,0 +1,9 @@ +module Tendermint.SDK.BaseApp.Transaction.AnteHandler + ( AnteHandler + ) where + +import Data.Monoid (Endo) +import Polysemy (Sem) +import Tendermint.SDK.BaseApp.Transaction.Types (RoutingTx) + +type AnteHandler r = forall msg a. (Endo (RoutingTx msg -> Sem r a)) diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Cache.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Cache.hs new file mode 100644 index 00000000..3616d9dc --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Cache.hs @@ -0,0 +1,66 @@ +module Tendermint.SDK.BaseApp.Transaction.Cache + ( Cache + , emptyCache + , writeCache + , Deleted(..) + , put + , get + , delete + ) where + +import Data.ByteString (ByteString) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Polysemy (Member, Sem) +import Polysemy.Tagged (Tagged, tag) +import Tendermint.SDK.BaseApp.Store.RawStore (Scope (..), StoreKey, + WriteStore, storeDelete, + storePut) + +data Cache = Cache + { keysToDelete :: Set StoreKey + , stateCache :: Map StoreKey ByteString + } deriving (Eq, Show) + +emptyCache :: Cache +emptyCache = Cache Set.empty Map.empty + +put + :: StoreKey + -> ByteString + -> Cache + -> Cache +put k v Cache{..} = + let keysToDelete' = Set.delete k keysToDelete + stateCache' = Map.insert k v stateCache + in Cache keysToDelete' stateCache' + +data Deleted = Deleted + +get + :: StoreKey + -> Cache + -> Either Deleted (Maybe ByteString) +get k Cache{..} = + if k `Set.member` keysToDelete + then Left Deleted + else Right $ Map.lookup k stateCache + +delete + :: StoreKey + -> Cache + -> Cache +delete k Cache{..} = + let keysToDelete' = Set.insert k keysToDelete + stateCache' = Map.delete k stateCache + in Cache keysToDelete' stateCache' + +writeCache + :: Member (Tagged 'Consensus WriteStore) r + => Cache + -> Sem r () +writeCache Cache{..} = do + mapM_ (tag @'Consensus . uncurry storePut) (Map.toList stateCache) + mapM_ (tag @'Consensus . storeDelete) (Set.toList keysToDelete) diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Checker.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Checker.hs new file mode 100644 index 00000000..bc801d12 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Checker.hs @@ -0,0 +1,57 @@ +module Tendermint.SDK.BaseApp.Transaction.Checker + ( DefaultCheckTx(..) + , VoidReturn + ) where + +import Data.Proxy +import qualified Data.Validation as V +import Polysemy (EffectRow, Member, + Sem) +import Polysemy.Error (Error) +import Servant.API ((:<|>) (..), (:>)) +import Tendermint.SDK.BaseApp.Errors (AppError, + SDKError (..), + throwSDKError) +import Tendermint.SDK.BaseApp.Transaction.Types +import Tendermint.SDK.Types.Message (ValidateMessage (..), formatMessageSemanticError) + +defaultCheckTxHandler + :: Member (Error AppError) r + => ValidateMessage msg + => RoutingTx msg + -> Sem r () +defaultCheckTxHandler(RoutingTx Tx{txMsg}) = + case validateMessage txMsg of + V.Failure err -> + throwSDKError . MessageValidation . map formatMessageSemanticError $ err + V.Success _ -> pure () + +type family VoidReturn (api :: *) :: * where + VoidReturn (a :<|> b) = VoidReturn a :<|> VoidReturn b + VoidReturn (path :> a) = path :> VoidReturn a + VoidReturn (TypedMessage msg :~> Return a) = TypedMessage msg :~> Return () + +class DefaultCheckTx api (r :: EffectRow) where + type DefaultCheckTxT api r :: * + defaultCheckTx :: Proxy api -> Proxy r -> DefaultCheckTxT api r + +instance (DefaultCheckTx a r, DefaultCheckTx b r) => DefaultCheckTx (a :<|> b) r where + type DefaultCheckTxT (a :<|> b) r = DefaultCheckTxT a r :<|> DefaultCheckTxT b r + + defaultCheckTx _ pr = + defaultCheckTx (Proxy :: Proxy a) pr :<|> defaultCheckTx (Proxy :: Proxy b) pr + +instance DefaultCheckTx rest r => DefaultCheckTx (path :> rest) r where + type DefaultCheckTxT (path :> rest) r = DefaultCheckTxT rest r + + defaultCheckTx _ = defaultCheckTx (Proxy :: Proxy rest) + +instance (Member (Error AppError) r, ValidateMessage msg) => DefaultCheckTx (TypedMessage msg :~> Return a) r where + type DefaultCheckTxT (TypedMessage msg :~> Return a) r = RoutingTx msg -> Sem r () + + defaultCheckTx _ _ = defaultCheckTxHandler + +instance DefaultCheckTx EmptyTxServer r where + type DefaultCheckTxT EmptyTxServer r = EmptyTxServer + + defaultCheckTx _ _ = EmptyTxServer diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Effect.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Effect.hs new file mode 100644 index 00000000..70017a02 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Effect.hs @@ -0,0 +1,139 @@ +module Tendermint.SDK.BaseApp.Transaction.Effect + ( TxEffs + , runTx + , eval + , evalReadOnly + ) where + +import Control.Lens ((&), (.~)) +import Control.Monad.IO.Class (liftIO) +import Data.ByteArray.Base64String (fromBytes) +import Data.Default.Class (def) +import Data.IORef (IORef, readIORef, + writeIORef) +import Data.Proxy +import Polysemy (Embed, Member, + Members, Sem, + interpret, + raiseUnder, rewrite) +import Polysemy.Error (Error, runError) +import Polysemy.Internal (send) +import Polysemy.Output (Output, ignoreOutput, + runOutputMonoidIORef) +import qualified Polysemy.State as State +import Polysemy.Tagged (Tagged (..)) +import Tendermint.SDK.BaseApp.Errors (AppError, + txResultAppError) +import qualified Tendermint.SDK.BaseApp.Events as E +import qualified Tendermint.SDK.BaseApp.Gas as G +import Tendermint.SDK.BaseApp.Store.RawStore (ReadStore (..), + WriteStore (..)) +import qualified Tendermint.SDK.BaseApp.Transaction.Cache as Cache +import Tendermint.SDK.BaseApp.Transaction.Types +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Effects ((:&)) +import Tendermint.SDK.Types.TxResult (TxResult, + txResultData, + txResultEvents, + txResultGasUsed, + txResultGasWanted) + +type TxEffs = + [ Output E.Event + , G.GasMeter + , WriteStore + , ReadStore + , Error AppError + ] + +eval + :: forall r scope a. + Members [Embed IO, Tagged scope ReadStore] r + => Proxy scope + -> TransactionContext + -> Sem (TxEffs :& r) a + -> Sem r (Either AppError a) +eval ps TransactionContext{..} = do + runError . + evalCachedReadStore ps storeCache . + rewrite (Tagged @Cache.Cache) . + evalCachedWriteStore storeCache . + rewrite (Tagged @Cache.Cache) . + State.runStateIORef gasRemaining . + G.eval . + raiseUnder @(State.State G.GasAmount) . + runOutputMonoidIORef events (pure @[]) + +evalReadOnly + :: forall r. + forall a. + Sem (TxEffs :& r) a + -> Sem (ReadStore ': Error AppError ': r) a +evalReadOnly = + writeNothing . + G.doNothing . + ignoreOutput + where + writeNothing = interpret (\case + StorePut _ _ -> pure () + StoreDelete _ -> pure () + ) + +runTx + :: Members [Embed IO, Tagged scope ReadStore] r + => HasCodec a + => Proxy scope + -> TransactionContext + -> Sem (TxEffs :& r) a + -> Sem r (TxResult, Maybe Cache.Cache) +runTx ps ctx@TransactionContext{..} tx = do + initialGas <- liftIO $ readIORef gasRemaining + eRes <- eval ps ctx tx + finalGas <- liftIO $ readIORef gasRemaining + let gasUsed = initialGas - finalGas + baseResponse = + def & txResultGasWanted .~ G.unGasAmount initialGas + & txResultGasUsed .~ G.unGasAmount gasUsed + case eRes of + Left e -> return (baseResponse & txResultAppError .~ e, Nothing) + Right a -> do + es <- liftIO $ readIORef events + c <- liftIO $ readIORef storeCache + return ( baseResponse & txResultEvents .~ es + & txResultData .~ fromBytes (encode a) + , Just c + ) + +evalCachedReadStore + :: Members [Embed IO, Tagged scope ReadStore] r + => Proxy scope + -> IORef Cache.Cache + -> Sem (Tagged Cache.Cache ReadStore ': r) a + -> Sem r a +evalCachedReadStore (_ :: Proxy scope) c m = do + interpret + (\(Tagged action) -> case action of + StoreGet k -> do + cache <- liftIO $ readIORef c + case Cache.get k cache of + Left Cache.Deleted -> pure Nothing + Right (Just v) -> pure (Just v) + Right Nothing -> send (Tagged @scope (StoreGet k)) + StoreProve _ -> pure Nothing + ) m + +evalCachedWriteStore + :: Member (Embed IO) r + => IORef Cache.Cache + -> Sem (Tagged Cache.Cache WriteStore ': r) a + -> Sem r a +evalCachedWriteStore c m = do + interpret + (liftIO . \(Tagged action) -> case action of + StorePut k v -> do + cache <- liftIO $ readIORef c + writeIORef c $ Cache.put k v cache + StoreDelete k -> do + cache <- liftIO $ readIORef c + writeIORef c $ Cache.delete k cache + ) m diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Router.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Router.hs new file mode 100644 index 00000000..fafa25e8 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Router.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE UndecidableInstances #-} +module Tendermint.SDK.BaseApp.Transaction.Router + ( HasTxRouter(..) + , emptyTxServer + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import Data.Monoid +import Data.Proxy +import Data.String.Conversions (cs) +import GHC.TypeLits (KnownSymbol, + symbolVal) +import Polysemy (EffectRow, + Embed, Members, + Sem) +import Polysemy.Tagged (Tagged) +import Servant.API +import qualified Tendermint.SDK.BaseApp.Router as R +import Tendermint.SDK.BaseApp.Store (ReadStore, + Scope) +import Tendermint.SDK.BaseApp.Transaction.AnteHandler (AnteHandler) +import Tendermint.SDK.BaseApp.Transaction.Cache (Cache) +import Tendermint.SDK.BaseApp.Transaction.Effect (TxEffs, runTx) +import Tendermint.SDK.BaseApp.Transaction.Types +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Effects ((:&)) +import Tendermint.SDK.Types.Message (HasMessageType (..), + Msg (..)) +import Tendermint.SDK.Types.TxResult (TxResult) + +-------------------------------------------------------------------------------- + +class HasTxRouter layout (r :: EffectRow) (scope :: Scope) where + type RouteTx layout (s :: EffectRow) :: * + routeTx + :: Proxy layout + -> Proxy r + -> Proxy scope + -> R.Delayed (Sem r) env (RoutingTx ByteString) (RouteTx layout (TxEffs :& r)) + -> R.Router env r (RoutingTx ByteString) (TxResult, Maybe Cache) + + applyAnteHandler + :: Proxy layout + -> Proxy r + -> Proxy scope + -> AnteHandler r + -> RouteTx layout r + -> RouteTx layout r + + hoistTxRouter + :: Proxy layout + -> Proxy r + -> Proxy scope + -> (forall a. Sem s a -> Sem s' a) + -> RouteTx layout s + -> RouteTx layout s' + +instance (HasTxRouter a r scope, HasTxRouter b r scope) => HasTxRouter (a :<|> b) r scope where + type RouteTx (a :<|> b) s = RouteTx a s :<|> RouteTx b s + + routeTx _ pr ps server = + R.choice (routeTx (Proxy @a) pr ps ((\ (a :<|> _) -> a) <$> server)) + (routeTx (Proxy @b) pr ps ((\ (_ :<|> b) -> b) <$> server)) + + applyAnteHandler _ pr ps ah (a :<|> b) = + applyAnteHandler (Proxy @a) pr ps ah a :<|> + applyAnteHandler (Proxy @b) pr ps ah b + + hoistTxRouter _ pr nat ps (a :<|> b) = + hoistTxRouter (Proxy @a) pr nat ps a :<|> hoistTxRouter (Proxy @b) pr nat ps b + +instance (HasTxRouter sublayout r scope, KnownSymbol path) => HasTxRouter (path :> sublayout) r scope where + + type RouteTx (path :> sublayout) s = RouteTx sublayout s + + routeTx _ pr ps subserver = + R.pathRouter (cs (symbolVal proxyPath)) (routeTx (Proxy @sublayout) pr ps subserver) + where proxyPath = Proxy @path + + applyAnteHandler _ pr ps ah = applyAnteHandler (Proxy @sublayout) pr ps ah + + hoistTxRouter _ pr ps nat = hoistTxRouter (Proxy @sublayout) pr ps nat + +methodRouter + :: HasCodec a + => Members [Embed IO, Tagged scope ReadStore] r + => Proxy scope + -> R.Delayed (Sem r) env (RoutingTx msg) (Sem (TxEffs :& r) a) + -> R.Router env r (RoutingTx msg) (TxResult, Maybe Cache) +methodRouter ps action = + let route' env tx = do + ctx <- liftIO $ newTransactionContext tx + let action' = runTx ps ctx <$> action + R.runAction action' env tx (pure . R.Route) + in R.leafRouter route' + +instance ( HasMessageType msg, HasCodec msg + , Members [Tagged scope ReadStore, Embed IO] r + , HasCodec a + ) => HasTxRouter (TypedMessage msg :~> Return a) r scope where + + type RouteTx (TypedMessage msg :~> Return a) r = RoutingTx msg -> Sem r a + + routeTx _ _ ps subserver = + let f (RoutingTx tx@Tx{txMsg}) = + if msgType txMsg == mt + then case decode $ msgData txMsg of + Left e -> R.delayedFail $ + R.InvalidRequest ("Failed to parse message of type " <> mt <> ": " <> e <> ".") + Right a -> pure . RoutingTx $ tx {txMsg = txMsg {msgData = a}} + else R.delayedFail R.PathNotFound + in methodRouter ps $ R.addBody subserver $ R.withRequest f + where mt = messageType (Proxy :: Proxy msg) + + applyAnteHandler _ _ _ ah f = appEndo ah f + + hoistTxRouter _ _ _ nat = (.) nat + +emptyTxServer :: RouteTx EmptyTxServer r +emptyTxServer = EmptyTxServer + +instance HasTxRouter EmptyTxServer r scope where + type RouteTx EmptyTxServer r = EmptyTxServer + routeTx _ _ _ _ = R.StaticRouter mempty mempty + + applyAnteHandler _ _ _ _ = id + + hoistTxRouter _ _ _ _ = id diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Types.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Types.hs new file mode 100644 index 00000000..4f284458 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Types.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Tendermint.SDK.BaseApp.Transaction.Types + ( module Tendermint.SDK.BaseApp.Transaction.Types + -- * Re-Exports + , Tx(..) + ) where + +import Control.Lens (lens) +import Data.ByteString (ByteString) +import Data.IORef (IORef, newIORef) +import qualified Tendermint.SDK.BaseApp.Events as E +import qualified Tendermint.SDK.BaseApp.Gas as G +import Tendermint.SDK.BaseApp.Router (HasPath (..)) +import qualified Tendermint.SDK.BaseApp.Transaction.Cache as Cache +import Tendermint.SDK.Types.Transaction (Tx (..)) +import Tendermint.SDK.Types.TxResult (TxResult) + +-------------------------------------------------------------------------------- +-- Router Types and Combinators +-------------------------------------------------------------------------------- + +data msg :~> a + +data TypedMessage msg + +data Return a + +data EmptyTxServer = EmptyTxServer + +-------------------------------------------------------------------------------- +-- RouteContext and Singletons +-------------------------------------------------------------------------------- + +data RouteContext = CheckTx | DeliverTx deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- Transaction Application types +-------------------------------------------------------------------------------- + +data RoutingTx msg where + RoutingTx :: Tx alg msg -> RoutingTx msg + +instance Functor RoutingTx where + fmap f (RoutingTx tx) = RoutingTx $ fmap f tx + +instance HasPath (RoutingTx msg) where + path = lens (\(RoutingTx tx) -> txRoute tx) + (\(RoutingTx tx) r -> RoutingTx tx {txRoute = r}) + +data TransactionContext = TransactionContext + { gasRemaining :: IORef G.GasAmount + , storeCache :: IORef Cache.Cache + , events :: IORef [E.Event] + } + +newTransactionContext + :: RoutingTx msg + -> IO TransactionContext +newTransactionContext (RoutingTx Tx{txGas}) = do + initialGas <- newIORef $ G.GasAmount txGas + initialCache <- newIORef Cache.emptyCache + es <- newIORef [] + pure TransactionContext + { gasRemaining = initialGas + , storeCache = initialCache + , events = es + } + +type TransactionApplication m = + RoutingTx ByteString -> m (TxResult, Maybe Cache.Cache) + diff --git a/hs-abci-sdk/src/Tendermint/SDK/Codec.hs b/hs-abci-sdk/src/Tendermint/SDK/Codec.hs index 6d1c221d..734d6330 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/Codec.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/Codec.hs @@ -1,13 +1,59 @@ -module Tendermint.SDK.Codec where +module Tendermint.SDK.Codec + ( HasCodec(..) + , defaultSDKAesonOptions + ) where -import qualified Data.ByteString as BS +import Data.Aeson (Options) +import Data.Aeson.Casing (aesonDrop, snakeCase) +import Data.Bifunctor (first) +import qualified Data.ByteString as BS +import Data.Int (Int32, Int64) +import qualified Data.ProtoLens.Encoding.Bytes as PB +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word32, Word64) + + +-- | This class is used as a codec for all items stored in +-- | the database as well as incoming transaction messages. class HasCodec a where encode :: a -> BS.ByteString - decode :: BS.ByteString -> Either String a + decode :: BS.ByteString -> Either Text a + +instance HasCodec () where + encode = const "" + decode = const $ pure () + + +instance HasCodec Word32 where + encode = PB.runBuilder . PB.putFixed32 + decode = first cs . PB.runParser PB.getFixed32 + +instance HasCodec Int32 where + encode = PB.runBuilder . PB.putFixed32 . PB.signedInt32ToWord + decode = first cs . PB.runParser (PB.wordToSignedInt32 <$> PB.getFixed32) + +instance HasCodec Word64 where + encode = PB.runBuilder . PB.putFixed64 + decode = first cs . PB.runParser PB.getFixed64 + +instance HasCodec Int64 where + encode = PB.runBuilder . PB.putFixed64 . PB.signedInt64ToWord + decode = first cs . PB.runParser (PB.wordToSignedInt64 <$> PB.getFixed64) + +instance HasCodec String where + encode = cs + decode = Right . cs + +instance HasCodec Text where + encode = cs + decode = Right . cs -class HasCodec c => ContainsCodec c cs where +instance HasCodec BS.ByteString where + encode = id + decode = Right -instance {-# OVERLAPPING #-} HasCodec c => ContainsCodec c (c : cs) -instance {-# OVERLAPPABLE #-} (HasCodec c, ContainsCodec c cs) => ContainsCodec c (c' : cs) +defaultSDKAesonOptions :: String -> Options +defaultSDKAesonOptions prefix = aesonDrop (length prefix) snakeCase diff --git a/hs-abci-sdk/src/Tendermint/SDK/Crypto.hs b/hs-abci-sdk/src/Tendermint/SDK/Crypto.hs new file mode 100644 index 00000000..0a1e779a --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Crypto.hs @@ -0,0 +1,104 @@ +module Tendermint.SDK.Crypto + ( MakeDigest(..) + , SignatureSchema(..) + , RecoverableSignatureSchema(..) + , parsePubKey + , Secp256k1 + ) where + +import Control.Error (note) +import Crypto.Hash (Digest, hashWith) +import Crypto.Hash.Algorithms (Keccak_256 (..), + SHA256) +import qualified Crypto.Secp256k1 as Secp256k1 +import Data.ByteArray (convert) +import qualified Data.ByteArray.Base64String as Base64 +import qualified Data.ByteString as B +import qualified Data.ByteString.Short as Short +import Data.Maybe (fromMaybe) +import Data.Proxy +import Data.Text (Text) +import qualified Network.ABCI.Types.Messages.FieldTypes as FT +import Tendermint.SDK.Types.Address (Address, + addressFromBytes) + +-- | Class encapsulating data which can hashed. +class MakeDigest a where + makeDigest :: a -> Digest SHA256 + +-- | Defines the types and methods for the signature schema parameterized by 'alg'. +class SignatureSchema alg where + type PubKey alg :: * + type PrivateKey alg :: * + type Signature alg :: * + type Message alg :: * + + algorithm :: Proxy alg -> Text + sign :: Proxy alg -> PrivateKey alg -> Message alg -> Signature alg + verify :: Proxy alg -> PubKey alg -> Signature alg -> Message alg -> Bool + + makePubKey :: Proxy alg -> B.ByteString -> Maybe (PubKey alg) + makeSignature :: Proxy alg -> B.ByteString -> Maybe (Signature alg) + derivePubKey :: Proxy alg -> PrivateKey alg -> PubKey alg + addressFromPubKey :: Proxy alg -> PubKey alg -> Address + +-- | Class allowing for signing and recovering signatures for messages. +class SignatureSchema alg => RecoverableSignatureSchema alg where + type RecoverableSignature alg :: * + + signRecoverableMessage :: Proxy alg -> PrivateKey alg -> Message alg -> RecoverableSignature alg + recover :: Proxy alg -> RecoverableSignature alg -> Message alg -> Maybe (PubKey alg) + serializeRecoverableSignature :: Proxy alg -> RecoverableSignature alg -> B.ByteString + makeRecoverableSignature :: Proxy alg -> B.ByteString -> Maybe (RecoverableSignature alg) + +data Secp256k1 + +msgFromSHA256 :: Digest SHA256 -> Secp256k1.Msg +msgFromSHA256 dig = fromMaybe (error "Digest SHA256 wasn't 32 bytes.") $ + Secp256k1.msg $ convert dig + +instance SignatureSchema Secp256k1 where + type PubKey Secp256k1 = Secp256k1.PubKey + type PrivateKey Secp256k1 = Secp256k1.SecKey + type Signature Secp256k1 = Secp256k1.Sig + type Message Secp256k1 = Digest SHA256 + + algorithm _ = "secp256k1" + sign _ priv dig = Secp256k1.signMsg priv (msgFromSHA256 dig) + verify _ pub sig dig = Secp256k1.verifySig pub sig (msgFromSHA256 dig) + + makePubKey _ = Secp256k1.importPubKey + makeSignature _ = Secp256k1.importSig + -- For lack of a better idea, we're just going to use the Ethereum style here + derivePubKey _ = Secp256k1.derivePubKey + addressFromPubKey _ = addressFromBytes . B.drop 12 . convert . + hashWith Keccak_256 . Secp256k1.exportPubKey False + +instance RecoverableSignatureSchema Secp256k1 where + type RecoverableSignature Secp256k1 = Secp256k1.RecSig + + signRecoverableMessage _ priv dig = Secp256k1.signRecMsg priv (msgFromSHA256 dig) + recover _ sig dig = Secp256k1.recover sig (msgFromSHA256 dig) + serializeRecoverableSignature _ sig = + let csr = Secp256k1.exportCompactRecSig sig + in Short.fromShort (Secp256k1.getCompactRecSigR csr) <> + Short.fromShort (Secp256k1.getCompactRecSigS csr) <> + B.pack [Secp256k1.getCompactRecSigV csr] + makeRecoverableSignature _ bs = + let (r,rest) = B.splitAt 32 bs + (s,v) = B.splitAt 32 rest + in if B.length r /= 32 || B.length s /= 32 || B.length v /= 1 + then Nothing + else Secp256k1.importCompactRecSig $ + Secp256k1.CompactRecSig (Short.toShort r) (Short.toShort s) (B.head v) + + +parsePubKey + :: SignatureSchema alg + => Proxy alg + -> FT.PubKey + -> Either Text (PubKey alg) +parsePubKey p FT.PubKey{..} + | pubKeyType == algorithm p = + note "Couldn't parse PubKey" $ makePubKey p (Base64.toBytes pubKeyData) + | otherwise = Left $ "Unsupported curve: " <> pubKeyType diff --git a/hs-abci-sdk/src/Tendermint/SDK/Events.hs b/hs-abci-sdk/src/Tendermint/SDK/Events.hs deleted file mode 100644 index a10d2e17..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/Events.hs +++ /dev/null @@ -1,87 +0,0 @@ -module Tendermint.SDK.Events - ( Event(..) - , IsEvent(..) - , emit - - , EventBuffer - , newEventBuffer - -- , appendEvent - -- , flushEventBuffer - , withEventBuffer - - , evalWithBuffer - ) where - -import qualified Control.Concurrent.MVar as MVar -import Control.Monad (void) -import Control.Monad.IO.Class -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 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) - -class IsEvent e where - makeEventType :: Proxy e -> String - makeEventData :: e -> [(BS.ByteString, BS.ByteString)] - -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 - :: IsEvent 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 - :: IsEvent 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-sdk/src/Tendermint/SDK/Logger.hs b/hs-abci-sdk/src/Tendermint/SDK/Logger.hs deleted file mode 100644 index 7322c33e..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/Logger.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Tendermint.SDK.Logger - ( Logger(..) - , Tendermint.SDK.Logger.log - , Severity(..) - ) where - -import Data.Text (Text) -import Polysemy (makeSem) - -data Severity = Debug | Info | Warning | Error | Exception deriving (Eq, Ord) - -data Logger m a where - Log :: Severity -> Text -> Logger m () - -makeSem ''Logger diff --git a/hs-abci-sdk/src/Tendermint/SDK/Logger/Katip.hs b/hs-abci-sdk/src/Tendermint/SDK/Logger/Katip.hs deleted file mode 100644 index cf783846..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/Logger/Katip.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Tendermint.SDK.Logger.Katip where - -import Control.Lens.TH (makeLenses) -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Katip as K -import Polysemy (Sem, interpret) -import Tendermint.SDK.Logger (Logger (..), Severity (..)) - -data LogConfig = LogConfig - { _logNamespace :: K.Namespace - , _logContext :: K.LogContexts - , _logEnv :: K.LogEnv - } -makeLenses ''LogConfig - -mkLogConfig :: Text -> Text -> IO LogConfig -mkLogConfig environment processName = do - le <- mkLogEnv - return $ LogConfig - { _logNamespace = mempty - , _logContext = mempty - , _logEnv = le - } - where - mkLogEnv = K.initLogEnv (K.Namespace [processName]) (K.Environment environment) - -evalKatip - :: forall r a. - K.Katip (Sem r) - => K.KatipContext (Sem r) - => Sem (Logger ': r) a - -> Sem r a -evalKatip = do - interpret (\case - Log severity msg -> K.logFM (coerceSeverity severity) (fromString . cs $ msg) - ) - where - coerceSeverity :: Severity -> K.Severity - coerceSeverity = \case - Debug -> K.DebugS - Info -> K.InfoS - Warning -> K.WarningS - Error -> K.ErrorS - Exception -> K.CriticalS diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth.hs new file mode 100644 index 00000000..8a80f33e --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth.hs @@ -0,0 +1,28 @@ +module Tendermint.SDK.Modules.Auth + ( Auth + , authModule + + , module Tendermint.SDK.Modules.Auth.Keeper + , module Tendermint.SDK.Modules.Auth.Query + , module Tendermint.SDK.Modules.Auth.Types + ) where + +import Polysemy (Members) +import Tendermint.SDK.Application.Module (Module (..), ModuleEffs) +import Tendermint.SDK.BaseApp (EmptyTxServer (..)) +import Tendermint.SDK.Modules.Auth.Keeper hiding (accountsMap) +import Tendermint.SDK.Modules.Auth.Query +import Tendermint.SDK.Modules.Auth.Types + +type Auth = + Module AuthName EmptyTxServer EmptyTxServer Api AuthEffs '[] + +authModule + :: Members (ModuleEffs Auth) r + => Auth r +authModule = Module + { moduleTxDeliverer = EmptyTxServer + , moduleTxChecker = EmptyTxServer + , moduleQuerier = querier + , moduleEval = eval + } diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Keeper.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Keeper.hs new file mode 100644 index 00000000..25a9ea35 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Keeper.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tendermint.SDK.Modules.Auth.Keeper + ( AuthEffs + , Accounts(..) + , createAccount + , updateAccount + , getAccount + , eval + -- stores + , accountsMap + ) where + +import Control.Lens (iso) +import Polysemy +import Polysemy.Error (Error, mapError, throw) +import Tendermint.SDK.BaseApp (AppError, IsKey (..), + KeyRoot (..), RawKey (..), + ReadStore, Store, + WriteStore, makeAppError, + makeStore) +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import Tendermint.SDK.Modules.Auth.Types +import Tendermint.SDK.Types.Address (Address) + +data Accounts m a where + CreateAccount :: Address -> Accounts m Account + UpdateAccount :: Address -> (Account -> Account) -> Accounts m () + GetAccount :: Address -> Accounts m (Maybe Account) + +makeSem ''Accounts + +type AuthEffs = '[Accounts, Error AuthError] + +eval + :: Members [ReadStore, WriteStore, Error AppError] r + => Sem (Accounts : Error AuthError : r) a + -> Sem r a +eval = mapError makeAppError . evalAuth + where + evalAuth :: Members [ReadStore, WriteStore, Error AuthError, Error AppError] r + => Sem (Accounts : r) a + -> Sem r a + evalAuth = + interpret (\case + CreateAccount addr -> createAccountF addr + UpdateAccount addr f -> updateAccountF addr f + GetAccount addr -> getAccountF addr + ) + +-------------------------------------------------------------------------------- + +data AuthNamespace + +store :: Store AuthNamespace +store = makeStore $ KeyRoot "auth" + +data AccountsMapKey = AccountsMapKey + +instance RawKey AccountsMapKey where + rawKey = iso (const "accounts") (const AccountsMapKey) + +instance IsKey AccountsMapKey AuthNamespace where + type Value AccountsMapKey AuthNamespace = M.Map Address Account + +accountsMap :: M.Map Address Account +accountsMap = M.makeMap AccountsMapKey store + +createAccountF + :: Members [ReadStore, WriteStore, Error AppError, Error AuthError] r + => Address + -> Sem r Account +createAccountF addr = do + mAcct <- M.lookup addr accountsMap + case mAcct of + Just _ -> throw $ AccountAlreadyExists addr + Nothing -> do + let emptyAccount = Account + { accountCoins = [] + , accountNonce = 0 + } + M.insert addr emptyAccount accountsMap + pure emptyAccount + +updateAccountF + :: Members [ReadStore, WriteStore, Error AppError, Error AuthError] r + => Address + -> (Account -> Account) + -> Sem r () +updateAccountF addr f = do + mAcct <- M.lookup addr accountsMap + case mAcct of + Nothing -> throw $ AccountNotFound addr + Just acct -> M.insert addr (f acct) accountsMap + +getAccountF + :: Members [ReadStore, Error AppError] r + => Address + -> Sem r (Maybe Account) +getAccountF addr = M.lookup addr accountsMap diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Query.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Query.hs new file mode 100644 index 00000000..98e14e49 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Query.hs @@ -0,0 +1,25 @@ +module Tendermint.SDK.Modules.Auth.Query + ( Api + , querier + ) where + +import Polysemy (Members) +import Servant.API ((:>)) +import qualified Tendermint.SDK.BaseApp as BaseApp +import Tendermint.SDK.BaseApp.Query (QueryEffs, StoreLeaf) +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import Tendermint.SDK.Modules.Auth.Keeper (accountsMap) +import Tendermint.SDK.Modules.Auth.Types (Account) +import Tendermint.SDK.Types.Address (Address) + +-------------------------------------------------------------------------------- +-- | Query API +-------------------------------------------------------------------------------- + +type Api = "accounts" :> StoreLeaf (M.Map Address Account) + +querier + :: Members QueryEffs r + => BaseApp.RouteQ Api r +querier = + BaseApp.storeQueryHandler accountsMap diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Types.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Types.hs new file mode 100644 index 00000000..e0d43484 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Types.hs @@ -0,0 +1,158 @@ +module Tendermint.SDK.Modules.Auth.Types + ( module Tendermint.SDK.Modules.Auth.Types + , Address(..) + ) where + +import Control.Lens (Wrapped (..), from, iso, view, + (&), (.~), (^.), (^..), + _Unwrapped') +import Data.Aeson as JSON +import Data.Bifunctor (bimap) +import qualified Data.ProtoLens as P +import Data.Proxy (Proxy (..)) +import Data.String (IsString (..)) +import Data.String.Conversions (cs) +import Data.Text (Text, pack) +import Data.Word +import GHC.Generics (Generic) +import GHC.TypeLits (symbolVal) +import qualified Proto.Modules.Auth as A +import qualified Proto.Modules.Auth_Fields as A +import Tendermint.SDK.BaseApp (AppError (..), IsAppError (..)) +import Tendermint.SDK.Codec (HasCodec (..), + defaultSDKAesonOptions) +import Tendermint.SDK.Types.Address (Address (..)) +import Web.HttpApiData (FromHttpApiData (..), + ToHttpApiData (..)) + +-------------------------------------------------------------------------------- + +type AuthName = "auth" + +-------------------------------------------------------------------------------- +-- Exceptions +-------------------------------------------------------------------------------- + +data AuthError = + AccountAlreadyExists Address + | AccountNotFound Address + +instance IsAppError AuthError where + makeAppError (AccountAlreadyExists addr) = + AppError + { appErrorCode = 1 + , appErrorCodespace = cs (symbolVal $ Proxy @AuthName) + , appErrorMessage = "Account already exists " <> (cs . show $ addr) <> "." + } + + makeAppError (AccountNotFound addr) = + AppError + { appErrorCode = 2 + , appErrorCodespace = cs (symbolVal $ Proxy @AuthName) + , appErrorMessage = "Account not found for address " <> (cs . show $ addr) <> "." + } + +-------------------------------------------------------------------------------- + +newtype CoinId = CoinId { unCoinId :: Text } deriving (Eq, Show, Generic) + +instance Wrapped CoinId where + type Unwrapped CoinId = A.CoinId + + _Wrapped' = iso t f + where + t CoinId {..} = + P.defMessage + & A.id .~ unCoinId + f message = CoinId + { unCoinId = message ^. A.id + } + +instance HasCodec CoinId where + encode = P.encodeMessage . view _Wrapped' + decode = bimap cs (view $ from _Wrapped') . P.decodeMessage + +instance IsString CoinId where + fromString = CoinId . pack +instance JSON.ToJSON CoinId where + toJSON = JSON.genericToJSON JSON.defaultOptions +instance JSON.FromJSON CoinId where + parseJSON = JSON.genericParseJSON JSON.defaultOptions +instance ToHttpApiData CoinId where + toQueryParam = unCoinId +instance FromHttpApiData CoinId where + parseQueryParam = fmap CoinId . parseQueryParam + +-------------------------------------------------------------------------------- + +newtype Amount = Amount { unAmount :: Word64 } + deriving (Eq, Show, Num, Generic, Ord, JSON.ToJSON, JSON.FromJSON) + +instance Wrapped Amount where + type Unwrapped Amount = A.Amount + + _Wrapped' = iso t f + where + t Amount {..} = + P.defMessage + & A.amount .~ unAmount + f message = Amount + { unAmount = message ^. A.amount + } + +instance HasCodec Amount where + encode = P.encodeMessage . view _Wrapped' + decode = bimap cs (view $ from _Wrapped') . P.decodeMessage + +-------------------------------------------------------------------------------- + +data Coin = Coin + { coinId :: CoinId + , coinAmount :: Amount + } deriving (Eq, Show, Generic) + +instance Wrapped Coin where + type Unwrapped Coin = A.Coin + + _Wrapped' = iso t f + where + t Coin {..} = + P.defMessage + & A.id .~ coinId ^. _Wrapped' + & A.amount .~ coinAmount ^. _Wrapped' + f message = Coin + { coinId = message ^. A.id . _Unwrapped' + , coinAmount = message ^. A.amount . _Unwrapped' + } + +instance HasCodec Coin where + encode = P.encodeMessage . view _Wrapped' + decode = bimap cs (view $ from _Wrapped') . P.decodeMessage + +coinAesonOptions :: JSON.Options +coinAesonOptions = defaultSDKAesonOptions "coin" + +-------------------------------------------------------------------------------- + +data Account = Account + { accountCoins :: [Coin] + , accountNonce :: Word64 + } deriving (Show, Generic) + +instance Wrapped Account where + type Unwrapped Account = A.Account + + _Wrapped' = iso t f + where + t Account {..} = + P.defMessage + & A.coins .~ accountCoins ^.. traverse . _Wrapped' + & A.nonce .~ accountNonce + f message = Account + { accountCoins = message ^.. A.coins. traverse . _Unwrapped' + , accountNonce = message ^. A.nonce + } + +instance HasCodec Account where + encode = P.encodeMessage . view _Wrapped' + decode = bimap cs (view $ from _Wrapped') . P.decodeMessage diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank.hs new file mode 100644 index 00000000..da0ee394 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank.hs @@ -0,0 +1,37 @@ +module Tendermint.SDK.Modules.Bank + ( + -- * Module + Bank + , bankModule + + , module Tendermint.SDK.Modules.Bank.Keeper + , module Tendermint.SDK.Modules.Bank.Messages + , module Tendermint.SDK.Modules.Bank.Query + , module Tendermint.SDK.Modules.Bank.Router + , module Tendermint.SDK.Modules.Bank.Types + + ) where + +import Data.Proxy +import Polysemy (Members) +import Tendermint.SDK.Application (Module (..), ModuleEffs) +import Tendermint.SDK.BaseApp (DefaultCheckTx (..)) +import qualified Tendermint.SDK.Modules.Auth as Auth +import Tendermint.SDK.Modules.Bank.Keeper +import Tendermint.SDK.Modules.Bank.Messages +import Tendermint.SDK.Modules.Bank.Query +import Tendermint.SDK.Modules.Bank.Router +import Tendermint.SDK.Modules.Bank.Types + +type Bank = + Module BankName MessageApi MessageApi QueryApi BankEffs '[Auth.Auth] + +bankModule + :: Members (ModuleEffs Bank) r + => Bank r +bankModule = Module + { moduleTxDeliverer = messageHandlers + , moduleTxChecker = defaultCheckTx (Proxy :: Proxy MessageApi) (Proxy :: Proxy r) + , moduleQuerier = querier + , moduleEval = eval + } diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Keeper.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Keeper.hs new file mode 100644 index 00000000..8b5b4bfb --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Keeper.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tendermint.SDK.Modules.Bank.Keeper + ( BankEffs + , BankKeeper(..) + , getBalance + , transfer + , burn + , mint + , eval + ) where + +import Data.List (find) +import Data.Maybe (fromMaybe) +import Polysemy +import Polysemy.Error (Error, mapError, throw) +import Polysemy.Output (Output) +import qualified Tendermint.SDK.BaseApp as BaseApp +import qualified Tendermint.SDK.Modules.Auth as Auth +import Tendermint.SDK.Modules.Bank.Types (BankError (..), + TransferEvent (..)) +import Tendermint.SDK.Types.Address (Address) + +type BankEffs = '[BankKeeper, Error BankError] + +data BankKeeper m a where + GetBalance :: Address -> Auth.CoinId -> BankKeeper m Auth.Coin + Transfer :: Address -> Auth.Coin -> Address -> BankKeeper m () + Burn :: Address -> Auth.Coin -> BankKeeper m () + Mint :: Address -> Auth.Coin -> BankKeeper m () + +makeSem ''BankKeeper + +eval + :: Members [BaseApp.Logger, Output BaseApp.Event, Error BaseApp.AppError] r + => Members Auth.AuthEffs r + => forall a. Sem (BankKeeper ': Error BankError ': r) a -> Sem r a +eval = mapError BaseApp.makeAppError . evalBankKeeper + where + evalBankKeeper + :: forall r. + Members Auth.AuthEffs r + => Members [BaseApp.Logger, Output BaseApp.Event, Error BankError ] r + => forall a. + Sem (BankKeeper ': r) a + -> Sem r a + evalBankKeeper = interpret (\case + GetBalance addr coinId -> getCoinBalance addr coinId + Transfer from coin to -> transferF from coin to + Burn addr coin -> burnF addr coin + Mint addr coin -> mintF addr coin + ) + +-------------------------------------------------------------------------------- + +transferF + :: Members [BaseApp.Logger, Output BaseApp.Event, Error BankError] r + => Members Auth.AuthEffs r + => Address + -> Auth.Coin + -> Address + -> Sem r () +transferF addr1 (Auth.Coin cid amount) addr2 = do + -- check if addr1 has amt + (Auth.Coin _ addr1Bal) <- getCoinBalance addr1 cid + if addr1Bal >= amount + then do + (Auth.Coin _ addr2Bal) <- getCoinBalance addr2 cid + let newCoinBalance1 = Auth.Coin cid (addr1Bal - amount) + newCoinBalance2 = Auth.Coin cid (addr2Bal + amount) + -- update both balances + putCoinBalance addr1 newCoinBalance1 + putCoinBalance addr2 newCoinBalance2 + let event = TransferEvent + { transferEventAmount = amount + , transferEventCoinId = cid + , transferEventTo = addr2 + , transferEventFrom = addr1 + } + BaseApp.emit event + BaseApp.logEvent event + else throw @BankError (InsufficientFunds "Insufficient funds for transfer.") + +burnF + :: Members Auth.AuthEffs r + => Member (Error BankError) r + => Address + -> Auth.Coin + -> Sem r () +burnF addr (Auth.Coin cid amount) = do + (Auth.Coin _ bal) <- getCoinBalance addr cid + if bal < amount + then throw @BankError $ InsufficientFunds "Insufficient funds for burn." + else putCoinBalance addr (Auth.Coin cid (bal - amount)) + +mintF + :: Members Auth.AuthEffs r + => Address + -> Auth.Coin + -> Sem r () +mintF addr (Auth.Coin cid amount) = do + (Auth.Coin _ bal) <- getCoinBalance addr cid + putCoinBalance addr (Auth.Coin cid (bal + amount)) + +-------------------------------------------------------------------------------- + +getCoinBalance + :: Members Auth.AuthEffs r + => Address + -> Auth.CoinId + -> Sem r Auth.Coin +getCoinBalance address cid = do + mAcnt <- Auth.getAccount address + let zeroBalance = Auth.Coin cid 0 + case mAcnt of + Nothing -> pure zeroBalance + Just (Auth.Account coins _) -> + let mCoin = find (\(Auth.Coin cid1 _) -> cid == cid1) coins + in pure $ fromMaybe zeroBalance mCoin + +replaceCoinValue + :: Auth.Coin + -> [Auth.Coin] + -> [Auth.Coin] +replaceCoinValue c [] = [c] +replaceCoinValue c@(Auth.Coin cid _) (c1@(Auth.Coin cid' _):rest) = + if cid' == cid + then c : rest + else c1 : replaceCoinValue c rest + +putCoinBalance + :: Members Auth.AuthEffs r + => Address + -> Auth.Coin + -> Sem r () +putCoinBalance address coin = do + mAcnt <- Auth.getAccount address + acnt <- case mAcnt of + Nothing -> Auth.createAccount address + Just a -> pure a + let f a = a { Auth.accountCoins = replaceCoinValue coin $ Auth.accountCoins acnt } + Auth.updateAccount address f + diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Messages.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Messages.hs new file mode 100644 index 00000000..50d52902 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Messages.hs @@ -0,0 +1,86 @@ +module Tendermint.SDK.Modules.Bank.Messages where + +import Control.Lens (Wrapped (..), from, iso, view, + (&), (.~), (^.)) +import Data.Bifunctor (bimap) +import qualified Data.ProtoLens as P +import Data.String.Conversions (cs) +import Data.Validation (Validation (..)) +import GHC.Generics (Generic) +import qualified Proto.Modules.Bank as B +import qualified Proto.Modules.Bank_Fields as B +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Modules.Auth (Amount (..), CoinId (..)) +import Tendermint.SDK.Types.Address (Address, addressFromBytes, + addressToBytes) +import Tendermint.SDK.Types.Message (HasMessageType (..), + ValidateMessage (..)) + +data TransferMsg = TransferMsg + { transferTo :: Address + , transferFrom :: Address + , transferCoinId :: CoinId + , transferAmount :: Amount + } deriving (Eq, Show, Generic) + +instance Wrapped TransferMsg where + type Unwrapped TransferMsg = B.Transfer + + _Wrapped' = iso t f + where + t TransferMsg {..} = + P.defMessage + & B.to .~ addressToBytes transferTo + & B.from .~ addressToBytes transferFrom + & B.cid .~ unCoinId transferCoinId + & B.amount .~ unAmount transferAmount + f message = TransferMsg + { transferTo = addressFromBytes $ message ^. B.to + , transferFrom = addressFromBytes $ message ^. B.from + , transferCoinId = CoinId $ message ^. B.cid + , transferAmount = Amount $ message ^. B.amount + } + +instance HasMessageType TransferMsg where + messageType _ = "TransferMsg" + +instance HasCodec TransferMsg where + encode = P.encodeMessage . view _Wrapped' + decode = bimap cs (view $ from _Wrapped') . P.decodeMessage + +instance ValidateMessage TransferMsg where + validateMessage _ = Success () + +-------------------------------------------------------------------------------- + +data BurnMsg = BurnMsg + { burnAddress :: Address + , burnCoinId :: CoinId + , burnAmount :: Amount + } deriving (Eq, Show, Generic) + +instance Wrapped BurnMsg where + type Unwrapped BurnMsg = B.Burn + + _Wrapped' = iso t f + where + t BurnMsg {..} = + P.defMessage + & B.address .~ addressToBytes burnAddress + & B.cid .~ unCoinId burnCoinId + & B.amount .~ unAmount burnAmount + f message = BurnMsg + { burnAddress = addressFromBytes $ message ^. B.address + , burnCoinId = CoinId $ message ^. B.cid + , burnAmount = Amount $ message ^. B.amount + } + +instance HasMessageType BurnMsg where + messageType _ = "BurnMsg" + +instance HasCodec BurnMsg where + encode = P.encodeMessage . view _Wrapped' + decode = bimap cs (view $ from _Wrapped') . P.decodeMessage + +instance ValidateMessage BurnMsg where + validateMessage _ = Success () diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Query.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Query.hs new file mode 100644 index 00000000..6ef9b59b --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Query.hs @@ -0,0 +1,44 @@ +module Tendermint.SDK.Modules.Bank.Query where + +import Control.Lens ((^.)) +import qualified Data.ByteArray.Base64String as Base64 +import Polysemy +import Servant.API +import qualified Tendermint.SDK.BaseApp as BaseApp +import Tendermint.SDK.BaseApp.Query (QueryArgs (..)) +import qualified Tendermint.SDK.Modules.Auth as Auth +import Tendermint.SDK.Modules.Bank.Keeper (BankKeeper, getBalance) +import Tendermint.SDK.Types.Address (Address) + +-------------------------------------------------------------------------------- +-- | Query Api +-------------------------------------------------------------------------------- + +type GetAddressCoinBalance = + "balance" + :> BaseApp.QA Address + :> QueryParam' '[Required, Strict] "coin_id" Auth.CoinId + :> BaseApp.Leaf Auth.Coin + +getAddressCoinBalance + :: Member BankKeeper r + => QueryArgs Address + -> Auth.CoinId + -> Sem r (BaseApp.QueryResult Auth.Coin) +getAddressCoinBalance (QueryArgs _ address _) cid = do + coin <- getBalance address cid + pure $ BaseApp.QueryResult + { queryResultData = coin + , queryResultIndex = 0 + , queryResultKey = Base64.fromBytes $ address ^. BaseApp.rawKey + , queryResultProof = Nothing + , queryResultHeight = 0 + } + +type QueryApi = GetAddressCoinBalance + +querier + :: forall r. + Member BankKeeper r + => BaseApp.RouteQ QueryApi r +querier = getAddressCoinBalance diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Router.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Router.hs new file mode 100644 index 00000000..bbe9885a --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Router.hs @@ -0,0 +1,42 @@ +module Tendermint.SDK.Modules.Bank.Router + ( MessageApi + , messageHandlers + ) where + +import Polysemy (Members, Sem) +import Servant.API ((:<|>) (..)) +import Tendermint.SDK.BaseApp ((:~>), Return, RouteTx, + RoutingTx (..), + TypedMessage) +import Tendermint.SDK.Modules.Auth (Coin (..)) +import Tendermint.SDK.Modules.Bank.Keeper (BankEffs, burn, transfer) +import Tendermint.SDK.Modules.Bank.Messages +import Tendermint.SDK.Types.Message (Msg (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) + +type MessageApi = + TypedMessage BurnMsg :~> Return () + :<|> TypedMessage TransferMsg :~> Return () + +messageHandlers + ::Members BankEffs r + => RouteTx MessageApi r +messageHandlers = burnH :<|> transferH + +transferH + :: Members BankEffs r + => RoutingTx TransferMsg + -> Sem r () +transferH (RoutingTx Tx{txMsg=Msg{msgData}}) = + let TransferMsg{..} = msgData + coin = Coin transferCoinId transferAmount + in transfer transferFrom coin transferTo + +burnH + :: Members BankEffs r + => RoutingTx BurnMsg + -> Sem r () +burnH (RoutingTx Tx{txMsg=Msg{msgData}}) = + let BurnMsg{..} = msgData + coin = Coin burnCoinId burnAmount + in burn burnAddress coin diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Types.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Types.hs new file mode 100644 index 00000000..d62e130d --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Types.hs @@ -0,0 +1,54 @@ +module Tendermint.SDK.Modules.Bank.Types + ( module Tendermint.SDK.Modules.Bank.Types + , Auth.Amount(..) + , Auth.Coin(..) + , Auth.CoinId(..) + ) where + +import Data.Aeson as A +import Data.Text (Text) +import GHC.Generics (Generic) +import qualified Tendermint.SDK.BaseApp as BaseApp +import Tendermint.SDK.Codec (defaultSDKAesonOptions) +import qualified Tendermint.SDK.Modules.Auth as Auth +import Tendermint.SDK.Types.Address (Address (..)) + +-------------------------------------------------------------------------------- + +type BankName = "bank" + +-------------------------------------------------------------------------------- +-- Exceptions +-------------------------------------------------------------------------------- + +data BankError = + InsufficientFunds Text + +instance BaseApp.IsAppError BankError where + makeAppError (InsufficientFunds msg) = + BaseApp.AppError + { appErrorCode = 1 + , appErrorCodespace = "bank" + , appErrorMessage = msg + } + +-------------------------------------------------------------------------------- +-- Events +-------------------------------------------------------------------------------- + +data TransferEvent = TransferEvent + { transferEventCoinId :: Auth.CoinId + , transferEventAmount :: Auth.Amount + , transferEventTo :: Address + , transferEventFrom :: Address + } deriving (Eq, Show, Generic) + +transferEventAesonOptions :: A.Options +transferEventAesonOptions = defaultSDKAesonOptions "transferEvent" + +instance A.ToJSON TransferEvent where + toJSON = A.genericToJSON transferEventAesonOptions +instance A.FromJSON TransferEvent where + parseJSON = A.genericParseJSON transferEventAesonOptions +instance BaseApp.ToEvent TransferEvent +instance BaseApp.Select TransferEvent diff --git a/hs-abci-sdk/src/Tendermint/SDK/Router.hs b/hs-abci-sdk/src/Tendermint/SDK/Router.hs deleted file mode 100644 index d39afbc3..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/Router.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Tendermint.SDK.Router - ( serve - , serveRouter - , QueryApplication - , module Tendermint.SDK.Router.Class - , module Tendermint.SDK.Router.Router - , module Tendermint.SDK.Router.Types - , module Tendermint.SDK.Router.Delayed - ) where - -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Proxy - -import qualified Network.ABCI.Types.Messages.Request as Request -import qualified Network.ABCI.Types.Messages.Response as Response - -import Tendermint.SDK.Router.Class -import Tendermint.SDK.Router.Delayed -import Tendermint.SDK.Router.Router -import Tendermint.SDK.Router.Types - -type QueryApplication m = Request.Query -> m Response.Query - -serveRouter - :: Monad m - => Router () m - -> QueryApplication m -serveRouter r = toApplication $ runRouter r () - -serve - :: HasRouter layout - => MonadIO m - => Proxy layout - -> RouteT layout m - -> QueryApplication m -serve p server = - toApplication (runRouter (route p (emptyDelayed (Route server))) ()) - -toApplication - :: Monad m - => RoutingApplication m -> QueryApplication m -toApplication ra query = do - res <- ra query - case res of - Fail e -> pure $ responseQueryError e - FailFatal e -> pure $ responseQueryError e - Route a -> pure a diff --git a/hs-abci-sdk/src/Tendermint/SDK/Router/Class.hs b/hs-abci-sdk/src/Tendermint/SDK/Router/Class.hs deleted file mode 100644 index 89f420ba..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/Router/Class.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Tendermint.SDK.Router.Class where - -import Control.Error -import Data.Proxy -import Data.String.Conversions (cs) -import GHC.TypeLits (KnownSymbol, symbolVal) -import Servant.API -import Tendermint.SDK.Router.Delayed (Delayed, addQueryArgs, - delayedFail) -import Tendermint.SDK.Router.Router (Router, Router' (..), choice, - methodRouter, pathRouter) -import Tendermint.SDK.Router.Types (EncodeQueryResult (..), - FromQueryData (..), Leaf, QA, - QueryArgs (..), QueryError (..), - QueryResult) - --------------------------------------------------------------------------------- - - -class HasRouter layout where - -- | A route handler. - type RouteT layout (m :: * -> *) :: * - -- | Transform a route handler into a 'Router'. - route :: Monad m => Proxy layout -> Delayed m env (RouteT layout m) -> Router env m - - -instance (HasRouter a, HasRouter b) => HasRouter (a :<|> b) where - type RouteT (a :<|> b) m = RouteT a m :<|> RouteT b m - - route _ server = choice (route pa ((\ (a :<|> _) -> a) <$> server)) - (route pb ((\ (_ :<|> b) -> b) <$> server)) - where pa = Proxy :: Proxy a - pb = Proxy :: Proxy b - -instance (HasRouter sublayout, KnownSymbol path) => HasRouter (path :> sublayout) where - - type RouteT (path :> sublayout) m = RouteT sublayout m - - route _ subserver = - pathRouter (cs (symbolVal proxyPath)) (route (Proxy :: Proxy sublayout) subserver) - where proxyPath = Proxy :: Proxy path - - -instance EncodeQueryResult a => HasRouter (Leaf a) where - - type RouteT (Leaf a) m = ExceptT QueryError m (QueryResult a) - route _ = methodRouter - - -instance (FromQueryData a, HasRouter layout) - => HasRouter (QA a :> layout) where - - type RouteT (QA a :> layout) m = QueryArgs a -> RouteT layout m - - route _ d = - RQueryArgs $ - route (Proxy :: Proxy layout) - (addQueryArgs d $ \ qa -> case fromQueryData $ queryArgsData qa of - Left e -> delayedFail $ InvalidQuery e - Right v -> return qa {queryArgsData = v} - ) diff --git a/hs-abci-sdk/src/Tendermint/SDK/Router/Delayed.hs b/hs-abci-sdk/src/Tendermint/SDK/Router/Delayed.hs deleted file mode 100644 index 1fdd8c89..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/Router/Delayed.hs +++ /dev/null @@ -1,99 +0,0 @@ -module Tendermint.SDK.Router.Delayed where - -import Control.Error (ExceptT, runExceptT) -import Control.Monad.Reader (MonadReader, ReaderT, - ask, runReaderT) -import Control.Monad.Trans (MonadTrans (..)) -import Data.Default.Class (def) -import Data.String.Conversions (cs) -import qualified Network.ABCI.Types.Messages.Request as Request -import qualified Network.ABCI.Types.Messages.Response as Response -import Tendermint.SDK.Router.Types (QueryError (..), - RouteResult (..), - RouteResultT (..)) - --------------------------------------------------------------------------------- - - -newtype DelayedM m a = - DelayedM { runDelayedM' :: ReaderT Request.Query (RouteResultT m) a } - deriving (Functor, Applicative, Monad, MonadReader Request.Query) - -liftRouteResult :: Monad m => RouteResult a -> DelayedM m a -liftRouteResult x = DelayedM $ lift $ RouteResultT . return $ x - -runDelayedM :: DelayedM m a -> Request.Query -> m (RouteResult a) -runDelayedM m req = runRouteResultT $ runReaderT (runDelayedM' m) req - --------------------------------------------------------------------------------- - -data Delayed m env a where - Delayed :: { delayedQueryArgs :: env -> DelayedM m qa - , delayedHandler :: qa -> Request.Query -> RouteResult a - } -> Delayed m env a - -instance Functor (Delayed m env) where - fmap f Delayed{..} = - Delayed { delayedHandler = fmap (fmap f) . delayedHandler - , .. - } - -runDelayed :: Monad m - => Delayed m env a - -> env - -> Request.Query - -> m (RouteResult a) -runDelayed Delayed{..} env = runDelayedM (do - q <- ask - qa <- delayedQueryArgs env - liftRouteResult $ delayedHandler qa q - ) - -runAction :: Monad m - => Delayed m env (ExceptT QueryError m a) - -> env - -> Request.Query - -> (a -> RouteResult Response.Query) - -> m (RouteResult Response.Query) -runAction action env query k = - runDelayed action env query >>= go - where - go (Fail e) = pure $ Fail e - go (FailFatal e) = pure $ FailFatal e - go (Route a) = do - e <- runExceptT a - case e of - Left err -> pure $ Route (responseQueryError err) - Right a' -> pure $ k a' - --- | Fail with the option to recover. -delayedFail :: Monad m => QueryError -> DelayedM m a -delayedFail err = liftRouteResult $ Fail err - -responseQueryError :: QueryError -> Response.Query -responseQueryError e = - let msg = case e of - PathNotFound -> "Path Not Found" - ResourceNotFound -> "Resource Not Found" - InvalidQuery m -> "Invalid Query: " <> m - InternalError _ -> "Internal Error" - in def { Response.queryCode = 1 - , Response.queryLog = cs msg - } - -addQueryArgs - :: Monad m - => Delayed m env (a -> b) - -> (qa -> DelayedM m a) - -> Delayed m (qa, env) b -addQueryArgs Delayed{..} new = - Delayed - { delayedQueryArgs = \ (qa, env) -> (,) <$> delayedQueryArgs env <*> new qa - , delayedHandler = \ (x, v) query -> ($ v) <$> delayedHandler x query - , .. - } - -emptyDelayed :: Monad m => RouteResult a -> Delayed m b a -emptyDelayed response = - let r = pure () - in Delayed (const r) $ \_ _ -> response diff --git a/hs-abci-sdk/src/Tendermint/SDK/Router/Router.hs b/hs-abci-sdk/src/Tendermint/SDK/Router/Router.hs deleted file mode 100644 index cef3578b..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/Router/Router.hs +++ /dev/null @@ -1,98 +0,0 @@ -module Tendermint.SDK.Router.Router where - -import Control.Error -import Control.Lens (to, (&), (.~), (^.)) -import Data.ByteArray.Base64String (Base64String) -import Data.Default.Class (def) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Network.ABCI.Types.Messages.Request as Request -import qualified Network.ABCI.Types.Messages.Response as Response -import Network.HTTP.Types (decodePathSegments) -import Tendermint.SDK.Router.Delayed (Delayed, runAction) -import Tendermint.SDK.Router.Types (EncodeQueryResult (..), - QueryArgs (..), - QueryError (..), - QueryResult (..), - RouteResult (..)) - - -data Router' env a = - RChoice (Router' env a) (Router' env a) - | RStatic (Map Text (Router' env a)) [env -> a] - | RQueryArgs (Router' (QueryArgs Base64String, env) a) - -type RoutingApplication m = Request.Query -> m (RouteResult Response.Query) - -type Router env m = Router' env (RoutingApplication m) - -pathRouter :: Text -> Router' env a -> Router' env a -pathRouter t r = RStatic (M.singleton t r) [] - -leafRouter :: (env -> a) -> Router' env a -leafRouter l = RStatic M.empty [l] - -choice :: Router' env a -> Router' env a -> Router' env a -choice (RStatic table1 ls1) (RStatic table2 ls2) = - RStatic (M.unionWith choice table1 table2) (ls1 ++ ls2) -choice router1 (RChoice router2 router3) = RChoice (choice router1 router2) router3 -choice router1 router2 = RChoice router1 router2 - - -methodRouter - :: Monad m - => EncodeQueryResult b - => Delayed m env (ExceptT QueryError m (QueryResult b)) - -> Router env m -methodRouter action = leafRouter route' - where - route' env query = runAction action env query $ \QueryResult{..} -> - Route $ def & Response._queryIndex .~ queryResultIndex - & Response._queryKey .~ queryResultKey - & Response._queryValue .~ encodeQueryResult queryResultData - & Response._queryProof .~ queryResultProof - & Response._queryHeight .~ queryResultHeight - -runRouter - :: Monad m - => Router env m - -> env - -> RoutingApplication m -runRouter router env query = - case router of - RStatic table ls -> - let path = query ^. Request._queryPath . to (decodePathSegments . T.encodeUtf8) - in case path of - [] -> runChoice ls env query - -- This case is to handle trailing slashes. - [""] -> runChoice ls env query - first : rest | Just router' <- M.lookup first table - -> let query' = query { Request.queryPath = T.intercalate "/" rest } - in runRouter router' env query' - _ -> pure $ Fail PathNotFound - RQueryArgs r' -> - let qa = QueryArgs - { queryArgsData = query ^. Request._queryData - , queryArgsQueryData = query ^. Request._queryData - , queryArgsBlockHeight = query ^. Request._queryHeight - , queryArgsProve = query ^. Request._queryProve - } - in runRouter r' (qa, env) query - RChoice r1 r2 -> - runChoice [runRouter r1, runRouter r2] env query - -runChoice :: Monad m => [env -> RoutingApplication m] -> env -> RoutingApplication m -runChoice ls = - case ls of - [] -> \ _ _ -> pure $ Fail PathNotFound - [r] -> r - (r : rs) -> - \ env query -> do - response1 <- r env query - case response1 of - Fail _ -> runChoice rs env query - _ -> pure response1 - diff --git a/hs-abci-sdk/src/Tendermint/SDK/Router/Types.hs b/hs-abci-sdk/src/Tendermint/SDK/Router/Types.hs deleted file mode 100644 index b86a01eb..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/Router/Types.hs +++ /dev/null @@ -1,101 +0,0 @@ -module Tendermint.SDK.Router.Types where - -import Control.Lens (from, (^.)) -import Control.Monad (ap) -import Control.Monad.Trans (MonadTrans (..)) -import Data.ByteArray.Base64String (Base64String, - fromBytes, toBytes) -import Data.Int (Int64) -import GHC.TypeLits (Symbol) -import Network.ABCI.Types.Messages.FieldTypes (Proof, WrappedVal (..)) -import qualified Network.ABCI.Types.Messages.Request as Request -import qualified Network.ABCI.Types.Messages.Response as Response -import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Store (HasKey (..)) - - -data Leaf (a :: *) - -data QA (a :: *) - --------------------------------------------------------------------------------- - -type Application m = Request.Query -> m Response.Query - --------------------------------------------------------------------------------- - -data QueryError = - PathNotFound - | ResourceNotFound - | InvalidQuery String - | InternalError String - deriving (Show) - -data QueryArgs a = QueryArgs - { queryArgsProve :: Bool - , queryArgsData :: a - , queryArgsQueryData :: Base64String - , queryArgsBlockHeight :: WrappedVal Int64 - } deriving Functor - -data QueryResult a = QueryResult - { queryResultData :: a - , queryResultIndex :: WrappedVal Int64 - , queryResultKey :: Base64String - , queryResultProof :: Maybe Proof - , queryResultHeight :: WrappedVal Int64 - } deriving Functor - --------------------------------------------------------------------------------- - -class HasKey a => Queryable a where - type Name a :: Symbol - -class EncodeQueryResult a where - encodeQueryResult :: a -> Base64String - - default encodeQueryResult :: HasCodec a => a -> Base64String - encodeQueryResult = fromBytes . encode - -class FromQueryData a where - fromQueryData :: Base64String -> Either String a - default fromQueryData :: (HasKey b, Key b ~ a) => Base64String -> Either String a - fromQueryData bs = Right (toBytes bs ^. from rawKey) - --------------------------------------------------------------------------------- - -data RouteResult a = - Fail QueryError - | FailFatal QueryError - | Route a - deriving (Functor) - -instance Applicative RouteResult where - pure = return - (<*>) = ap - -instance Monad RouteResult where - return = Route - (>>=) m f = case m of - Route a -> f a - Fail e -> Fail e - FailFatal e -> FailFatal e - -data RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) } - deriving (Functor) - -instance MonadTrans RouteResultT where - lift m = RouteResultT $ fmap Route m - -instance Monad m => Applicative (RouteResultT m) where - pure = return - (<*>) = ap - -instance Monad m => Monad (RouteResultT m) where - return = RouteResultT . return . Route - (>>=) m f = RouteResultT $ do - a <- runRouteResultT m - case a of - Route a' -> runRouteResultT $ f a' - Fail e -> return $ Fail e - FailFatal e -> return $ FailFatal e diff --git a/hs-abci-sdk/src/Tendermint/SDK/Store.hs b/hs-abci-sdk/src/Tendermint/SDK/Store.hs deleted file mode 100644 index 07f42f61..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/Store.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Tendermint.SDK.Store - ( RawStore(..) - , HasKey(..) - , Root(..) - , get - , put - , prove - , root - ) where - -import Control.Lens (Iso', (^.)) -import qualified Data.ByteString as BS -import Polysemy (Member, Sem, makeSem) -import Tendermint.SDK.Codec (HasCodec (..)) - -newtype Root = Root BS.ByteString - -data RawStore m a where - RawStorePut :: BS.ByteString -> BS.ByteString -> RawStore m () - RawStoreGet :: Root -> BS.ByteString -> RawStore m (Maybe BS.ByteString) - RawStoreProve :: Root -> BS.ByteString -> RawStore m (Maybe BS.ByteString) - RawStoreRoot :: RawStore m Root - -makeSem ''RawStore - -class HasCodec a => HasKey a where - type Key a = k | k -> a - rawKey :: Iso' (Key a) BS.ByteString - -root - :: Member RawStore r - => Sem r Root -root = rawStoreRoot - -put - :: forall a r. - HasKey a - => Member RawStore r - => Key a - -> a - -> Sem r () -put k a = - let key = k ^. rawKey - val = encode a - in rawStorePut key val - -get - :: forall a r. - HasKey a - => Member RawStore r - => Root - -> Key a - -> Sem r (Maybe a) -get index k = do - let key = k ^. rawKey - mRes <- rawStoreGet index key - pure $ case mRes of - Nothing -> Nothing - Just raw -> case decode raw of - Left e -> error $ "Impossible codec error " <> e - Right a -> Just a - -prove - :: HasKey a - => Member RawStore r - => Root - -> Key a - -> Sem r (Maybe BS.ByteString) -prove r k = rawStoreProve r (k ^. rawKey) diff --git a/hs-abci-sdk/src/Tendermint/SDK/StoreQueries.hs b/hs-abci-sdk/src/Tendermint/SDK/StoreQueries.hs deleted file mode 100644 index 7b32cf26..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/StoreQueries.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Tendermint.SDK.StoreQueries where - ---import Servant.API --- import Tendermint.SDK.Routes -import Control.Error (ExceptT, throwE) -import Control.Lens (to, (^.)) -import Control.Monad.Trans (lift) -import Data.ByteArray.Base64String (fromBytes) -import Data.Proxy -import Polysemy (Member, Sem) -import Servant.API ((:<|>) (..), (:>)) -import Tendermint.SDK.Router.Class -import Tendermint.SDK.Router.Types -import Tendermint.SDK.Store (HasKey (..), RawStore, get) - -class StoreQueryHandler a h where - storeQueryHandler :: Proxy a -> h - -instance - ( HasKey a - , Key a ~ k - , Member RawStore r - ) - => StoreQueryHandler a (QueryArgs k -> ExceptT QueryError (Sem r) (QueryResult a)) where - storeQueryHandler _ QueryArgs{..} = do - let key = queryArgsData - mRes <- lift $ get undefined key - case mRes of - Nothing -> throwE ResourceNotFound - Just (res :: a) -> pure $ QueryResult - -- TODO: actually handle proofs - { queryResultData = res - , queryResultIndex = 0 - , queryResultKey = key ^. rawKey . to fromBytes - , queryResultProof = Nothing - , queryResultHeight = 0 - } - -class StoreQueryHandlers (items :: [*]) m where - type QueryApi items :: * - storeQueryHandlers :: Proxy items -> Proxy m -> RouteT (QueryApi items) m - -instance - ( Queryable a - , Member RawStore r - ) => StoreQueryHandlers (a ': '[]) (Sem r) where - type QueryApi (a ': '[]) = Name a :> QA (Key a) :> Leaf a - storeQueryHandlers _ _ = storeQueryHandler (Proxy :: Proxy a) - -instance - ( Queryable a - , StoreQueryHandlers (a': as) (Sem r) - , Member RawStore r - ) => StoreQueryHandlers (a ': a' : as) (Sem r) where - type (QueryApi (a ': a' : as)) = (Name a :> QA (Key a) :> Leaf a) :<|> QueryApi (a' ': as) - storeQueryHandlers _ pm = - storeQueryHandler (Proxy :: Proxy a) :<|> - storeQueryHandlers (Proxy :: Proxy (a' ': as)) pm - -allStoreHandlers - :: forall (contents :: [*]) r. - StoreQueryHandlers contents (Sem r) - => Member RawStore r - => Proxy contents - -> Proxy r - -> RouteT (QueryApi contents) (Sem r) -allStoreHandlers _ _ = storeQueryHandlers (Proxy :: Proxy contents) (Proxy :: Proxy (Sem r)) diff --git a/hs-abci-sdk/src/Tendermint/SDK/Subscription.hs b/hs-abci-sdk/src/Tendermint/SDK/Subscription.hs deleted file mode 100644 index fc1d178f..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/Subscription.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Tendermint.SDK.Subscription where - -import Control.Concurrent.Async as Async -import qualified Control.Concurrent.MVar as MVar -import Control.Monad (forM_, forever) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Conduit -import qualified Data.IORef as IORef -import qualified Data.Map as M -import Polysemy -import Polysemy.Output - -data SubscriptionDriver o = SubscriptionDriver - { listenersVar :: IORef.IORef (M.Map Int (MVar.MVar o)) - , freshVar :: IORef.IORef Int - } - -initSubscriptionDriver :: IO (SubscriptionDriver o) -initSubscriptionDriver = do - ls <- IORef.newIORef M.empty - f <- IORef.newIORef 0 - pure $ SubscriptionDriver ls f - -eval - :: MonadIO (Sem r) - => SubscriptionDriver o - -> Sem (Output o ': r) a - -> Sem r a -eval SubscriptionDriver{listenersVar} = - interpret (\case - Output o -> liftIO $ do - listeners <- IORef.readIORef listenersVar - forM_ listeners $ \listener -> MVar.putMVar listener o - ) - -subscribe - :: SubscriptionDriver o - -> ConduitT o Void IO () - -> IO (Async.Async ()) -subscribe SubscriptionDriver{freshVar, listenersVar} consumer = do - inputVar <- MVar.newEmptyMVar - listenerId <- do - listenerId <- IORef.readIORef freshVar - IORef.modifyIORef freshVar (1 +) - IORef.modifyIORef listenersVar (M.insert listenerId inputVar) - pure listenerId - let producer = mkProducer inputVar - Async.async $ do - runConduit (producer .| consumer) - IORef.modifyIORef listenersVar (M.delete listenerId) - where - mkProducer :: MonadIO m => MVar.MVar o -> ConduitT () o m () - mkProducer var = forever $ do - mInput <- liftIO $ MVar.tryTakeMVar var - case mInput of - Nothing -> pure () - Just a -> yield a diff --git a/hs-abci-sdk/src/Tendermint/SDK/Types/Address.hs b/hs-abci-sdk/src/Tendermint/SDK/Types/Address.hs new file mode 100644 index 00000000..712ae92b --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Types/Address.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Tendermint.SDK.Types.Address where + +import qualified Crypto.Secp256k1 as Crypto +import qualified Data.Aeson as A +import qualified Data.ByteArray.HexString as Hex +import Data.ByteString (ByteString) +import Data.String (fromString) +import Data.Text (unpack) +import GHC.Generics (Generic) +import Proto3.Suite (HasDefault (..), MessageField, + Primitive (..)) +import qualified Proto3.Suite.DotProto as DotProto +import qualified Proto3.Wire.Decode as Decode +import qualified Proto3.Wire.Encode as Encode +import Tendermint.SDK.Codec (HasCodec (..)) +import Web.HttpApiData (FromHttpApiData (..), + ToHttpApiData (..)) + +-- | Used as a unique identifier for an account. +newtype Address = + Address Hex.HexString + deriving (Eq, Show, Generic, Ord, A.ToJSON, A.FromJSON) + +instance Primitive Address where + encodePrimitive n a = Encode.byteString n $ addressToBytes a + decodePrimitive = addressFromBytes <$> Decode.byteString + primType _ = DotProto.Bytes +instance HasDefault Hex.HexString +instance HasDefault Address +instance MessageField Address +instance HasCodec Address where + decode = Right . addressFromBytes + encode = addressToBytes +instance ToHttpApiData Address where + toQueryParam (Address aHex) = Hex.format aHex +instance FromHttpApiData Address where + parseQueryParam = Right . Address . fromString . unpack + +addressToBytes :: Address -> ByteString +addressToBytes (Address addrHex) = Hex.toBytes addrHex + +addressFromBytes :: ByteString -> Address +addressFromBytes = Address . Hex.fromBytes + +pubKeyToAddress :: Crypto.PubKey -> Address +pubKeyToAddress = addressFromBytes . Crypto.exportPubKey False diff --git a/hs-abci-sdk/src/Tendermint/SDK/Types/Effects.hs b/hs-abci-sdk/src/Tendermint/SDK/Types/Effects.hs new file mode 100644 index 00000000..9aef2ae7 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Types/Effects.hs @@ -0,0 +1,10 @@ +module Tendermint.SDK.Types.Effects + ( (:&) + ) where + +-- | This type family gives a nice syntax for combining multiple lists of effects. +type family (as :: [a]) :& (bs :: [a]) :: [a] where + '[] :& bs = bs + (a ': as) :& bs = a ': (as :& bs) + +infixr 5 :& diff --git a/hs-abci-sdk/src/Tendermint/SDK/Types/Message.hs b/hs-abci-sdk/src/Tendermint/SDK/Types/Message.hs new file mode 100644 index 00000000..bdd203b5 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Types/Message.hs @@ -0,0 +1,143 @@ +module Tendermint.SDK.Types.Message where + +import Control.Lens (Wrapped (..), from, iso, view, + ( # ), (&), (.~), (^.)) +import Data.Bifunctor (bimap) +import Data.ByteString (ByteString) +import qualified Data.ProtoLens as P +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Validation as V +import qualified Proto.Types.Transaction as T +import qualified Proto.Types.Transaction_Fields as T +import qualified Proto3.Wire.Decode as Wire +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Address (Address) + +-- | The basic message format embedded in any transaction. +data Msg msg = Msg + { msgAuthor :: Address + , msgData :: msg + , msgType :: Text + } + +instance Functor Msg where + fmap f msg@Msg{msgData} = msg {msgData = f msgData} + +class HasMessageType msg where + messageType :: Proxy msg -> Text + +data TypedMessage = TypedMessage + { typedMsgData :: ByteString + , typedMsgType :: Text + } + +instance Wrapped TypedMessage where + type Unwrapped TypedMessage = T.TypedMessage + + _Wrapped' = iso t f + where + t TypedMessage {..} = + P.defMessage + & T.data' .~ typedMsgData + & T.type' .~ typedMsgType + f message = TypedMessage + { typedMsgData = message ^. T.data' + , typedMsgType = message ^. T.type' + } + +instance HasCodec TypedMessage where + encode = P.encodeMessage . view _Wrapped' + decode = bimap cs (view $ from _Wrapped') . P.decodeMessage + +-- | This is a general error type, primarily accomodating protobuf messages being parsed +-- | by either the [proto3-wire](https://hackage.haskell.org/package/proto3-wire) +-- | or the [proto-lens](https://hackage.haskell.org/package/proto-lens) libraries. +data MessageParseError = + -- | A 'WireTypeError' occurs when the type of the data in the protobuf + -- binary format does not match the type encountered by the parser. + WireTypeError Text + -- | A 'BinaryError' occurs when we can't successfully parse the contents of + -- the field. + | BinaryError Text + -- | An 'EmbeddedError' occurs when we encounter an error while parsing an + -- embedded message. + | EmbeddedError Text (Maybe MessageParseError) + -- | Unknown or unstructured parsing error. + | OtherParseError Text + +-- | Useful for returning in error logs or console logging. +formatMessageParseError + :: MessageParseError + -> Text +formatMessageParseError = cs . go + where + go err = + let (context,msg) = case err of + WireTypeError txt -> ("Wire Type Error", txt) + BinaryError txt -> ("Binary Error", txt) + EmbeddedError txt err' -> ("Embedded Error", txt <> ". " <> maybe "" go err') + OtherParseError txt -> ("Other Error", txt) + in "Parse Error [" <> context <> "]: " <> msg + +-- Used to facilitate writing 'HasCodec' instances for protobuf messages that use +-- the proto3-suite library. +coerceProto3Error + :: Wire.ParseError + -> MessageParseError +coerceProto3Error = \case + Wire.WireTypeError txt -> WireTypeError (cs txt) + Wire.BinaryError txt -> BinaryError (cs txt) + Wire.EmbeddedError txt merr -> EmbeddedError (cs txt) (coerceProto3Error <$> merr) + +-- Used to facilitate writing 'HasCodec' instances for protobuf messages that use +-- the proto-lens library. +coerceProtoLensError + :: String + -> MessageParseError +coerceProtoLensError = OtherParseError . cs + +-- | Used during message validation to indicate that although the message has parsed +-- | correctly, it fails certain sanity checks. +data MessageSemanticError = + -- | Used to indicate that the message signer does not have the authority to send + -- | this message. + PermissionError Text + -- | Used to indicate that a field isn't valid, e.g. enforces non-negative quantities + -- | or nonempty lists. + | InvalidFieldError Text + -- Catchall for other erors + | OtherSemanticError Text + +formatMessageSemanticError + :: MessageSemanticError + -> Text +formatMessageSemanticError err = + let (context, msg) = case err of + PermissionError m -> ("Permission Error", m) + InvalidFieldError m -> ("Invalid Field Error", m) + OtherSemanticError m -> ("Other Error", m) + in "Semantic Error [" <> context <> "]:" <> msg + +class ValidateMessage msg where + validateMessage :: Msg msg -> V.Validation [MessageSemanticError] () + +nonEmptyCheck + :: Eq a + => Monoid a + => Text + -> a + -> V.Validation [MessageSemanticError] () +nonEmptyCheck fieldName x + | x == mempty = V._Failure # [InvalidFieldError $ fieldName <> " must be nonempty."] + | otherwise = V.Success () + +isAuthorCheck + :: Text + -> Msg msg + -> (msg -> Address) + -> V.Validation [MessageSemanticError] () +isAuthorCheck fieldName Msg{msgAuthor, msgData} getAuthor + | getAuthor msgData /= msgAuthor = V._Failure # [PermissionError $ fieldName <> " must be message author."] + | otherwise = V.Success () diff --git a/hs-abci-sdk/src/Tendermint/SDK/Types/Transaction.hs b/hs-abci-sdk/src/Tendermint/SDK/Types/Transaction.hs new file mode 100644 index 00000000..4c255815 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Types/Transaction.hs @@ -0,0 +1,123 @@ +module Tendermint.SDK.Types.Transaction where + +import Control.Error (note) +import Control.Lens (Wrapped (..), from, iso, view, + (&), (.~), (^.), _Unwrapped') +import Crypto.Hash (Digest, hashWith) +import Crypto.Hash.Algorithms (SHA256 (..)) +import Data.Bifunctor (bimap) +import Data.ByteString (ByteString) +import Data.Int (Int64) +import qualified Data.ProtoLens as P +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word64) +import GHC.Generics (Generic) +import qualified Proto.Types.Transaction as T +import qualified Proto.Types.Transaction_Fields as T +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Crypto (MakeDigest (..), + RecoverableSignatureSchema (..), + SignatureSchema (..)) +import Tendermint.SDK.Types.Message (Msg (..), TypedMessage (..)) + +-- Our standard transaction type parameterized by the signature schema 'alg' +-- and an underlying message type 'msg'. +data Tx alg msg = Tx + { txMsg :: Msg msg + , txRoute :: Text + , txGas :: Int64 + , txSignature :: RecoverableSignature alg + , txSignBytes :: Message alg + , txSigner :: PubKey alg + , txNonce :: Word64 + } + +instance Functor (Tx alg) where + fmap f tx@Tx{txMsg} = tx {txMsg = fmap f txMsg} + +-------------------------------------------------------------------------------- + +-- TODO: figure out what the actual standards are for these things, if there +-- even are any. + +-- | Raw transaction type coming in over the wire +data RawTransaction = RawTransaction + { rawTransactionData :: TypedMessage + -- ^ the encoded message via protobuf encoding + , rawTransactionGas :: Int64 + , rawTransactionRoute :: Text + -- ^ module name + , rawTransactionSignature :: ByteString + , rawTransactionNonce :: Word64 + } deriving Generic + +instance Wrapped RawTransaction where + type Unwrapped RawTransaction = T.RawTransaction + + _Wrapped' = iso t f + where + t RawTransaction {..} = + P.defMessage + & T.data' .~ (rawTransactionData ^. _Wrapped') + & T.gas .~ rawTransactionGas + & T.route .~ rawTransactionRoute + & T.signature .~ rawTransactionSignature + & T.nonce .~ rawTransactionNonce + f message = RawTransaction + { rawTransactionData = message ^. T.data' . _Unwrapped' + , rawTransactionGas = message ^. T.gas + , rawTransactionRoute = message ^. T.route + , rawTransactionSignature = message ^. T.signature + , rawTransactionNonce = message ^. T.nonce + } + +instance HasCodec RawTransaction where + encode = P.encodeMessage . view _Wrapped' + decode = bimap cs (view $ from _Wrapped') . P.decodeMessage + +instance MakeDigest RawTransaction where + makeDigest tx = hashWith SHA256 . encode $ tx {rawTransactionSignature = ""} + +signRawTransaction + :: forall alg. + RecoverableSignatureSchema alg + => Message alg ~ Digest SHA256 + => Proxy alg + -> PrivateKey alg -- + -> RawTransaction + -> RecoverableSignature alg +signRawTransaction p priv tx = signRecoverableMessage p priv (makeDigest tx) + +-- | Attempt to parse a Bytestring into a 'RawTransaction' then as a 'Tx' without +-- | attempting to parse the underlying message. This is done as a preprocessing +-- | step to the router, allowing for failure before the router is ever +-- | reached. +parseTx + :: forall alg. + RecoverableSignatureSchema alg + => Message alg ~ Digest SHA256 + => Proxy alg + -> ByteString + -> Either Text (Tx alg ByteString) +parseTx p bs = do + rawTx@RawTransaction{..} <- decode bs + recSig <- note "Unable to parse transaction signature as a recovery signature." $ + makeRecoverableSignature p rawTransactionSignature + let txForSigning = rawTx {rawTransactionSignature = ""} + signBytes = makeDigest txForSigning + signerPubKey <- note "Signature recovery failed." $ recover p recSig signBytes + return $ Tx + { txMsg = Msg + { msgData = typedMsgData rawTransactionData + , msgAuthor = addressFromPubKey p signerPubKey + , msgType = typedMsgType rawTransactionData + } + , txRoute = cs rawTransactionRoute + , txGas = rawTransactionGas + , txSignature = recSig + , txSignBytes = signBytes + , txSigner = signerPubKey + , txNonce = rawTransactionNonce + } diff --git a/hs-abci-sdk/src/Tendermint/SDK/Types/TxResult.hs b/hs-abci-sdk/src/Tendermint/SDK/Types/TxResult.hs new file mode 100644 index 00000000..42a4de4f --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/Types/TxResult.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TemplateHaskell #-} +module Tendermint.SDK.Types.TxResult where + +import Control.Lens (Iso', iso) +import Control.Lens.TH (makeLenses) +import Data.ByteArray.Base64String (Base64String) +import Data.Default.Class (Default (..)) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Word (Word32) +import Network.ABCI.Types.Messages.FieldTypes (Event, WrappedVal (..)) +import qualified Network.ABCI.Types.Messages.Response as Response + +-- | This type represents a common transaction result for the CheckTx +-- | and DeliverTx abci-messages. +data TxResult = TxResult + { _txResultData :: Base64String + , _txResultInfo :: Text + , _txResultGasWanted :: Int64 + , _txResultGasUsed :: Int64 + , _txResultEvents :: [Event] + , _txResultCode :: Word32 + , _txResultLog :: Text + , _txResultCodespace :: Text + } deriving Show + +makeLenses ''TxResult + +instance Default TxResult where + def = TxResult + { _txResultData = "" + , _txResultInfo = "" + , _txResultGasWanted = 0 + , _txResultGasUsed = 0 + , _txResultEvents = [] + , _txResultCode = 0 + , _txResultLog = "" + , _txResultCodespace = "" + } + +-- | This class is used to set the 'TxResult' data into the appropriate +-- | response fields for the CheckTx abci-message. +checkTxTxResult :: Iso' Response.CheckTx TxResult +checkTxTxResult = iso g s + where + g Response.CheckTx{..} = TxResult + { _txResultData = checkTxData + , _txResultInfo = checkTxInfo + , _txResultGasWanted = unWrappedVal checkTxGasWanted + , _txResultGasUsed = unWrappedVal checkTxGasUsed + , _txResultEvents = checkTxEvents + , _txResultCode = checkTxCode + , _txResultLog = checkTxLog + , _txResultCodespace = checkTxCodespace + } + s TxResult{..} = Response.CheckTx + { Response.checkTxData = _txResultData + , Response.checkTxInfo = _txResultInfo + , Response.checkTxGasWanted = WrappedVal _txResultGasWanted + , Response.checkTxGasUsed = WrappedVal _txResultGasUsed + , Response.checkTxEvents = _txResultEvents + , Response.checkTxCode = _txResultCode + , Response.checkTxCodespace = _txResultCodespace + , Response.checkTxLog = _txResultLog + } + +-- | This class is used to set the 'TxResult' data into the appropriate +-- | response fields for the DeliverTx abci-message. +deliverTxTxResult :: Iso' Response.DeliverTx TxResult +deliverTxTxResult = iso g s + where + g Response.DeliverTx{..} = TxResult + { _txResultData = deliverTxData + , _txResultInfo = deliverTxInfo + , _txResultGasWanted = unWrappedVal deliverTxGasWanted + , _txResultGasUsed = unWrappedVal deliverTxGasUsed + , _txResultEvents = deliverTxEvents + , _txResultCode = deliverTxCode + , _txResultLog = deliverTxLog + , _txResultCodespace = deliverTxCodespace + } + s TxResult{..} = Response.DeliverTx + { Response.deliverTxData = _txResultData + , Response.deliverTxInfo = _txResultInfo + , Response.deliverTxGasWanted = WrappedVal _txResultGasWanted + , Response.deliverTxGasUsed = WrappedVal _txResultGasUsed + , Response.deliverTxEvents = _txResultEvents + , Response.deliverTxCode = _txResultCode + , Response.deliverTxCodespace = _txResultCodespace + , Response.deliverTxLog = _txResultLog + } diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/ArraySpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/ArraySpec.hs new file mode 100644 index 00000000..5ed5d714 --- /dev/null +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/ArraySpec.hs @@ -0,0 +1,128 @@ +module Tendermint.SDK.Test.ArraySpec (spec) where + +import Control.Lens (iso) +import Data.ByteString (ByteString) +import Data.IORef (IORef, newIORef) +import Data.Maybe (fromJust, isJust) +import Data.String.Conversions (cs) +import Data.Word (Word64) +import Polysemy (Embed, Sem, runM) +import Polysemy.Error (Error, runError) +import qualified Tendermint.SDK.BaseApp as BA +import Tendermint.SDK.BaseApp.Store (Version (..)) +import qualified Tendermint.SDK.BaseApp.Store.Array as A +import Tendermint.SDK.BaseApp.Store.MemoryStore as Mem +import Tendermint.SDK.Codec (HasCodec (..)) +import Test.Hspec + +spec :: Spec +spec = + beforeAll makeConfig $ + describe "Array Spec" $ do + + it "Can create an empty array" $ \config -> do + res <- runToIO config $ A.toList valArray + res `shouldBe` [] + + it "Can add an element to the array" $ \config -> do + res <- runToIO config $ do + let n = 1 + A.append n valArray + mi <- A.elemIndex n valArray + l <- A.toList valArray + pure (mi, l) + res `shouldBe` (Just 0, [1]) + runToIO config $ A.deleteWhen (const True) valArray + + it "Can add an element, modify it, then delete it" $ \config -> do + let n = 2 + m = 3 + + -- save the element and get its index + i <- runToIO config $ do + A.append n valArray + A.elemIndex n valArray + i `shouldSatisfy` isJust + + -- accessing at the index gets the value back again + n' <- runToIO config (valArray A.!! fromJust i) + Just n `shouldBe` n' + + -- modifying the element at the index is successful + mm <- runToIO config $ A.modifyAtIndex (fromJust i) (const m) valArray + mm `shouldBe` Just m + + -- deleting the element and trying to find it gives Nothing + res2 <- runToIO config $ do + A.deleteWhen (== m) valArray + A.elemIndex n valArray + res2 `shouldBe` Nothing + + -- modifying a deleted element gives Nothing + let k = 4 + mm' <- runToIO config $ A.modifyAtIndex (fromJust i) (const k) valArray + mm' `shouldBe` Nothing + + + + + +-------------------------------------------------------------------------------- +-- Store types +-------------------------------------------------------------------------------- + +data Namespace + +store :: BA.Store Namespace +store = BA.makeStore $ BA.KeyRoot "namespace" + +data ValArrayKey = ValArrayKey + +instance BA.RawKey ValArrayKey where + rawKey = iso (\_ -> cs valArrayKey) (const ValArrayKey) + where + valArrayKey :: ByteString + valArrayKey = cs $ ("valArray" :: String) + +instance BA.IsKey ValArrayKey Namespace where + type Value ValArrayKey Namespace = A.Array Val + +newtype Val = Val Word64 deriving (Eq, Show, Num, HasCodec) + +valArray :: A.Array Val +valArray = A.makeArray ValArrayKey store + +-------------------------------------------------------------------------------- +-- Interpreter +-------------------------------------------------------------------------------- + +type Effs = + [ BA.ReadStore + , BA.WriteStore + , Error BA.AppError + , Embed IO + ] + +data Config = Config + { configDB :: Mem.DB + , configVersion :: IORef Version + } + +makeConfig :: IO Config +makeConfig = do + db <- Mem.initDB + v <- newIORef Latest + pure $ Config db v + +runToIO + :: Config + -> forall a. + Sem Effs a + -> IO a +runToIO Config{configDB, configVersion} m = do + eRes <- + runM . + runError . + evalWrite configDB . + evalRead configDB configVersion $ m + either (error . show) pure eRes diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/AuthTreeStoreSpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/AuthTreeStoreSpec.hs deleted file mode 100644 index a023cb87..00000000 --- a/hs-abci-sdk/test/Tendermint/SDK/Test/AuthTreeStoreSpec.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Tendermint.SDK.Test.AuthTreeStoreSpec where - -import Control.Lens (iso) -import qualified Data.Binary as Binary -import Data.ByteString (ByteString) -import Data.String.Conversions (cs) -import Polysemy (runM) -import Tendermint.SDK.AuthTreeStore (AuthTreeDriver, - initAuthTreeDriver, - interpretAuthTreeStore) -import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Store (HasKey (..), Root, get, put) -import Test.Hspec - -spec :: Spec -spec = beforeAll beforeAction $ - describe "AuthTreeStore" $ do - it "can fail to query an empty AuthTreeStore" $ \driver -> do - mv <- runM . interpretAuthTreeStore driver $ get (undefined :: Root) IntStoreKey - mv `shouldBe` Nothing - it "can set a value and query the value" $ \driver -> do - mv <- runM . interpretAuthTreeStore driver $ do - put IntStoreKey (IntStore 1) - get (undefined :: Root) IntStoreKey - mv `shouldBe` Just (IntStore 1) - - -beforeAction :: IO AuthTreeDriver -beforeAction = initAuthTreeDriver - -newtype IntStore = IntStore Int deriving (Eq, Show) - -data IntStoreKey = IntStoreKey - -instance HasCodec IntStore where - encode (IntStore c) = cs . Binary.encode $ c - decode = Right . IntStore . Binary.decode . cs - -instance HasKey IntStore where - type Key IntStore = IntStoreKey - rawKey = iso (\_ -> cs intStoreKey) (const IntStoreKey) - where - intStoreKey :: ByteString - intStoreKey = "IntStore" diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/CryptoSpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/CryptoSpec.hs new file mode 100644 index 00000000..2d2cbaff --- /dev/null +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/CryptoSpec.hs @@ -0,0 +1,46 @@ +module Tendermint.SDK.Test.CryptoSpec (spec) where + +import Crypto.Secp256k1 (CompactRecSig (..), SecKey, + derivePubKey, + exportCompactRecSig, secKey) +import qualified Data.ByteArray.HexString as Hex +import Data.ByteString (ByteString, snoc) +import Data.ByteString.Short (fromShort) +import Data.Maybe (fromJust) +import Data.Proxy +import Data.String (fromString) +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Crypto (Secp256k1) +import Tendermint.SDK.Types.Message +import Tendermint.SDK.Types.Transaction +import Test.Hspec + +spec :: Spec +spec = describe "Crypto Tests" $ do + it "Can sign a transaction and recover the signature" $ do + let rawTxWithoutSig = RawTransaction + { rawTransactionData = TypedMessage "abcd" "foo_msg" + , rawTransactionSignature = "" + , rawTransactionRoute= "dog" + , rawTransactionGas = 10 + , rawTransactionNonce = 0 + } + signature = signRawTransaction algProxy privateKey rawTxWithoutSig + rawTxWithSig = rawTxWithoutSig {rawTransactionSignature = + encodeCompactSig $ exportCompactRecSig signature} + -- @NOTE: this is kinda dumb bc parseTx decodes a bs into a rawTx + eTx = parseTx algProxy . encode $ rawTxWithSig + Tx {..} = case eTx of + Left errMsg -> error $ show errMsg + Right a -> a + txSigner `shouldBe` derivePubKey privateKey + +privateKey :: SecKey +privateKey = fromJust . secKey . Hex.toBytes . fromString $ + "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" + +algProxy :: Proxy Secp256k1 +algProxy = Proxy + +encodeCompactSig :: CompactRecSig -> ByteString +encodeCompactSig (CompactRecSig r s v) = snoc (fromShort r <> fromShort s) v diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/GasSpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/GasSpec.hs new file mode 100644 index 00000000..91e7730e --- /dev/null +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/GasSpec.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tendermint.SDK.Test.GasSpec (spec) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Either (isRight) +import qualified Data.IORef as Ref +import Polysemy +import Polysemy.Error (Error, runError) +import Polysemy.State (State, runStateIORef) +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import qualified Tendermint.SDK.BaseApp.Gas as G +import Test.Hspec + +data Dog m a where + Bark :: Dog m () + +makeSem ''Dog + +evalDog :: Sem (Dog ': r) a -> Sem r a +evalDog = interpret $ \case + Bark -> pure () + +eval + :: Ref.IORef G.GasAmount + -> Sem [Dog, G.GasMeter, Error AppError, Embed IO] a + -> IO (Either AppError a) +eval meter = + runM . + runError . + runStateIORef meter . + G.eval . + raiseUnder @(State G.GasAmount) . + evalDog + +spec :: Spec +spec = describe "Gas Tests" $ do + it "Can perform a computation without running out of gas" $ do + meter <- Ref.newIORef 1 + eRes <- eval meter $ G.withGas 1 bark + eRes `shouldSatisfy` isRight + remainingGas <- Ref.readIORef meter + remainingGas `shouldBe` 0 + + it "Can perform a computation with surplus gas" $ do + meter <- Ref.newIORef 2 + eRes <- eval meter $ G.withGas 1 bark + eRes `shouldSatisfy` isRight + remainingGas <- Ref.readIORef meter + remainingGas `shouldBe` 1 + + it "Can perform a computation and run out of gas" $ do + meter <- Ref.newIORef 0 + var <- Ref.newIORef (1 :: Int) + eRes <- eval meter $ do + G.withGas 1 bark + -- this shouldn't execute + liftIO $ Ref.modifyIORef var (+ 1) + let AppError{..} = case eRes of + Left e -> e + Right _ -> error "Was supposed to run out of gas" + appErrorCode `shouldBe` 4 + remainingGas <- Ref.readIORef meter + remainingGas `shouldBe` 0 + varVal <- Ref.readIORef var + varVal `shouldBe` 1 + diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/IAVLStoreSpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/IAVLStoreSpec.hs new file mode 100644 index 00000000..646fc9a9 --- /dev/null +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/IAVLStoreSpec.hs @@ -0,0 +1,214 @@ +module Tendermint.SDK.Test.IAVLStoreSpec (spec) where + +import Control.Lens (iso) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.Proxy +import qualified Data.Serialize as Serialize +import Data.String.Conversions (cs) +import Network.GRPC.Client.Helpers (GrpcClient) +import Polysemy (Embed, Members, Sem, + runM) +import Polysemy.Error (Error, runError) +import Polysemy.Reader (Reader, runReader) +import Polysemy.Resource (Resource, + resourceToIO) +import Polysemy.Tagged (tag) +import Tendermint.SDK.BaseApp.Errors (AppError (..), SDKError (InternalError), + throwSDKError) +import Tendermint.SDK.BaseApp.Store (IsKey (..), + KeyRoot (..), + RawKey (..), + ReadStore, + Scope (..), Store, + StoreEffs, + WriteStore, + WriteStore, commit, + commitBlock, delete, + get, makeStore, put, + withSandbox, + withTransaction) +import Tendermint.SDK.BaseApp.Store.IAVLStore (GrpcConfig (..), + IAVLVersions, + evalStoreEffs, + initGrpcClient, + initIAVLVersions) +import qualified Tendermint.SDK.BaseApp.Store.MemoryStore as Memory +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Effects ((:&)) +import Test.Hspec + +spec :: Spec +spec = do + beforeAll iavlBeforeAction $ + describe "IAVL tests" $ spec' (Proxy @IAVLEffs) + + beforeAll pureBeforeAction $ + describe "Pure tests" $ spec' (Proxy @PureEffs) + +spec' :: Members [Error AppError, Embed IO, Resource] r => Members StoreEffs r => Proxy r -> SpecWith (Driver r) +spec' (Proxy :: Proxy r) = do + + it "can fail to query an empty AuthTreeStore" $ \(driver :: Driver r) -> do + Right mv <- runDriver driver $ tag @'QueryAndMempool $ + get store IntStoreKey + mv `shouldBe` Nothing + + it "can set a value and query the value" $ \(driver :: Driver r) -> do + Right mv <- runDriver driver $ do + tag @'Consensus @WriteStore $ (put store IntStoreKey (IntStore 1) :: Sem (WriteStore ': r) ()) + tag @'Consensus @ReadStore $ get store IntStoreKey + mv `shouldBe` Just (IntStore 1) + + it "can make changes and roll back" $ \(driver :: Driver r) -> do + Right mv'' <- runDriver driver $ do + void $ withTransaction $ + tag @'Consensus $ (put store IntStoreKey (IntStore 1) :: Sem (WriteStore ': r) ()) + withSandbox $ do + tag @'Consensus @WriteStore $ (put store IntStoreKey (IntStore 5) :: Sem (WriteStore ': r) ()) + mv <- tag @'Consensus @ReadStore $ get store IntStoreKey + liftIO (mv `shouldBe` Just (IntStore 5)) + + tag @'Consensus @WriteStore$ (delete store IntStoreKey :: Sem (WriteStore ': r) ()) + mv' <- tag @'Consensus @ReadStore $ get store IntStoreKey + + liftIO (mv' `shouldBe` Nothing) + tag @'Consensus @ReadStore $ get store IntStoreKey + mv'' `shouldBe` Just (IntStore 1) + + it "can roll back if an error occurs during a transaction" $ \driver -> do + Left apperr <- runDriver driver $ do + void $ withTransaction $ + tag @'Consensus $ (put store IntStoreKey (IntStore 1) :: Sem (WriteStore ': r) ()) + void $ withTransaction $ do + tag @'Consensus $ (put store IntStoreKey (IntStore 6) :: Sem (WriteStore ': r) ()) + throwSDKError $ InternalError "SomeError" + appErrorCode apperr `shouldBe` 1 + Right mv <- runDriver driver $ + tag @'Consensus @ReadStore $ get store IntStoreKey + mv `shouldBe` Just (IntStore 1) + + it "can make changes with a transaction" $ \driver -> do + Right (mv, _) <- runDriver driver . withTransaction $ do + tag @'Consensus $ (put store IntStoreKey (IntStore 5) :: Sem (WriteStore ': r) ()) + tag @'Consensus @ReadStore $ get store IntStoreKey + mv `shouldBe` Just (IntStore 5) + + it "can merge the scopes" $ \driver -> do + -- set all to be initially the same value + void $ runDriver driver $ + withTransaction $ + tag @'Consensus $ (put store IntStoreKey (IntStore 0) :: Sem (WriteStore ': r) ()) + + -- mergeScopes so that all are using the latest version + void $ runDriver driver $ commitBlock + + void $ runDriver driver $ do + res <- tag @'QueryAndMempool $ get store IntStoreKey + liftIO (res `shouldBe` Just 0) + void $ runDriver driver $ do + res <- tag @'Consensus @ReadStore $ get store IntStoreKey + liftIO (res `shouldBe` Just 0) + + + -- Make another change on Consensus that does not commit + void $ runDriver driver $ do + tag @'Consensus $ (put store IntStoreKey (IntStore 1) :: Sem (WriteStore ': r) ()) + + void $ runDriver driver $ do + res <- tag @'QueryAndMempool @ReadStore $ get store IntStoreKey + liftIO (res `shouldBe` Just 0) + + void $ runDriver driver $ do + res <- tag @'Consensus @ReadStore $ get store IntStoreKey + liftIO (res `shouldBe` Just 1) + + -- commit the changes + void $ runDriver driver $ commit + + -- mergeScopes so that all are using the latest version + void $ runDriver driver $ commitBlock + + void $ runDriver driver $ do + res <- tag @'QueryAndMempool @ReadStore $ get store IntStoreKey + liftIO (res `shouldBe` Just 1) + + void $ runDriver driver $ do + res <- tag @'Consensus @ReadStore $ get store IntStoreKey + liftIO (res `shouldBe` Just 1) + + +iavlBeforeAction :: IO (Driver IAVLEffs) +iavlBeforeAction = do + vs <- initIAVLVersions + gc <- initGrpcClient $ GrpcConfig "0.0.0.0" 8090 + pure $ runIAVL (vs, gc) + +pureBeforeAction :: IO (Driver PureEffs) +pureBeforeAction = do + vs <- Memory.initDBVersions + db <- Memory.initDB + pure $ runPure (vs, db) + +newtype IntStore = IntStore Int deriving (Eq, Show, Num, Serialize.Serialize) + +data IntStoreKey = IntStoreKey + +instance HasCodec IntStore where + encode = Serialize.encode + decode = first cs . Serialize.decode + +instance RawKey IntStoreKey where + rawKey = iso (\_ -> cs intStoreKey) (const IntStoreKey) + where + intStoreKey :: ByteString + intStoreKey = "IntStore" + +instance IsKey IntStoreKey "int_store" where + type Value IntStoreKey "int_store" = IntStore + +store :: Store "int_store" +store = makeStore $ KeyRoot "int_store" + +type IAVLEffs = + StoreEffs :& [Reader IAVLVersions, Reader GrpcClient, Error AppError, Resource, Embed IO] + +runIAVL + :: (IAVLVersions, GrpcClient) + -> Driver IAVLEffs +runIAVL (versions, gc) = Driver $ \action -> + runM . + resourceToIO . + runError . + runReader gc . + runReader versions $ + evalStoreEffs action + + +type PureEffs = + StoreEffs :& [Reader Memory.DBVersions, Reader Memory.DB, Error AppError, Resource, Embed IO] + +runPure + :: (Memory.DBVersions, Memory.DB) + -> Driver PureEffs +runPure (versions, db) = Driver $ \action -> + runM . + resourceToIO . + runError . + runReader db . + runReader versions $ + Memory.evalStoreEffs action + + +newtype Driver core = Driver + (forall a. Sem core a -> IO (Either AppError a)) + +runDriver + :: forall core. + Driver core + -> forall a. + Sem core a + -> IO (Either AppError a) +runDriver (Driver f) a = f a diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/ListSpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/ListSpec.hs new file mode 100644 index 00000000..b3fca2dc --- /dev/null +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/ListSpec.hs @@ -0,0 +1,187 @@ +module Tendermint.SDK.Test.ListSpec (spec) where + +import Control.Lens (iso) +import Data.ByteString (ByteString) +import Data.IORef (IORef, newIORef) +import Data.String.Conversions (cs) +import Data.Word (Word64) +import Polysemy (Embed, Sem, runM) +import Polysemy.Error (Error, runError) +import qualified Tendermint.SDK.BaseApp as BA +import Tendermint.SDK.BaseApp.Store (Version (..)) +import qualified Tendermint.SDK.BaseApp.Store.List as L +import Tendermint.SDK.BaseApp.Store.MemoryStore as Mem +import Tendermint.SDK.Codec (HasCodec (..)) +import Test.Hspec + +spec :: Spec +spec = + + beforeAll makeConfig $ + describe "List Spec" $ do + + it "Can create an empty list" $ \config -> do + res <- runToIO config $ L.toList valList + res `shouldBe` [] + + it "Can make a singleton list then delete it" $ \config -> do + lInit <- runToIO config $ L.toList valList + lInit `shouldBe` [] + let n = 1 + res <- runToIO config $ do + L.append n valList + mi <- L.elemIndex n valList + me <- maybe (pure Nothing) (valList L.!! ) mi + l <- L.toList valList + len <- L.length valList + pure (mi, me , l, len) + res `shouldBe` (Just 0, Just n, [n], 1) + res' <- runToIO config $ do + L.delete n valList + i <- L.elemIndex n valList + len <- L.length valList + l <- L.toList valList + pure (i, len, l) + res' `shouldBe` (Nothing, 0, []) + runToIO config $ L.deleteWhen (const True) valList + + it "Can add two elements and delete the head" $ \config -> do + lInit <- runToIO config $ L.toList valList + lInit `shouldBe` [] + let n = 1 + m = 2 + res <- runToIO config $ do + L.append n valList + L.append m valList + mi <- L.elemIndex m valList + me <- maybe (pure Nothing) (valList L.!!) mi + l <- L.toList valList + len <- L.length valList + pure (mi, me, l, len) + res `shouldBe` (Just 0, Just m, [m,n], 2) + res' <- runToIO config $ do + L.delete m valList + i <- L.elemIndex m valList + len <- L.length valList + l <- L.toList valList + pure (i, len, l) + res' `shouldBe` (Nothing, 1, [n]) + runToIO config $ L.deleteWhen (const True) valList + + it "Can add add three elements and delete the second" $ \config -> do + lInit <- runToIO config $ L.toList valList + lInit `shouldBe` [] + let n = 1 + m = 2 + k = 3 + res <- runToIO config $ do + L.append n valList + L.append m valList + L.append k valList + mi <- L.elemIndex m valList + me <- maybe (pure Nothing) (valList L.!!) mi + l <- L.toList valList + len <- L.length valList + pure (mi, me, l, len) + res `shouldBe` (Just 1, Just m, [k,m,n], 3) + res' <- runToIO config $ do + L.delete m valList + i <- L.elemIndex m valList + len <- L.length valList + l <- L.toList valList + pure (i, len, l) + res' `shouldBe` (Nothing, 2, [k,n]) + runToIO config $ L.deleteWhen (const True) valList + + it "Can add add three elements and delete the third" $ \config -> do + lInit <- runToIO config $ L.toList valList + lInit `shouldBe` [] + let n = 1 + m = 2 + k = 3 + res <- runToIO config $ do + L.append n valList + L.append m valList + L.append k valList + mi <- L.elemIndex n valList + me <- maybe (pure Nothing) (valList L.!!) mi + l <- L.toList valList + len <- L.length valList + pure (mi, me, l, len) + res `shouldBe` (Just 2, Just n, [k,m,n], 3) + res' <- runToIO config $ do + L.delete n valList + i <- L.elemIndex n valList + len <- L.length valList + l <- L.toList valList + pure (i, len, l) + res' `shouldBe` (Nothing, 2, [k,m]) + runToIO config $ L.deleteWhen (const True) valList + + + + + + + + + +-------------------------------------------------------------------------------- +-- Store types +-------------------------------------------------------------------------------- + +data Namespace + +store :: BA.Store Namespace +store = BA.makeStore $ BA.KeyRoot "namespace" + +data ValListKey = ValListKey + +instance BA.RawKey ValListKey where + rawKey = iso (\_ -> cs valListKey) (const ValListKey) + where + valListKey :: ByteString + valListKey = cs $ ("valArray" :: String) + +instance BA.IsKey ValListKey Namespace where + type Value ValListKey Namespace = L.List Val + +newtype Val = Val Word64 deriving (Eq, Show, Num, HasCodec) + +valList :: L.List Val +valList = L.makeList ValListKey store + +-------------------------------------------------------------------------------- +-- Interpreter +-------------------------------------------------------------------------------- + +type Effs = + [ BA.ReadStore + , BA.WriteStore + , Error BA.AppError + , Embed IO + ] + +data Config = Config + { configDB :: Mem.DB + , configVersion :: IORef Version + } + +makeConfig :: IO Config +makeConfig = do + db <- Mem.initDB + v <- newIORef Latest + pure $ Config db v + +runToIO + :: Config + -> forall a. + Sem Effs a + -> IO a +runToIO Config{configDB, configVersion} m = do + eRes <- + runM . + runError . + evalWrite configDB . + evalRead configDB configVersion $ m + either (error . show) pure eRes diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/MapSpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/MapSpec.hs new file mode 100644 index 00000000..1c08b316 --- /dev/null +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/MapSpec.hs @@ -0,0 +1,107 @@ +module Tendermint.SDK.Test.MapSpec (spec) where + +import Control.Lens (iso) +import Data.ByteString (ByteString) +import Data.IORef (IORef, newIORef) +import Data.String.Conversions (cs) +import Data.Word (Word64) +import Polysemy (Embed, Sem, runM) +import Polysemy.Error (Error, runError) +import qualified Tendermint.SDK.BaseApp as BA +import Tendermint.SDK.BaseApp.Store (Version (..)) +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import Tendermint.SDK.BaseApp.Store.MemoryStore as Mem +import Tendermint.SDK.Codec (HasCodec (..)) +import Test.Hspec + +spec :: Spec +spec = + beforeAll makeConfig $ + describe "Map Spec" $ do + + it "Can insert and delete from map" $ \config -> do + res <- runToIO config $ do + M.insert 1 1 valMap + v <- M.lookup 1 valMap + M.delete 1 valMap + v' <- M.lookup 1 valMap + pure (v,v') + res `shouldBe` (Just 1, Nothing) + + it "Can insert and update map" $ \config -> do + res <- runToIO config $ do + M.insert 1 1 valMap + M.update (const $ Just 2) 1 valMap + v <- M.lookup 1 valMap + M.update (const $ Nothing) 1 valMap + v' <- M.lookup 1 valMap + pure (v,v') + res `shouldBe` (Just 2, Nothing) + + +-------------------------------------------------------------------------------- +-- Store types +-------------------------------------------------------------------------------- + +data Namespace + +store :: BA.Store Namespace +store = BA.makeStore $ BA.KeyRoot "namespace" + +newtype Key = Key Word64 deriving (Eq, Show, Num) + +instance BA.RawKey Key where + rawKey = iso (\(Key k) -> encode k) + (either (const $ error "KeyError") Key . decode) + +newtype Val = Val Word64 deriving (Eq, Show, Num, HasCodec) + +data ValMapKey = ValMapKey + +instance BA.RawKey ValMapKey where + rawKey = iso (\_ -> cs valMapKey) (const ValMapKey) + where + valMapKey :: ByteString + valMapKey = cs $ ("valArray" :: String) + +instance BA.IsKey ValMapKey Namespace where + type Value ValMapKey Namespace = M.Map Key Val + + +valMap :: M.Map Key Val +valMap = M.makeMap ValMapKey store + +-------------------------------------------------------------------------------- +-- Interpreter +-------------------------------------------------------------------------------- + +type Effs = + [ BA.ReadStore + , BA.WriteStore + , Error BA.AppError + , Embed IO + ] + +data Config = Config + { configDB :: Mem.DB + , configVersion :: IORef Version + } + +makeConfig :: IO Config +makeConfig = do + db <- Mem.initDB + v <- newIORef Latest + pure $ Config db v + +runToIO + :: Config + -> forall a. + Sem Effs a + -> IO a +runToIO Config{configDB, configVersion} m = do + eRes <- + runM . + runError . + evalWrite configDB . + evalRead configDB configVersion $ m + either (error . show) pure eRes diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/MetricsSpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/MetricsSpec.hs new file mode 100644 index 00000000..26ab0e3c --- /dev/null +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/MetricsSpec.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Tendermint.SDK.Test.MetricsSpec (spec) where + +import Control.Concurrent.MVar (readMVar) +import Data.Map.Strict ((!)) +import qualified Data.Map.Strict as Map +import Polysemy +import qualified System.Metrics.Prometheus.Concurrent.Registry as Registry +import qualified System.Metrics.Prometheus.Metric as Metric +import qualified System.Metrics.Prometheus.Metric.Counter as Counter +import qualified System.Metrics.Prometheus.Metric.Histogram as Histogram +import qualified System.Metrics.Prometheus.Registry as RSample +import Tendermint.SDK.BaseApp.Metrics +import Tendermint.SDK.BaseApp.Metrics.Prometheus +import Test.Hspec + +data Fox m a where + Shine :: Fox m () + +makeSem ''Fox + +evalFox :: Sem (Fox ': r) a -> Sem r a +evalFox = interpret $ \case + Shine -> pure () + +eval + :: MetricsState + -> Sem [Fox, Metrics, Embed IO] a + -> IO a +eval s = runM . evalMetrics s . evalFox + +spec :: Spec +spec = describe "Metrics tests" $ do + let countName = "testCount" + c = countToIdentifier countName + cid = metricIdStorable c + cMetricId = mkPrometheusMetricId c + it "Can make a new count and increment it" $ do + state@MetricsState{..} <- emptyState + -- Creates new count and sets it to 1 + _ <- eval state $ incCount countName + newCtrIndex <- readMVar _metricsCounters + newCtrValue <- Counter.sample $ newCtrIndex ! cid + Counter.unCounterSample newCtrValue `shouldBe` 1 + -- register should contain new counter metric + newRegistrySample <- Registry.sample _metricsRegistry + let registryMap = RSample.unRegistrySample newRegistrySample + (Metric.CounterMetricSample registryCtrSample) = registryMap ! cMetricId + Counter.unCounterSample registryCtrSample `shouldBe` 1 + -- increment it again + _ <- eval state $ incCount countName + incCtrIndex <- readMVar _metricsCounters + incCtrValue <- Counter.sample $ incCtrIndex ! cid + Counter.unCounterSample incCtrValue `shouldBe` 2 + + let buckettedHistName = "bucketted" + buckettedH = histogramToIdentifier buckettedHistName + buckettedHMetricId = mkPrometheusMetricId buckettedH + it "Can measure action response times with default buckets" $ do + state@MetricsState{..} <- emptyState + -- time an action + _ <- eval state $ withTimer buckettedHistName shine + -- check registry hist buckets + newRegistrySample <- Registry.sample _metricsRegistry + let registryMap = RSample.unRegistrySample newRegistrySample + (Metric.HistogramMetricSample registryHistSample) = registryMap ! buckettedHMetricId + histBuckets = Histogram.histBuckets registryHistSample + Map.elems histBuckets `shouldSatisfy` atLeastOneUpdated + where atLeastOneUpdated = foldr (\b acc -> acc || (b /= 0.0)) False diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/ModuleSpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/ModuleSpec.hs deleted file mode 100644 index 0abb2c1f..00000000 --- a/hs-abci-sdk/test/Tendermint/SDK/Test/ModuleSpec.hs +++ /dev/null @@ -1,109 +0,0 @@ -module Tendermint.SDK.Test.ModuleSpec where - --- import qualified Control.Concurrent.MVar as MVar --- import Control.Lens (to, (^.)) --- import Control.Monad (void) --- import Control.Monad.Trans --- import Data.ByteArray.Base64String (fromBytes, toBytes) --- import Data.Conduit --- import Data.Proxy --- import qualified Network.ABCI.Types.Messages.Request as Request --- import qualified Network.ABCI.Types.Messages.Response as Response --- import Servant.API ((:>)) --- import Tendermint.SDK.AuthTreeStore --- import Tendermint.SDK.Codec --- import Tendermint.SDK.Module --- import Tendermint.SDK.Router --- import Tendermint.SDK.Store --- import Tendermint.SDK.StoreQueries --- import Tendermint.SDK.Test.StoreExample -import Test.Hspec - -spec :: Spec -spec = - describe "UserModule" $ pure () - -- it "can create the user module and query it via Query msg and from component" $ do - -- TendermintIO {ioQuery, ioServer, ioSubscribe} <- runApp userComponent () - -- logsVar <- MVar.newMVar [] - -- charlesLogsVar <- MVar.newMVar [] - -- let irakli = Buyer { buyerId = "1" - -- , buyerName = "irakli" - -- } - -- irakliKey = BuyerKey "1" - -- charles = Buyer { buyerId = "2" - -- , buyerName = "charles" - -- } - -- logger = awaitForever $ \case - -- StoredBuyer buyer -> lift $ MVar.modifyMVar_ logsVar (pure . (:) buyer) - -- charlesLogger = awaitForever $ \case - -- StoredBuyer buyer -> - -- lift $ if buyerName buyer == "charles" - -- then MVar.modifyMVar_ charlesLogsVar (pure . (:) buyer) - -- else pure () - -- _ <- ioSubscribe logger - -- _ <- ioSubscribe charlesLogger - -- void $ ioQuery $ tell (PutBuyer irakli) - -- void $ ioQuery $ tell (PutBuyer charles) - -- mIrakli <- ioQuery $ request (GetBuyer irakliKey) - -- mIrakli `shouldBe` Just irakli - -- mNobody <- ioQuery $ request (GetBuyer (BuyerKey "3")) - -- mNobody `shouldBe` Nothing - -- logs <- MVar.readMVar logsVar - -- logs `shouldBe` [charles, irakli] - -- charlesLogs <- MVar.readMVar charlesLogsVar - -- charlesLogs `shouldBe` [charles] - - -- let serveRoutes :: Application IO - -- serveRoutes = serve (Proxy :: Proxy UserApi) (Proxy :: Proxy IO) ioServer - -- irakliKeyHex = irakliKey ^. rawKey . to fromBytes - -- irakliQuery = Request.Query irakliKeyHex "user/buyer" 0 False - -- qBuyerRes <- serveRoutes irakliQuery - -- let ebuyer = decode . toBytes . Response.queryValue $ qBuyerRes - -- ebuyer `shouldBe` Right irakli - --------------------------------------------------------------------------------- --- User Module --------------------------------------------------------------------------------- - --- data UserQ a = --- PutBuyer Buyer a --- | GetBuyer BuyerKey (Maybe Buyer -> a) - --- data UserMessage = --- StoredBuyer Buyer - --- evalQuery :: forall a action. UserQ a -> TendermintM UserStore action UserMessage IO a --- evalQuery (PutBuyer buyer a) = do --- withState $ \store -> --- putBuyer (BuyerKey $ buyerId buyer) buyer store --- raise $ StoredBuyer buyer --- pure a --- evalQuery (GetBuyer buyerKey f) = do --- buyer <- withState $ --- \store -> get (undefined :: Root) buyerKey store --- pure $ f buyer - --- type UserApi = "user" :> QueryApi UserStoreContents - --- userComponentSpec :: ComponentSpec UserStore UserQ action input UserMessage UserApi IO --- userComponentSpec = ComponentSpec --- { initialState = const $ do --- rawStore <- mkAuthTreeStore --- pure $ Store --- { storeRawStore = rawStore } --- , eval = evaluator --- , mkServer = userServer --- } --- where --- userServer :: UserStore -> RouteT UserApi IO --- userServer = allStoreHandlers - --- evaluator = mkEval $ EvalSpec --- { handleAction = const $ pure () --- , handleQuery = evalQuery --- , receive = const Nothing --- , initialize = Nothing --- } - --- userComponent :: forall (input :: *). Component UserQ input UserMessage UserApi IO --- userComponent = Component userComponentSpec diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/QuerySpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/QuerySpec.hs new file mode 100644 index 00000000..37d5c290 --- /dev/null +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/QuerySpec.hs @@ -0,0 +1,153 @@ +module Tendermint.SDK.Test.QuerySpec (spec) where + +import Control.Lens ((^.)) +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteArray.Base64String as Base64 +import qualified Data.ByteArray.HexString as Hex +import Data.ByteString (ByteString) +import Data.Maybe (isJust) +import Data.Proxy +import Data.Text (Text) +import qualified Network.ABCI.Types.Messages.Request as Req +import qualified Network.ABCI.Types.Messages.Response as Resp +import Polysemy (Sem) +import qualified Tendermint.SDK.Application as App +import qualified Tendermint.SDK.Application.Module as M +import qualified Tendermint.SDK.BaseApp as BA +import qualified Tendermint.SDK.BaseApp.Logger.Katip as KL +import Tendermint.SDK.BaseApp.Query (QueryApplication, + serveQueryApplication) +import qualified Tendermint.SDK.BaseApp.Store as Store +import Tendermint.SDK.BaseApp.Transaction (TransactionApplication, + serveTxApplication) +import Tendermint.SDK.BaseApp.Transaction.Cache (writeCache) +import Tendermint.SDK.Codec (HasCodec (..)) +import qualified Tendermint.SDK.Modules.Auth as A +import qualified Tendermint.SDK.Modules.Bank as B +import qualified Tendermint.SDK.Test.SimpleStorage as SS +import Tendermint.SDK.Types.Message (Msg (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) +import Test.Hspec + +type Ms = '[SS.SimpleStorage, B.Bank, A.Auth] + +modules :: App.ModuleList Ms (App.Effs Ms BA.PureCoreEffs) +modules = + SS.simpleStorageModule App.:+ + B.bankModule App.:+ + A.authModule App.:+ + App.NilModules + +cProxy :: Proxy BA.PureCoreEffs +cProxy = Proxy + +rProxy :: Proxy (BA.BaseAppEffs BA.PureCoreEffs) +rProxy = Proxy + +app :: M.Application (M.ApplicationC Ms) (M.ApplicationD Ms) (M.ApplicationQ Ms) + (BA.TxEffs BA.:& BA.BaseAppEffs BA.PureCoreEffs) (BA.QueryEffs BA.:& BA.BaseAppEffs BA.PureCoreEffs) +app = M.makeApplication cProxy mempty modules + +doQuery :: QueryApplication (Sem (BA.BaseAppEffs BA.PureCoreEffs)) +doQuery = serveQueryApplication (Proxy @(M.ApplicationQ Ms)) rProxy $ M.applicationQuerier app + +doTx :: TransactionApplication (Sem (BA.BaseAppEffs BA.PureCoreEffs)) +doTx = serveTxApplication (Proxy @(M.ApplicationD Ms)) rProxy (Proxy @'Store.Consensus) $ M.applicationTxDeliverer app + +spec :: Spec +spec = beforeAll initContext $ do + describe "Query tests" $ do + it "Can make a new count and query it with a multiplier" $ \ctx -> do + let increaseCountMsg = Msg + { msgAuthor = undefined + , msgType = "update_count" + , msgData = encode $ SS.UpdateCountTx 1 + } + tx = BA.RoutingTx $ Tx + { txMsg = increaseCountMsg + , txRoute = "simple_storage" + , txGas = 0 + , txSignature = undefined + , txSignBytes = undefined + , txSigner = undefined + , txNonce = undefined + } + _ <- SS.evalToIO ctx $ do + (_, mCache) <- doTx tx + liftIO (mCache `shouldSatisfy` isJust) + let (Just cache) = mCache + writeCache cache + _ <- Store.commit + Store.commitBlock + let q = Req.Query + -- TODO -- this shouldn't require / count + { queryPath = "/simple_storage/manipulated/1?factor=4" + , queryData = undefined + , queryProve = False + , queryHeight = 0 + } + Resp.Query{..} <- SS.evalToIO ctx $ doQuery q + queryCode `shouldBe` 0 + let resultCount = decode (Base64.toBytes queryValue) :: Either Text SS.Count + resultCount `shouldBe` Right 3 + + describe "throw/catch tests" $ do + it "Can throw and catch a bank error" $ \ctx -> do + let addr = A.Address . Hex.fromBytes $ ("1234" :: ByteString) + + queryBalance = do + let path = "/bank/balance?coin_id=" <> B.unCoinId SS.simpleStorageCoinId + q1 = Req.Query + { queryPath = path + , queryData = Base64.fromBytes (addr ^. BA.rawKey) + , queryProve = False + , queryHeight = 0 + } + Resp.Query{..} <- SS.evalToIO ctx $ doQuery q1 + queryCode `shouldBe` 0 + let Right resultBalance = decode (Base64.toBytes queryValue) :: Either Text B.Coin + pure resultBalance + + initialBalance <- queryBalance + + let increaseCountMsg = Msg + { msgAuthor = addr + , msgType = "update_paid_count" + , msgData = encode $ SS.UpdatePaidCountTx 33 10 + } + + tx = BA.RoutingTx $ Tx + { txMsg = increaseCountMsg + , txRoute = "simple_storage" + , txGas = 0 + , txSignature = undefined + , txSignBytes = undefined + , txSigner = undefined + , txNonce = undefined + } + _ <- SS.evalToIO ctx $ do + (_, mCache) <- doTx tx + liftIO (mCache `shouldSatisfy` isJust) + let (Just cache) = mCache + writeCache cache + _ <- Store.commit + Store.commitBlock + let q = Req.Query + -- TODO -- this shouldn't require / count + { queryPath = "/simple_storage/count" + , queryData = undefined + , queryProve = False + , queryHeight = 0 + } + Resp.Query{..} <- SS.evalToIO ctx $ doQuery q + queryCode `shouldBe` 0 + let resultCount = decode (Base64.toBytes queryValue) :: Either Text SS.Count + resultCount `shouldBe` Right 33 + + finalBalance <- queryBalance + finalBalance `shouldBe` initialBalance {B.coinAmount = B.coinAmount initialBalance + 1} + + +initContext :: IO BA.PureContext +initContext = do + BA.makePureContext (KL.InitialLogNamespace "test" "spec") diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/SimpleStorage.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/SimpleStorage.hs new file mode 100644 index 00000000..8fa74c65 --- /dev/null +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/SimpleStorage.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Tendermint.SDK.Test.SimpleStorage + ( SimpleStorage + , UpdateCountTx(..) + , UpdatePaidCountTx(..) + , simpleStorageModule + , simpleStorageCoinId + , evalToIO + , Count(..) + ) where + +import Control.Lens (iso, (^.)) +import Crypto.Hash (SHA256 (..), hashWith) +import Data.Bifunctor (first) +import Data.ByteArray (convert) +import qualified Data.ByteArray.Base64String as Base64 +import Data.ByteString (ByteString) +import Data.Int (Int32) +import Data.Proxy +import qualified Data.Serialize as Serialize +import Data.Serialize.Text () +import Data.String.Conversions (cs) +import Data.Validation (Validation (..)) +import Data.Word (Word64) +import GHC.Generics (Generic) +import GHC.TypeLits (symbolVal) +import Polysemy +import Polysemy.Error (Error, catch, throw) +import Servant.API +import Tendermint.SDK.Application (Module (..), ModuleEffs) +import qualified Tendermint.SDK.BaseApp as BA +import qualified Tendermint.SDK.BaseApp.Store.Array as A +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import qualified Tendermint.SDK.BaseApp.Store.Var as V +import Tendermint.SDK.Codec (HasCodec (..)) +import qualified Tendermint.SDK.Modules.Bank as B +import Tendermint.SDK.Types.Address (Address) +import Tendermint.SDK.Types.Message (HasMessageType (..), + Msg (..), + ValidateMessage (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) + + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- +type SimpleStorageName = "simple_storage" + +simpleStorageCoinId :: B.CoinId +simpleStorageCoinId = B.CoinId . cs . symbolVal $ Proxy @SimpleStorageName + +newtype Count = Count Int32 deriving (Eq, Show, Ord, Num, Serialize.Serialize) + +instance HasCodec Count where + encode = Serialize.encode + decode = first cs . Serialize.decode + +-- Count + +newtype AmountPaid = AmountPaid B.Amount deriving (Eq, Show, Num, Ord, HasCodec) + +-------------------------------------------------------------------------------- +-- Message Types +-------------------------------------------------------------------------------- + +data UpdateCountTx = UpdateCountTx + { updateCountTxCount :: Int32 + } deriving (Show, Eq, Generic) + +instance Serialize.Serialize UpdateCountTx + +instance HasMessageType UpdateCountTx where + messageType _ = "update_count" + +instance HasCodec UpdateCountTx where + encode = Serialize.encode + decode = first cs . Serialize.decode + +instance ValidateMessage UpdateCountTx where + validateMessage _ = Success () + +data UpdatePaidCountTx = UpdatePaidCountTx + { updatePaidCountTxCount :: Int32 + , updatePaidCountTxAmount :: Word64 + } deriving (Show, Eq, Generic) + +instance Serialize.Serialize UpdatePaidCountTx + +instance HasMessageType UpdatePaidCountTx where + messageType _ = "update_paid_count" + +instance HasCodec UpdatePaidCountTx where + encode = Serialize.encode + decode = first cs . Serialize.decode + +instance ValidateMessage UpdatePaidCountTx where + validateMessage _ = Success () + +-------------------------------------------------------------------------------- +-- Keeper +-------------------------------------------------------------------------------- + + +data SimpleStorageKeeper m a where + UpdateCount :: Count -> SimpleStorageKeeper m () + UpdatePaidCount :: Address -> Count -> B.Amount -> SimpleStorageKeeper m () + GetCount :: SimpleStorageKeeper m (Maybe Count) + GetAllCounts :: SimpleStorageKeeper m [Count] + +makeSem ''SimpleStorageKeeper + +-------------------------------------------------------------------------------- + +data SimpleStorageNamespace + +store :: BA.Store SimpleStorageNamespace +store = BA.makeStore $ BA.KeyRoot (cs . symbolVal $ Proxy @SimpleStorageName) + +data CountKey = CountKey + +instance BA.RawKey CountKey where + rawKey = iso (\_ -> cs countKey) (const CountKey) + where + countKey :: ByteString + countKey = convert . hashWith SHA256 . cs @_ @ByteString $ ("count" :: String) + +instance BA.IsKey CountKey SimpleStorageNamespace where + type Value CountKey SimpleStorageNamespace = V.Var Count + +countVar :: V.Var Count +countVar = V.makeVar CountKey store + +instance BA.QueryData CountKey + +data PaidKey = PaidKey + +instance BA.RawKey PaidKey where + rawKey = iso (const paidKey) (const PaidKey) + where + paidKey :: ByteString + paidKey = convert . hashWith SHA256 . cs @_ @ByteString $ ("paid" :: String) + +instance BA.IsKey PaidKey SimpleStorageNamespace where + type Value PaidKey SimpleStorageNamespace = M.Map Address AmountPaid + +paidMap :: M.Map Address AmountPaid +paidMap = M.makeMap PaidKey store + +-- | Counts + +data CountsKey = CountsKey + +instance BA.RawKey CountsKey where + rawKey = iso (\_ -> cs countsKey) (const CountsKey) + where + countsKey :: ByteString + countsKey = convert . hashWith SHA256 . cs @_ @ByteString $ ("counts" :: String) + +instance BA.IsKey CountsKey SimpleStorageNamespace where + type Value CountsKey SimpleStorageNamespace = A.Array Count + +countsList :: A.Array Count +countsList = A.makeArray CountsKey store + +-------------------------------------------------------------------------------- + +type SimpleStorageEffs = '[SimpleStorageKeeper] + +eval + :: forall r. + Members BA.TxEffs r + => Members B.BankEffs r + => forall a. (Sem (SimpleStorageKeeper ': r) a -> Sem r a) +eval = interpret (\case + UpdateCount count -> updateCountF count + UpdatePaidCount addr count amt -> updatePaidCountF addr count amt + GetCount -> V.takeVar countVar + GetAllCounts -> A.toList countsList + ) + + +updateCountF + :: Members [Error BA.AppError, BA.ReadStore, BA.WriteStore] r + => Count + -> Sem r () +updateCountF count = do + V.putVar count countVar + A.append count countsList + + +updatePaidCountF + :: forall r . + Members B.BankEffs r + => Members [BA.ReadStore, BA.WriteStore, Error BA.AppError] r + => Address + -> Count + -> B.Amount + -> Sem r () +updatePaidCountF from count amount = + catch @_ @r + ( do + B.burn from (B.Coin simpleStorageCoinId amount) + updateCountF count + M.update (Just . \a -> a + AmountPaid amount) from paidMap + ) + (\(B.InsufficientFunds _) -> do + let mintAmount = B.Coin simpleStorageCoinId (amount + 1) + B.mint from mintAmount + updatePaidCountF from count amount + ) + +-------------------------------------------------------------------------------- +-- Router +-------------------------------------------------------------------------------- + +type MessageApi = + BA.TypedMessage UpdateCountTx BA.:~> BA.Return () :<|> + BA.TypedMessage UpdatePaidCountTx BA.:~> BA.Return () + +messageHandlers + :: Member SimpleStorageKeeper r + => BA.RouteTx MessageApi r +messageHandlers = updateCountH :<|> updatePaidCountH + +updateCountH + :: Member SimpleStorageKeeper r + => BA.RoutingTx UpdateCountTx + -> Sem r () +updateCountH (BA.RoutingTx Tx{txMsg}) = + let Msg{msgData} = txMsg + UpdateCountTx{updateCountTxCount} = msgData + in updateCount (Count updateCountTxCount) + +updatePaidCountH + :: Member SimpleStorageKeeper r + => BA.RoutingTx UpdatePaidCountTx + -> Sem r () +updatePaidCountH (BA.RoutingTx Tx{txMsg}) = + let Msg{msgData, msgAuthor} = txMsg + UpdatePaidCountTx{..} = msgData + in updatePaidCount msgAuthor (Count updatePaidCountTxCount) + (B.Amount updatePaidCountTxAmount) + +-------------------------------------------------------------------------------- +-- Server +-------------------------------------------------------------------------------- + +type CountStoreApi = + "count" :> BA.StoreLeaf (V.Var Count) :<|> + "counts" :> BA.StoreLeaf (A.Array Count) :<|> + "amount_paid" :> BA.StoreLeaf (M.Map Address AmountPaid) + +type GetMultipliedCount = + "manipulated" + :> Capture "subtract" Integer + :> QueryParam' '[Required, Strict] "factor" Integer + :> BA.Leaf Count + +getMultipliedCount + :: Members [Error BA.AppError, SimpleStorageKeeper] r + => Integer + -> Integer + -> Sem r (BA.QueryResult Count) +getMultipliedCount subtractor multiplier = do + let m = fromInteger multiplier + s = fromInteger subtractor + mc <- getCount + case mc of + Nothing -> throw . BA.makeAppError $ BA.ResourceNotFound + Just c -> pure $ BA.QueryResult + { queryResultData = m * c - s + , queryResultIndex = 0 + , queryResultKey = Base64.fromBytes $ CountKey ^. BA.rawKey + , queryResultProof = Nothing + , queryResultHeight = 0 + } + +type QueryApi = GetMultipliedCount :<|> CountStoreApi + +querier + :: forall r. + Members BA.QueryEffs r + => Member SimpleStorageKeeper r + => BA.RouteQ QueryApi r +querier = + getMultipliedCount :<|> + ( BA.storeQueryHandler countVar :<|> + BA.storeQueryHandler countsList :<|> + BA.storeQueryHandler paidMap + ) + +-------------------------------------------------------------------------------- +-- Module Definition +-------------------------------------------------------------------------------- + +type SimpleStorage = + Module SimpleStorageName MessageApi MessageApi QueryApi SimpleStorageEffs '[B.Bank] + +simpleStorageModule + :: Members (ModuleEffs SimpleStorage) r + => SimpleStorage r +simpleStorageModule = Module + { moduleTxDeliverer = messageHandlers + , moduleTxChecker = BA.defaultCheckTx (Proxy :: Proxy MessageApi) (Proxy :: Proxy r) + , moduleQuerier = querier + , moduleEval = eval + } + +evalToIO + :: BA.PureContext + -> Sem (BA.BaseAppEffs BA.PureCoreEffs) a + -> IO a +evalToIO context action = do + eRes <- BA.runPureCoreEffs context . BA.defaultCompileToPureCore $ action + either (error . show) pure eRes diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/VarSpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/VarSpec.hs new file mode 100644 index 00000000..96ed41ef --- /dev/null +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/VarSpec.hs @@ -0,0 +1,95 @@ +module Tendermint.SDK.Test.VarSpec (spec) where + +import Control.Lens (iso) +import Data.ByteString (ByteString) +import Data.IORef (IORef, newIORef) +import Data.String.Conversions (cs) +import Data.Word (Word64) +import Polysemy (Embed, Sem, runM) +import Polysemy.Error (Error, runError) +import qualified Tendermint.SDK.BaseApp as BA +import Tendermint.SDK.BaseApp.Store (Version (..)) +import Tendermint.SDK.BaseApp.Store.MemoryStore as Mem +import qualified Tendermint.SDK.BaseApp.Store.Var as V +import Tendermint.SDK.Codec (HasCodec (..)) +import Test.Hspec + +spec :: Spec +spec = + beforeAll makeConfig $ + describe "Var Spec" $ do + + it "Can create an empty var" $ \config -> do + res <- runToIO config $ V.takeVar valVar + res `shouldBe` Nothing + + it "Can put a val in a var and take it out" $ \config -> do + res <- runToIO config $ do + V.putVar 1 valVar + v <- V.takeVar valVar + v' <- V.unsafeTakeVar valVar + pure (v, v') + res `shouldBe` (Just 1, 1) + runToIO config $ V.deleteVar valVar + + +-------------------------------------------------------------------------------- +-- Store types +-------------------------------------------------------------------------------- + +data Namespace + +store :: BA.Store Namespace +store = BA.makeStore $ BA.KeyRoot "namespace" + +data ValVarKey = ValVarKey + +instance BA.RawKey ValVarKey where + rawKey = iso (\_ -> cs valVarKey) (const ValVarKey) + where + valVarKey :: ByteString + valVarKey = cs $ ("valVar" :: String) + +instance BA.IsKey ValVarKey Namespace where + type Value ValVarKey Namespace = V.Var Val + +newtype Val = Val Word64 deriving (Eq, Show, Num, HasCodec) + +valVar :: V.Var Val +valVar = V.makeVar ValVarKey store + + +-------------------------------------------------------------------------------- +-- Interpreter +-------------------------------------------------------------------------------- + +type Effs = + [ BA.ReadStore + , BA.WriteStore + , Error BA.AppError + , Embed IO + ] + +data Config = Config + { configDB :: Mem.DB + , configVersion :: IORef Version + } + +makeConfig :: IO Config +makeConfig = do + db <- Mem.initDB + v <- newIORef Latest + pure $ Config db v + +runToIO + :: Config + -> forall a. + Sem Effs a + -> IO a +runToIO Config{configDB, configVersion} m = do + eRes <- + runM . + runError . + evalWrite configDB . + evalRead configDB configVersion $ m + either (error . show) pure eRes diff --git a/hs-abci-server/README.md b/hs-abci-server/README.md index 41f83cea..9ea6bb48 100644 --- a/hs-abci-server/README.md +++ b/hs-abci-server/README.md @@ -1,7 +1,7 @@ # hs-abci-server The `hs-abci-server` package defines the types and methods for serving an ABCI application. See -the [example application](https://github.com/f-o-a-m/hs-abci/tree/master/hs-abci-example) as a guide for how you can use this package. +the [example application](https://github.com/f-o-a-m/kepler/tree/master/hs-abci-example) as a guide for how you can use this package. ## Application types The application type `App m` is defined as a newtype @@ -39,4 +39,4 @@ type Middleware m = App m -> App m ``` This is useful for hooking in things like metrics, loggers, etc. You can find some out-of-the-box middleware solutions in -the [hs-abci-extra](https://github.com/f-o-a-m/hs-abci/tree/master/hs-abci-extra) package. +the [hs-abci-extra](https://github.com/f-o-a-m/kepler/tree/master/hs-abci-extra) package. diff --git a/hs-abci-server/package.yaml b/hs-abci-server/package.yaml index 9ceaba95..6c86099a 100644 --- a/hs-abci-server/package.yaml +++ b/hs-abci-server/package.yaml @@ -1,12 +1,12 @@ name: hs-abci-server version: 0.1.0.0 -github: "f-o-a-m/hs-abci/hs-abci-server" +github: "f-o-a-m/kepler/hs-abci-server" license: Apache author: "Martin Allen" maintainer: "martin@foam.space" -copyright: "2019 Martin Allen" +copyright: "2020 Martin Allen" -description: Please see the README on GitHub at +description: Please see the README on GitHub at default-extensions: - NamedFieldPuns @@ -24,32 +24,33 @@ default-extensions: - OverloadedStrings - MultiParamTypeClasses - FunctionalDependencies - - -dependencies: -- base >= 4.7 && < 5 -- aeson -- aeson-casing -- base16-bytestring -- bytestring -- conduit -- conduit-extra -- data-default-class -- lens -- memory -- proto-lens -- proto-lens-runtime -- string-conversions -- text -- template-haskell -- time -- hs-abci-types +- TypeApplications library: source-dirs: src ghc-options: - -Werror - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-uni-patterns + - -Wredundant-constraints + dependencies: + - aeson + - base >= 4.7 && < 5 + - bytestring + - base16-bytestring + - conduit + - conduit-extra + - cryptonite + - data-default-class + - hs-abci-types + - lens + - memory + - proto-lens + - string-conversions + - text + exposed-modules: - Network.ABCI.Server - Network.ABCI.Server.App @@ -70,13 +71,11 @@ tests: dependencies: - - generic-arbitrary + - base >= 4.7 && < 5 + - bytestring - hs-abci-server - hspec - hspec-core - hspec-discover - binary - - lens-labels - - proto-lens-arbitrary - QuickCheck - - quickcheck-instances diff --git a/hs-abci-server/src/Network/ABCI/Server/App.hs b/hs-abci-server/src/Network/ABCI/Server/App.hs index 490e7bb4..c77b8b68 100644 --- a/hs-abci-server/src/Network/ABCI/Server/App.hs +++ b/hs-abci-server/src/Network/ABCI/Server/App.hs @@ -1,5 +1,19 @@ - -module Network.ABCI.Server.App where +module Network.ABCI.Server.App + ( App(..) + , runApp + , transformApp + , withProto + , Middleware + , MessageType(..) + , demoteRequestType + , msgTypeKey + , Request(..) + , hashRequest + , Response(..) + , LPByteStrings(..) + , decodeLengthPrefix + , encodeLengthPrefix + ) where import Control.Lens ((?~), (^.)) import Control.Lens.Wrapped (Wrapped (..), @@ -26,6 +40,10 @@ import qualified Network.ABCI.Server.App.DecodeError as DecodeError import qualified Network.ABCI.Types.Messages.Request as Request import qualified Network.ABCI.Types.Messages.Response as Response +import Crypto.Hash (hashWith) +import Crypto.Hash.Algorithms (SHA256 (..)) +import Data.ByteArray (convert) +import qualified Data.ByteArray.HexString as Hex import Data.Default.Class (Default (..)) import Data.ProtoLens.Message (Message (defMessage)) import Data.ProtoLens.Prism (( # )) @@ -45,6 +63,7 @@ data MessageType | MTDeliverTx | MTEndBlock | MTCommit + deriving (Eq, Ord, Enum) msgTypeKey :: MessageType -> String msgTypeKey m = case m of @@ -60,7 +79,21 @@ msgTypeKey m = case m of MTEndBlock -> "endBlock" MTCommit -> "commit" -reqParseJSON :: FromJSON inner => MessageType -> (inner -> Request t) -> Value -> Parser (Request t) +demoteRequestType :: forall (t :: MessageType). Request t -> MessageType +demoteRequestType req = case req of + RequestEcho _ -> MTEcho + RequestInfo _ -> MTInfo + RequestSetOption _ -> MTSetOption + RequestQuery _ -> MTQuery + RequestCheckTx _ -> MTCheckTx + RequestFlush _ -> MTFlush + RequestInitChain _ -> MTInitChain + RequestBeginBlock _ -> MTBeginBlock + RequestDeliverTx _ -> MTDeliverTx + RequestEndBlock _ -> MTEndBlock + RequestCommit _ -> MTCommit + +reqParseJSON :: forall t inner. FromJSON inner => MessageType -> (inner -> Request t) -> Value -> Parser (Request t) reqParseJSON msgType ctr = withObject ("req:" <> expectedType) $ \v -> do actualType <- v .: "type" if actualType == expectedType @@ -138,6 +171,24 @@ instance FromJSON (Request 'MTDeliverTx) where parseJSON = reqParseJSON MTDelive instance FromJSON (Request 'MTEndBlock) where parseJSON = reqParseJSON MTEndBlock RequestEndBlock instance FromJSON (Request 'MTCommit) where parseJSON = reqParseJSON MTCommit RequestCommit +hashRequest + :: forall (t :: MessageType). + Request t + -> Hex.HexString +hashRequest req = + let requestBytes :: BS.ByteString = case req of + RequestEcho v -> PL.encodeMessage $ v ^. _Wrapped' + RequestFlush v -> PL.encodeMessage $ v ^. _Wrapped' + RequestInfo v -> PL.encodeMessage $ v ^. _Wrapped' + RequestSetOption v -> PL.encodeMessage $ v ^. _Wrapped' + RequestInitChain v -> PL.encodeMessage $ v ^. _Wrapped' + RequestQuery v -> PL.encodeMessage $ v ^. _Wrapped' + RequestBeginBlock v -> PL.encodeMessage $ v ^. _Wrapped' + RequestCheckTx v -> PL.encodeMessage $ v ^. _Wrapped' + RequestDeliverTx v -> PL.encodeMessage $ v ^. _Wrapped' + RequestEndBlock v -> PL.encodeMessage $ v ^. _Wrapped' + RequestCommit v -> PL.encodeMessage $ v ^. _Wrapped' + in Hex.fromBytes @BS.ByteString . convert $ hashWith SHA256 requestBytes withProto :: (forall (t :: MessageType). Request t -> a) diff --git a/hs-abci-server/test/Network/ABCI/Test/Server/AppSpec.hs b/hs-abci-server/test/Network/ABCI/Test/Server/AppSpec.hs index e0a29c88..7c4d764a 100644 --- a/hs-abci-server/test/Network/ABCI/Test/Server/AppSpec.hs +++ b/hs-abci-server/test/Network/ABCI/Test/Server/AppSpec.hs @@ -1,4 +1,4 @@ -module Network.ABCI.Test.Server.AppSpec where +module Network.ABCI.Test.Server.AppSpec (spec) where import Data.Bifunctor (first) import qualified Data.Binary.Put as Put diff --git a/hs-abci-test-utils/README.md b/hs-abci-test-utils/README.md new file mode 100644 index 00000000..c5e2d124 --- /dev/null +++ b/hs-abci-test-utils/README.md @@ -0,0 +1,11 @@ +# hs-abci-test-utils + +Utils for 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 diff --git a/hs-abci-test-utils/package.yaml b/hs-abci-test-utils/package.yaml new file mode 100644 index 00000000..01ce29e8 --- /dev/null +++ b/hs-abci-test-utils/package.yaml @@ -0,0 +1,74 @@ +name: hs-abci-test-utils +version: 0.1.0.0 +github: "f-o-a-m/kepler/hs-abci-test-utils" +license: Apache +author: "Martin Allen" +maintainer: "martin@foam.space" +copyright: "2020 Martin Allen" + +extra-source-files: +- README.md + +description: Please see the README on GitHub at + +default-extensions: + - DataKinds + - DefaultSignatures + - DeriveGeneric + - FlexibleInstances + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - TypeApplications + - TypeFamilies + - RecordWildCards + - ScopedTypeVariables + - TypeOperators + - FlexibleContexts + - GeneralizedNewtypeDeriving + +library: + source-dirs: src + ghc-options: + - -Werror + - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-uni-patterns + - -Wredundant-constraints + dependencies: + - aeson + - aeson-pretty + - base >= 4.7 && < 5 + - bytestring + - cryptonite + - http-api-data + - lens + - mtl + - secp256k1-haskell + - servant + - string-conversions + - text + - hs-abci-types + - hs-abci-sdk + - hs-tendermint-client + +tests: + hs-abci-test-utils-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -Werror + - -Wall + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - aeson + - base >= 4.7 && < 5 + - hs-abci-sdk + - hs-abci-test-utils + - hspec + - hspec-core + - text + - string-conversions 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..fcc871e1 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/Client.hs @@ -0,0 +1,25 @@ +module Tendermint.Utils.Client + ( RunQueryClient(..) + , HasQueryClient(..) + , QueryClientResponse(..) + , EmptyQueryClient(..) + + , HasTxClient(..) + , RunTxClient(..) + , EmptyTxClient(..) + , TxClientResponse(..) + , SynchronousResponse(..) + , TxResponse(..) + , ClientConfig(..) + , defaultClientTxOpts + + , Signer(..) + , TxOpts(..) + , makeSignerFromKey + + ) where + +import Tendermint.Utils.QueryClient.Class +import Tendermint.Utils.QueryClient.Types +import Tendermint.Utils.TxClient.Class +import Tendermint.Utils.TxClient.Types diff --git a/hs-abci-test-utils/src/Tendermint/Utils/ClientUtils.hs b/hs-abci-test-utils/src/Tendermint/Utils/ClientUtils.hs new file mode 100644 index 00000000..c0213edf --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/ClientUtils.hs @@ -0,0 +1,124 @@ +module Tendermint.Utils.ClientUtils where + +import Control.Monad (unless) +import Data.Aeson (ToJSON) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Word (Word32) +import Network.ABCI.Types.Messages.FieldTypes (Event (..)) +import qualified Network.Tendermint.Client as RPC +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import Tendermint.SDK.BaseApp.Query (QueryResult (..)) +import Tendermint.Utils.Client (QueryClientResponse (..), + SynchronousResponse (..), + TxClientResponse (..), + TxResponse (..)) + +-------------------------------------------------------------------------------- +-- | Tx helpers +-------------------------------------------------------------------------------- + +assertTx + :: Monad m + => m (TxClientResponse a b) + -> m (SynchronousResponse a b) +assertTx m = do + resp <- m + case resp of + Response r -> pure r + RPCError err -> fail $ "Expected Response, got RPCError " <> show err + ParseError ctx err -> fail $ "Expected Response, got ParseError in context " <> show ctx + <> ": " <> show err + +-- get the logged events from a deliver response, +deliverTxEvents + :: Monad m + => Proxy e + -> SynchronousResponse a b + -> m [Event] +deliverTxEvents _ SynchronousResponse{deliverTxResponse} = + case deliverTxResponse of + TxResponse {txResponseEvents} -> do + pure txResponseEvents + TxError appError -> fail (show appError) + +-- check for a specific check response code +ensureCheckResponseCode + :: Monad m + => Word32 + -> SynchronousResponse a b + -> m () +ensureCheckResponseCode code SynchronousResponse{checkTxResponse} = + case checkTxResponse of + TxResponse _ _ -> + unless (code == 0) $ + fail $ "Couldn't match found checkTx response code 0 with expected code " <> show code <> "." + TxError appError -> + let errCode = appErrorCode appError + in unless (errCode == code) $ + fail $ "Couldn't match found checkTx response code " <> show errCode <> + " with expected code " <> show code <> "." + +-- check for a specific check response code +ensureDeliverResponseCode + :: Monad m + => Word32 + -> SynchronousResponse a b + -> m () +ensureDeliverResponseCode code SynchronousResponse{deliverTxResponse} = + case deliverTxResponse of + TxResponse _ _ -> + unless (code == 0) $ + fail $ "Couldn't match found deliverTx response code 0 with expected code " <> show code <> "." + TxError appError -> + let errCode = appErrorCode appError + in unless (errCode == code) $ + fail $ "Couldn't match found deliverTx response code " <> show errCode <> + " with expected code " <> show code <> "." + +ensureResponseCodes + :: Monad m + => (Word32, Word32) + -> SynchronousResponse a b + -> m () +ensureResponseCodes (checkCode, deliverCode) resp = do + ensureCheckResponseCode checkCode resp + ensureDeliverResponseCode deliverCode resp + +-------------------------------------------------------------------------------- +-- | Query helpers +-------------------------------------------------------------------------------- + +assertQuery + :: Monad m + => m (QueryClientResponse a) + -> m (QueryResult a) +assertQuery m = do + resp <- m + case resp of + QueryResponse r -> pure r + QueryError err -> fail $ show err + +ensureQueryResponseCode + :: Monad m + => Word32 + -> QueryClientResponse a + -> m () +ensureQueryResponseCode code resp = case resp of + QueryResponse _ -> + unless (code == 0) $ + fail $ "Couldn't match found query response code 0 with expected code " <> show code <> "." + QueryError AppError{appErrorCode} -> + unless (appErrorCode == code) $ + fail $ "Couldn't match found query response code " <> show appErrorCode <> + " with expected code " <> show code <> "." + +-------------------------------------------------------------------------------- + +rpcConfig :: RPC.Config +rpcConfig = + let RPC.Config baseReq _ _ host port tls = RPC.defaultConfig "localhost" 26657 False + 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") host port tls 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..cac27b36 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/Events.hs @@ -0,0 +1,53 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Tendermint.Utils.Events where + +import qualified Data.ByteArray.Base64String as Base64 +import qualified Data.ByteString as BS +import Data.Char (toUpper) +import qualified Data.List as L +import Data.String.Conversions (cs) +import Data.Text (Text, pack, unpack) +import GHC.Generics +import Network.ABCI.Types.Messages.FieldTypes (KVPair (..)) +import Tendermint.SDK.BaseApp.Events (Event (..), ToEvent) +import Tendermint.SDK.Codec (HasCodec (..)) + + +class GFromNamedEventPrimatives f where + gfromNamedEventPrimatives :: [(BS.ByteString, BS.ByteString)] -> Either Text (f a) + +instance (Selector s, HasCodec a) => GFromNamedEventPrimatives (S1 s (K1 i a)) where + gfromNamedEventPrimatives kvs = + let name = selName (undefined :: S1 s (K1 i a) p) + in case L.lookup (cs name) kvs of + Nothing -> Left $ "Could not find key " <> cs name <> " in Event key-values." + Just val -> M1 . K1 <$> decode val + +instance (GFromNamedEventPrimatives f) => GFromNamedEventPrimatives (C1 c f) where + gfromNamedEventPrimatives = fmap M1 . gfromNamedEventPrimatives + + +instance (GFromNamedEventPrimatives a, GFromNamedEventPrimatives b) => GFromNamedEventPrimatives (a :*: b) where + gfromNamedEventPrimatives kvs = + (:*:) <$> gfromNamedEventPrimatives kvs <*> gfromNamedEventPrimatives kvs + +class GFromEvent f where + gfromEventData :: Event -> Either Text (f p) + +instance (GFromNamedEventPrimatives f, Datatype d) => GFromEvent (D1 d f) where + gfromEventData Event{eventType, eventAttributes} = + let upperFirstChar [] = [] + upperFirstChar (x : xs) = toUpper x : xs + eventType' = pack . upperFirstChar . unpack $ eventType + dt = cs $ datatypeName (undefined :: D1 d f p) + in if dt == eventType' + then fmap M1 . gfromNamedEventPrimatives $ + map (\(KVPair k v) -> (Base64.toBytes k, Base64.toBytes v)) eventAttributes + else Left $ "Expected Event type " <> dt <> " does not match found Event type " <> cs eventType' <> "." + +class ToEvent e => FromEvent e where + fromEvent :: Event -> Either Text e + + default fromEvent :: (Generic e, GFromEvent (Rep e)) => Event -> Either Text e + fromEvent = fmap to . gfromEventData + diff --git a/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Class.hs b/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Class.hs new file mode 100644 index 00000000..f5078fdd --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Class.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE UndecidableInstances #-} +module Tendermint.Utils.QueryClient.Class where + +import Control.Lens ((^.)) +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 Data.Text (Text, intercalate) +import Data.Word (Word64) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.ABCI.Types.Messages.FieldTypes (WrappedVal (..)) +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 Servant.API.Modifiers +import Tendermint.SDK.BaseApp.Errors (queryAppError) +import Tendermint.SDK.BaseApp.Query.Store (StoreLeaf) +import Tendermint.SDK.BaseApp.Query.Types (Leaf, QA, + QueryArgs (..), + QueryData (..), + QueryResult (..)) +import qualified Tendermint.SDK.BaseApp.Store.Array as A +import qualified Tendermint.SDK.BaseApp.Store.Map as M +import qualified Tendermint.SDK.BaseApp.Store.Var as V +import Tendermint.SDK.Codec (HasCodec (decode)) +import Tendermint.Utils.QueryClient.Types +import Web.Internal.HttpApiData (ToHttpApiData (..)) + +class Monad m => RunQueryClient m where + -- | How to make a request. + runQuery :: Req.Query -> m Resp.Query + +instance RunQueryClient (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 + +type QueryStringList = [(Text, Text)] + +class HasQueryClient m layout where + + type ClientQ (m :: * -> *) layout :: * + genClientQ :: Proxy m -> Proxy layout -> (Req.Query, QueryStringList) -> ClientQ m layout + +instance (HasQueryClient m a, HasQueryClient m b) => HasQueryClient m (a :<|> b) where + type ClientQ m (a :<|> b) = ClientQ m a :<|> ClientQ m b + genClientQ pm _ (q,qs) = genClientQ pm (Proxy @a) (q,qs) :<|> genClientQ pm (Proxy @b) (q,qs) + +instance (KnownSymbol path, HasQueryClient m a) => HasQueryClient m (path :> a) where + type ClientQ m (path :> a) = ClientQ m a + genClientQ pm _ (q,qs) = genClientQ pm (Proxy @a) + (q {Req.queryPath = Req.queryPath q <> "/" <> cs (symbolVal (Proxy @path))}, qs) + +appendToQueryString + :: Text -- ^ param name + -> Maybe Text -- ^ param value + -> QueryStringList + -> QueryStringList +appendToQueryString pname pvalue qs = + maybe qs (\v -> (pname, v) : qs) pvalue + +instance (KnownSymbol sym, ToHttpApiData a, HasQueryClient m api, SBoolI (FoldRequired mods)) + => HasQueryClient m (QueryParam' mods sym a :> api) where + + type ClientQ m (QueryParam' mods sym a :> api) = RequiredArgument mods a -> ClientQ m api + + -- if mparam = Nothing, we don't add it to the query string + genClientQ pm Proxy (q,qs) mparam = + genClientQ pm (Proxy :: Proxy api) $ foldRequiredArgument + (Proxy :: Proxy mods) add (maybe (q,qs) add) mparam + where + add :: a -> (Req.Query, QueryStringList) + add param = (q, appendToQueryString pname (Just $ toQueryParam param) qs) + + pname :: Text + pname = cs $ symbolVal (Proxy :: Proxy sym) + +instance (QueryData k, HasQueryClient m a) => HasQueryClient m (QA k :> a) where + type ClientQ m (QA k :> a) = QueryArgs k -> ClientQ m a + genClientQ pm _ (q,qs) QueryArgs{..} = genClientQ pm (Proxy @a) + (q { Req.queryData = toQueryData queryArgsData + , Req.queryHeight = WrappedVal queryArgsHeight + , Req.queryProve = queryArgsProve + }, qs) + +instance (ToHttpApiData a, HasQueryClient m api) => HasQueryClient m (Capture' mods capture a :> api) where + + type ClientQ m (Capture' mods capture a :> api) = a -> ClientQ m api + + genClientQ pm _ (q,qs) val = + let p = toUrlPiece val + q' = q { Req.queryPath = Req.queryPath q <> "/" <> p } + in genClientQ pm (Proxy :: Proxy api) (q', qs) + +addQueryParamsToPath + :: QueryStringList + -> Text + -> Text +addQueryParamsToPath qs path = + let qParams = intercalate "&" $ map (\(n,v) -> n <> "=" <> v) qs + in case qs of + [] -> path + _ -> path <> "?" <> qParams + +instance (HasCodec a, RunQueryClient m) => HasQueryClient m (Leaf a) where + type ClientQ m (Leaf a) = m (QueryClientResponse a) + genClientQ _ _ = leafGenClient + +leafGenClient + :: HasCodec a + => RunQueryClient m + => (Req.Query, QueryStringList) + -> m (QueryClientResponse a) +leafGenClient (q,qs) = do + let reqPath = addQueryParamsToPath qs $ Req.queryPath q + r@Resp.Query{..} <- runQuery q { Req.queryPath = reqPath } + -- 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 decode $ Base64.toBytes queryValue of + Left err -> error $ "Impossible parse error: " <> cs err + Right a -> QueryResponse $ QueryResult + { queryResultData = a + , queryResultIndex = unWrappedVal queryIndex + , queryResultHeight = unWrappedVal queryHeight + , queryResultProof = queryProof + , queryResultKey = queryKey + } + _ -> QueryError $ r ^. queryAppError + +instance (HasCodec a, RunQueryClient m) => HasQueryClient m (StoreLeaf (V.Var a)) where + type ClientQ m (StoreLeaf (V.Var a)) = ClientQ m (QA () :> Leaf a) + genClientQ pm _ = genClientQ pm (Proxy @(QA () :> Leaf a)) + +instance (HasCodec a, RunQueryClient m) => HasQueryClient m (StoreLeaf (A.Array a)) where + type ClientQ m (StoreLeaf (A.Array a)) = ClientQ m (QA Word64 :> Leaf a) + genClientQ pm _ = genClientQ pm (Proxy @(QA Word64 :> Leaf a)) + +instance (QueryData k, HasCodec v, RunQueryClient m) => HasQueryClient m (StoreLeaf (M.Map k v)) where + type ClientQ m (StoreLeaf (M.Map k v)) = ClientQ m (QA k :> Leaf v) + genClientQ pm _ = genClientQ pm (Proxy @(QA k :> Leaf v)) + +-- | Singleton type representing a client for an empty API. +data EmptyQueryClient = EmptyQueryClient deriving (Eq, Show, Bounded, Enum) + +instance HasQueryClient m EmptyQueryClient where + type ClientQ m EmptyQueryClient = EmptyQueryClient + + genClientQ _ _ _ = EmptyQueryClient diff --git a/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Types.hs b/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Types.hs new file mode 100644 index 00000000..ff65cf63 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Types.hs @@ -0,0 +1,10 @@ +module Tendermint.Utils.QueryClient.Types where + +import Tendermint.SDK.BaseApp.Errors (AppError) +import Tendermint.SDK.BaseApp.Query.Types (QueryResult) + +-- | Data is Nothing iff Raw includes a non-0 response value +data QueryClientResponse a = + QueryResponse (QueryResult a) + | QueryError AppError + deriving (Eq, Show) diff --git a/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Class.hs b/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Class.hs new file mode 100644 index 00000000..2d0d9c70 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Class.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Tendermint.Utils.TxClient.Class + ( ClientConfig(..) + , RunTxClient(..) + , HasTxClient(..) + , EmptyTxClient(..) + , defaultClientTxOpts + ) where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ReaderT, ask) +import qualified Data.ByteArray.Base64String as Base64 +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word64) +import GHC.TypeLits (KnownSymbol, symbolVal) +import qualified Network.Tendermint.Client as RPC +import Servant.API ((:<|>) (..), (:>)) +import qualified Tendermint.SDK.BaseApp.Transaction as T +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Address (Address) +import Tendermint.SDK.Types.Message (HasMessageType (..), + TypedMessage (..)) +import Tendermint.SDK.Types.Transaction (RawTransaction (..)) +import Tendermint.Utils.TxClient.Types + +class Monad m => RunTxClient m where + -- | How to make a request. + runTx :: RawTransaction -> m RPC.ResultBroadcastTxCommit + getNonce :: Address -> m Word64 + +data ClientConfig = ClientConfig + { clientRPC :: RPC.Config + , clientGetNonce :: Address -> IO Word64 + } + + +instance RunTxClient (ReaderT ClientConfig IO) where + getNonce addr = do + nonceGetter <- clientGetNonce <$> ask + liftIO $ nonceGetter addr + runTx tx = do + let txReq = RPC.broadcastTxCommit . RPC.RequestBroadcastTxCommit . Base64.fromBytes . encode $ tx + rpc <- clientRPC <$> ask + liftIO . RPC.runTendermintM rpc $ txReq + +data ClientTxOpts = ClientTxOpts + { clientTxOptsRoute :: Text + , clientTxOptsNonce :: Word64 + } + +defaultClientTxOpts :: ClientTxOpts +defaultClientTxOpts = ClientTxOpts "" 0 + +class HasTxClient m layoutC layoutD where + + type ClientT (m :: * -> *) layoutC layoutD :: * + genClientT :: Proxy m -> Proxy layoutC -> Proxy layoutD -> ClientTxOpts -> ClientT m layoutC layoutD + +instance (HasTxClient m a c, HasTxClient m b d) => HasTxClient m (a :<|> b) (c :<|> d) where + type ClientT m (a :<|> b) (c :<|> d) = ClientT m a c :<|> ClientT m b d + genClientT pm _ _ opts = genClientT pm (Proxy @a) (Proxy @c) opts :<|> + genClientT pm (Proxy @b) (Proxy @d) opts + +instance (KnownSymbol path, HasTxClient m a b) => HasTxClient m (path :> a) (path :> b) where + type ClientT m (path :> a) (path :> b) = ClientT m a b + genClientT pm _ _ clientOpts = + let clientOpts' = clientOpts { clientTxOptsRoute = cs $ symbolVal (Proxy @path) } + in genClientT pm (Proxy @a) (Proxy @b) clientOpts' + +makeRawTxForSigning + :: forall msg. + HasMessageType msg + => HasCodec msg + => ClientTxOpts + -> TxOpts + -> msg + -> RawTransaction +makeRawTxForSigning ClientTxOpts{..} TxOpts{..} msg = + RawTransaction + { rawTransactionData = TypedMessage (encode msg) (messageType $ Proxy @msg) + , rawTransactionGas = txOptsGas + , rawTransactionNonce = clientTxOptsNonce + , rawTransactionRoute = clientTxOptsRoute + , rawTransactionSignature = "" + } + +instance ( HasMessageType msg, HasCodec msg + , HasCodec check, HasCodec deliver + , RunTxClient m + ) => HasTxClient m (T.TypedMessage msg T.:~> T.Return check) (T.TypedMessage msg T.:~> T.Return deliver) where + type ClientT m (T.TypedMessage msg T.:~> T.Return check) (T.TypedMessage msg T.:~> T.Return deliver) = + TxOpts -> msg -> m (TxClientResponse check deliver) + + genClientT _ _ _ clientOpts opts msg = do + let Signer signerAddress signer = txOptsSigner opts + nonce <- getNonce signerAddress + let clientOpts' = clientOpts {clientTxOptsNonce = nonce} + rawTxForSigning = makeRawTxForSigning clientOpts' opts msg + rawTxWithSig = signer rawTxForSigning + txRes <- runTx rawTxWithSig + pure $ parseRPCResponse txRes + + +-- | Singleton type representing a client for an empty API. +data EmptyTxClient = EmptyTxClient deriving (Eq, Show, Bounded, Enum) + +instance HasTxClient m T.EmptyTxServer T.EmptyTxServer where + type ClientT m T.EmptyTxServer T.EmptyTxServer = EmptyTxClient + + genClientT _ _ _ _ = EmptyTxClient diff --git a/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Types.hs b/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Types.hs new file mode 100644 index 00000000..7cec37b4 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Types.hs @@ -0,0 +1,95 @@ +module Tendermint.Utils.TxClient.Types where + +import Control.Lens ((^.)) +import Crypto.Hash (Digest) +import Crypto.Hash.Algorithms (SHA256) +import Data.Bifunctor (first) +import qualified Data.ByteArray.Base64String as Base64 +import Data.Int (Int64) +import Data.Proxy +import Data.Text (Text) +import Network.ABCI.Types.Messages.FieldTypes (Event) +import qualified Network.ABCI.Types.Messages.Response as Response +import qualified Network.Tendermint.Client as RPC +import Tendermint.SDK.BaseApp.Errors (AppError, + txResultAppError) +import qualified Tendermint.SDK.BaseApp.Transaction as T +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Crypto (RecoverableSignatureSchema (..), + SignatureSchema (..)) +import Tendermint.SDK.Types.Address (Address) +import Tendermint.SDK.Types.Transaction (RawTransaction (..), + signRawTransaction) +import Tendermint.SDK.Types.TxResult (checkTxTxResult, + deliverTxTxResult) + +data TxOpts = TxOpts + { txOptsGas :: Int64 + , txOptsSigner :: Signer + } + +data Signer = Signer + { signerAddress :: Address + , signerSign :: RawTransaction -> RawTransaction + } + +makeSignerFromKey + :: RecoverableSignatureSchema alg + => Message alg ~ Digest SHA256 + => Proxy alg + -> PrivateKey alg + -> Signer +makeSignerFromKey pa privKey = Signer (addressFromPubKey pa . derivePubKey pa $ privKey) $ \r -> + let sig = serializeRecoverableSignature pa $ + signRawTransaction pa privKey $ r {rawTransactionSignature = ""} + in r {rawTransactionSignature = sig} + +data TxResponse a = + TxResponse + { txResponseResult :: a + , txResponseEvents :: [Event] + } + | TxError AppError + deriving (Eq, Show) + +data SynchronousResponse c d = SynchronousResponse + { checkTxResponse :: TxResponse c + , deliverTxResponse :: TxResponse d + } deriving (Eq, Show) + +data TxClientResponse c d = + RPCError Text + | ParseError T.RouteContext Text + | Response (SynchronousResponse c d) + deriving (Eq, Show) + +parseRPCResponse + :: forall check deliver. + HasCodec check + => HasCodec deliver + => RPC.ResultBroadcastTxCommit + -> TxClientResponse check deliver +parseRPCResponse RPC.ResultBroadcastTxCommit{..} = + let + makeCheckResp r@Response.CheckTx{..} = case checkTxCode of + 0 -> do + resp <- decode $ Base64.toBytes checkTxData + pure $ TxResponse resp $ checkTxEvents + _ -> Right . TxError $ r ^. checkTxTxResult . txResultAppError + + makeDeliverResp r@Response.DeliverTx{..} = case deliverTxCode of + 0 -> do + resp <- decode $ Base64.toBytes deliverTxData + pure $ TxResponse resp $ deliverTxEvents + _ -> Right . TxError $ r ^. deliverTxTxResult . txResultAppError + + eResponses = do + checkResp <- first (ParseError T.CheckTx) $ + makeCheckResp resultBroadcastTxCommitCheckTx + deliverResp <- first (ParseError T.DeliverTx) $ + makeDeliverResp resultBroadcastTxCommitDeliverTx + pure (checkResp, deliverResp) + + in case eResponses of + Left e -> e + Right (check, deliver) -> Response $ SynchronousResponse check deliver 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..89f178b9 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/User.hs @@ -0,0 +1,28 @@ +module Tendermint.Utils.User where + +import Crypto.Secp256k1 (SecKey, derivePubKey, secKey) +import qualified Data.ByteArray.HexString as Hex +import Data.Maybe (fromJust) +import Data.Proxy +import Data.String (fromString) +import Tendermint.SDK.Crypto (Secp256k1, addressFromPubKey) +import Tendermint.SDK.Types.Address (Address (..)) +import Tendermint.Utils.TxClient.Types (Signer, makeSignerFromKey) + +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 + +makeSignerFromUser + :: User + -> Signer +makeSignerFromUser User{userPrivKey} = + makeSignerFromKey (Proxy @Secp256k1) userPrivKey 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/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..2a9169cd --- /dev/null +++ b/hs-abci-test-utils/test/Tendermint/Utils/Test/EventSpec.hs @@ -0,0 +1,41 @@ +module Tendermint.Utils.Test.EventSpec (spec) where + +import qualified Data.Aeson as A +import Data.Bifunctor (first) +import Data.String.Conversions (cs) +import Data.Text (pack) +import GHC.Generics (Generic) +import Tendermint.SDK.BaseApp.Events (ToEvent (..)) +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.Utils.Events (FromEvent (..)) +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 (toEvent transferEv) `shouldBe` Right transferEv + + +newtype WrappedInt = WrappedInt {unwrapInt :: Int} + deriving (Eq, Show, Generic, A.ToJSON, A.FromJSON, Num) + +instance HasCodec WrappedInt where + encode (WrappedInt i) = cs $ A.encode i + decode = first pack . A.eitherDecodeStrict + +data Transfer = Transfer + { to :: String + , from :: String + , amount :: WrappedInt + } deriving (Eq, Show, Generic) + + +instance A.ToJSON Transfer +instance A.FromJSON Transfer +instance ToEvent Transfer +instance FromEvent Transfer diff --git a/hs-abci-types/README.md b/hs-abci-types/README.md index b5166717..a4ff944e 100644 --- a/hs-abci-types/README.md +++ b/hs-abci-types/README.md @@ -2,9 +2,8 @@ This module provides haskell bindings for the Tendermint ABCI message types defined in [tendermint/tendermint/abci/types/types.proto](https://github.com/tendermint/tendermint/blob/v0.32.2/abci/types/types.proto#L3). - ## Under the hood -We use [proto-lens](https://github.com/google/proto-lens) to generate all the types from files in the [protos](https://github.com/f-o-a-m/hs-abci/tree/master/hs-abci-types/protos) directory, but the generated code is a bit brutal to use directly. This package defines a more user friendly version using Control.Lens.Wrapped. This way we still use proto-lens for encoding/decoding protocol messages while users can work with nicer types defined here. +We use [proto-lens](https://github.com/google/proto-lens) to generate all the types from files in the [protos](https://github.com/f-o-a-m/kepler/tree/master/hs-abci-types/protos) directory, but the generated code is a bit brutal to use directly. This package defines a more user friendly version using Control.Lens.Wrapped. This way we still use proto-lens for encoding/decoding protocol messages while users can work with nicer types defined here. ## JSON Again, Tendermint protocol messages are defined with protobuf files and use protobuf codecs. However, we still supply `ToJSON`/`FromJSON` instances of the types for communicating with tendermint json-rpc server and because they are generally useful. diff --git a/hs-abci-types/package.yaml b/hs-abci-types/package.yaml index 9624c12d..ffd03e8b 100644 --- a/hs-abci-types/package.yaml +++ b/hs-abci-types/package.yaml @@ -1,15 +1,15 @@ name: hs-abci-types version: 0.1.0.0 -github: "f-o-a-m/hs-abci/hs-abci-types" +github: "f-o-a-m/kepler//hs-abci-types" license: Apache author: "Martin Allen" maintainer: "martin@foam.space" -copyright: "2019 Martin Allen" +copyright: "2020 Martin Allen" extra-source-files: - protos/**/*.proto -description: Please see the README on GitHub at +description: Please see the README on GitHub at custom-setup: dependencies: @@ -36,33 +36,38 @@ default-extensions: - FunctionalDependencies -dependencies: -- base >= 4.7 && < 5 -- aeson -- aeson-casing -- base16-bytestring -- bytestring -- data-default-class -- lens -- memory -- proto-lens -- proto-lens-runtime -- string-conversions -- text -- template-haskell -- time - library: source-dirs: src ghc-options: - -Werror - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-uni-patterns + - -Wredundant-constraints + dependencies: + - aeson + - aeson-casing + - base >= 4.7 && < 5 + - bytestring + - data-default-class + - memory + - lens + - proto-lens + - proto-lens-runtime + - text + - template-haskell + - time exposed-modules: - Data.ByteArray.HexString - Data.ByteArray.Base64String + - Network.ABCI.Types.Messages.Common - Network.ABCI.Types.Messages.Request - Network.ABCI.Types.Messages.Response - Network.ABCI.Types.Messages.FieldTypes + other-modules: + - Data.Time.Calendar.Private + - Data.Time.Orphans generated-exposed-modules: - Proto.Types - Proto.Types_Fields @@ -92,13 +97,15 @@ tests: dependencies: + - base + - bytestring - generic-arbitrary - hs-abci-types - hspec - hspec-core - hspec-discover - - binary - - lens-labels + - lens + - proto-lens - proto-lens-arbitrary - QuickCheck - quickcheck-instances diff --git a/hs-abci-types/src/Data/ByteArray/HexString.hs b/hs-abci-types/src/Data/ByteArray/HexString.hs index 73b30336..fd895060 100644 --- a/hs-abci-types/src/Data/ByteArray/HexString.hs +++ b/hs-abci-types/src/Data/ByteArray/HexString.hs @@ -15,12 +15,12 @@ import Data.Semigroup (Semigroup) import Data.String (IsString (..)) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8, encodeUtf8) - +import GHC.Generics (Generic) -- | Represents a Hex string. Guarantees that all characters it contains -- are valid hex characters. newtype HexString = HexString { unHexString :: ByteString } - deriving (Eq, Ord, Semigroup, Monoid, ByteArrayAccess, ByteArray) + deriving (Eq, Ord, Generic, Semigroup, Monoid, ByteArrayAccess, ByteArray) instance Show HexString where show = ("HexString " ++) . show . format diff --git a/hs-abci-types/src/Data/Time/Calendar/Private.hs b/hs-abci-types/src/Data/Time/Calendar/Private.hs index 5a3e9f68..1d0b5926 100644 --- a/hs-abci-types/src/Data/Time/Calendar/Private.hs +++ b/hs-abci-types/src/Data/Time/Calendar/Private.hs @@ -1,6 +1,11 @@ -module Data.Time.Calendar.Private where -- venored from: http://hackage.haskell.org/package/time-1.9.3/docs/src/Data.Time.Calendar.Private.html -import Data.Fixed + +module Data.Time.Calendar.Private + ( PadOption (..) + , ShowPadded (..) + , quotBy + , remBy + ) where data PadOption = Pad Int Char | NoPad @@ -22,43 +27,9 @@ instance ShowPadded Int where showPaddedNum pad i | i < 0 = '-':(showPaddedNum pad (negate i)) showPaddedNum pad i = showPadded pad $ show i -show2Fixed :: Pico -> String -show2Fixed x | x < 10 = '0':(showFixed True x) -show2Fixed x = showFixed True x - -show2 :: (ShowPadded t) => t -> String -show2 = showPaddedNum $ Pad 2 '0' - -show3 :: (ShowPadded t) => t -> String -show3 = showPaddedNum $ Pad 3 '0' - -show4 :: (ShowPadded t) => t -> String -show4 = showPaddedNum $ Pad 4 '0' - -mod100 :: (Integral i) => i -> i -mod100 x = mod x 100 - -div100 :: (Integral i) => i -> i -div100 x = div x 100 - -clip :: (Ord t) => t -> t -> t -> t -clip a _ x | x < a = a -clip _ b x | x > b = b -clip _ _ x = x - -clipValid :: (Ord t) => t -> t -> t -> Maybe t -clipValid a _ x | x < a = Nothing -clipValid _ b x | x > b = Nothing -clipValid _ _ x = Just x - quotBy :: (Real a,Integral b) => a -> a -> b quotBy d n = truncate ((toRational n) / (toRational d)) remBy :: Real a => a -> a -> a remBy d n = n - (fromInteger f) * d where f = quotBy d n - -quotRemBy :: (Real a,Integral b) => a -> a -> (b,a) -quotRemBy d n = let - f = quotBy d n - in (f,n - (fromIntegral f) * d) diff --git a/hs-abci-types/src/Data/Time/Orphans.hs b/hs-abci-types/src/Data/Time/Orphans.hs index 199f7983..68b4e89b 100644 --- a/hs-abci-types/src/Data/Time/Orphans.hs +++ b/hs-abci-types/src/Data/Time/Orphans.hs @@ -1,6 +1,6 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.Time.Orphans where -- vendored from: http://hackage.haskell.org/package/time-1.9.3/docs/src/Data.Time.Format.Format.Class.html +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Time.Orphans () where import Data.Fixed (Pico) import Data.Time.Calendar.Private (PadOption (..), ShowPadded (..), diff --git a/hs-abci-types/src/Network/ABCI/Types/Messages/Request.hs b/hs-abci-types/src/Network/ABCI/Types/Messages/Request.hs index c2d38a64..47953d39 100644 --- a/hs-abci-types/src/Network/ABCI/Types/Messages/Request.hs +++ b/hs-abci-types/src/Network/ABCI/Types/Messages/Request.hs @@ -17,6 +17,7 @@ import Data.ByteArray.Base64String (Base64String) import qualified Data.ByteArray.Base64String as Base64 import Data.ByteArray.HexString (HexString) import qualified Data.ByteArray.HexString as Hex +import Data.Default.Class (Default (..)) import Data.Int (Int64) import Data.ProtoLens.Message (Message (defMessage)) import Data.Text (Text) @@ -60,6 +61,9 @@ instance Wrapped Echo where t Echo {..} = defMessage & PT.message .~ echoMessage f message = Echo { echoMessage = message ^. PT.message } +instance Default Echo where + def = defMessage ^. _Unwrapped' + -------------------------------------------------------------------------------- -- Flush -------------------------------------------------------------------------------- @@ -80,6 +84,9 @@ instance Wrapped Flush where t = const defMessage f = const Flush +instance Default Flush where + def = defMessage ^. _Unwrapped' + -------------------------------------------------------------------------------- -- Info -------------------------------------------------------------------------------- @@ -117,6 +124,9 @@ instance Wrapped Info where , infoP2pVersion = message ^. PT.p2pVersion } +instance Default Info where + def = defMessage ^. _Unwrapped' + -------------------------------------------------------------------------------- -- SetOption -------------------------------------------------------------------------------- @@ -148,6 +158,9 @@ instance Wrapped SetOption where , setOptionValue = message ^. PT.value } +instance Default SetOption where + def = defMessage ^. _Unwrapped' + -------------------------------------------------------------------------------- -- InitChain -------------------------------------------------------------------------------- @@ -199,6 +212,9 @@ instance Wrapped InitChain where , initChainAppState = Base64.fromBytes $ message ^. PT.appStateBytes } +instance Default InitChain where + def = defMessage ^. _Unwrapped' + -------------------------------------------------------------------------------- -- Query -------------------------------------------------------------------------------- @@ -240,6 +256,9 @@ instance Wrapped Query where , queryProve = message ^. PT.prove } +instance Default Query where + def = defMessage ^. _Unwrapped' + -------------------------------------------------------------------------------- -- BeginBlock -------------------------------------------------------------------------------- @@ -287,6 +306,9 @@ instance Wrapped BeginBlock where , beginBlockByzantineValidators = message ^.. PT.byzantineValidators . traverse . _Unwrapped' } +instance Default BeginBlock where + def = defMessage ^. _Unwrapped' + -------------------------------------------------------------------------------- -- CheckTx -------------------------------------------------------------------------------- @@ -315,6 +337,9 @@ instance Wrapped CheckTx where f message = CheckTx { checkTxTx = Base64.fromBytes $ message ^. PT.tx } +instance Default CheckTx where + def = defMessage ^. _Unwrapped' + -------------------------------------------------------------------------------- -- DeliverTx -------------------------------------------------------------------------------- @@ -342,6 +367,9 @@ instance Wrapped DeliverTx where f message = DeliverTx { deliverTxTx = Base64.fromBytes $ message ^. PT.tx } +instance Default DeliverTx where + def = defMessage ^. _Unwrapped' + -------------------------------------------------------------------------------- -- EndBlock -------------------------------------------------------------------------------- @@ -370,6 +398,9 @@ instance Wrapped EndBlock where f message = EndBlock { endBlockHeight = WrappedVal $ message ^. PT.height } +instance Default EndBlock where + def = defMessage ^. _Unwrapped' + -------------------------------------------------------------------------------- -- Commit -------------------------------------------------------------------------------- @@ -394,3 +425,6 @@ instance Wrapped Commit where t Commit = defMessage f _ = Commit + +instance Default Commit where + def = defMessage ^. _Unwrapped' diff --git a/hs-abci-types/src/Network/ABCI/Types/Messages/Response.hs b/hs-abci-types/src/Network/ABCI/Types/Messages/Response.hs index 6ff44fa7..1ffd69e5 100644 --- a/hs-abci-types/src/Network/ABCI/Types/Messages/Response.hs +++ b/hs-abci-types/src/Network/ABCI/Types/Messages/Response.hs @@ -21,8 +21,7 @@ import Data.Default.Class (Default (..)) import Data.Int (Int64) import Data.ProtoLens.Message (Message (defMessage)) import Data.Text (Text) -import Data.Word (Word64) -import Data.Word (Word32) +import Data.Word (Word32, Word64) import GHC.Generics (Generic) import Network.ABCI.Types.Messages.Common (defaultABCIOptions, makeABCILenses) diff --git a/hs-abci-types/test/Network/ABCI/Test/Types/MessagesSpec.hs b/hs-abci-types/test/Network/ABCI/Test/Types/MessagesSpec.hs index 04c6c6c5..2ce41e68 100644 --- a/hs-abci-types/test/Network/ABCI/Test/Types/MessagesSpec.hs +++ b/hs-abci-types/test/Network/ABCI/Test/Types/MessagesSpec.hs @@ -1,4 +1,4 @@ -module Network.ABCI.Test.Types.MessagesSpec where +module Network.ABCI.Test.Types.MessagesSpec (spec) where import Control.Lens (Iso', from, set, to, @@ -83,13 +83,6 @@ scrubTimestamp ts = ts & T.seconds %~ abs & T.nanos %~ (`mod` 1000000000) . abs -scrubTimestampField - :: HasField a "time" T.Timestamp - => a - -> a -scrubTimestampField a = - a & PT.time %~ scrubTimestamp - scrubTimestampFieldMaybe :: HasField a "maybe'time" (Maybe T.Timestamp) => a diff --git a/hs-iavl-client/Setup.hs b/hs-iavl-client/Setup.hs new file mode 100644 index 00000000..c81784fa --- /dev/null +++ b/hs-iavl-client/Setup.hs @@ -0,0 +1,2 @@ +import Data.ProtoLens.Setup +main = defaultMainGeneratingProtos "protos" diff --git a/hs-iavl-client/package.yaml b/hs-iavl-client/package.yaml new file mode 100644 index 00000000..1ff3d9df --- /dev/null +++ b/hs-iavl-client/package.yaml @@ -0,0 +1,85 @@ +name: hs-iavl-client +version: 0.1.0.0 +github: "f-o-a-m/kepler/hs-iavl-client" +license: Apache +author: "Martin Allen" +maintainer: "martin@foam.space" +copyright: "2020 Martin Allen" + +extra-source-files: +- protos/**/*.proto + +description: Please see the README on GitHub at + +custom-setup: + dependencies: + - base + - Cabal + - proto-lens-setup + +default-extensions: +- NamedFieldPuns +- RecordWildCards +- FlexibleContexts +- DeriveGeneric +- LambdaCase +- TypeFamilies +- GADTs +- GeneralizedNewtypeDeriving +- DataKinds +- PolyKinds +- RankNTypes +- DataKinds +- ScopedTypeVariables +- FlexibleInstances +- OverloadedStrings +- MultiParamTypeClasses +- FunctionalDependencies + +library: + source-dirs: src + ghc-options: + - -Werror + - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-uni-patterns + - -Wredundant-constraints + dependencies: + - base >= 4.7 && < 5 + - http2-client + - http2-client-grpc + - proto-lens + - proto-lens-runtime + - text + exposed-modules: + - Database.IAVL.RPC + - Database.IAVL.RPC.Types + generated-exposed-modules: + - Proto.Iavl.Api + - Proto.Iavl.Api_Fields + - Proto.Google.Api.Http + - Proto.Google.Protobuf.Empty + - Proto.Google.Api.Annotations + +tests: + hs-iavl-client-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -Werror + - -Wall + - -threaded + - -rtsopts + - -with-rtsopts=-N + + dependencies: + - base >= 4.7 && < 5 + - hs-iavl-client + - hspec + - hspec-core + - hspec-discover + - http2-client + - http2-client-grpc + - lens + - proto-lens diff --git a/hs-iavl-client/protos/google/api/annotations.proto b/hs-iavl-client/protos/google/api/annotations.proto new file mode 100644 index 00000000..85c361b4 --- /dev/null +++ b/hs-iavl-client/protos/google/api/annotations.proto @@ -0,0 +1,31 @@ +// Copyright (c) 2015, Google Inc. +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS IS" BASIS, +// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +// See the License for the specific language governing permissions and +// limitations under the License. + +syntax = "proto3"; + +package google.api; + +import "google/api/http.proto"; +import "google/protobuf/descriptor.proto"; + +option go_package = "google.golang.org/genproto/googleapis/api/annotations;annotations"; +option java_multiple_files = true; +option java_outer_classname = "AnnotationsProto"; +option java_package = "com.google.api"; +option objc_class_prefix = "GAPI"; + +extend google.protobuf.MethodOptions { + // See `HttpRule`. + HttpRule http = 72295728; +} diff --git a/hs-iavl-client/protos/google/api/http.proto b/hs-iavl-client/protos/google/api/http.proto new file mode 100644 index 00000000..b2977f51 --- /dev/null +++ b/hs-iavl-client/protos/google/api/http.proto @@ -0,0 +1,376 @@ +// Copyright 2019 Google LLC. +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS IS" BASIS, +// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +// See the License for the specific language governing permissions and +// limitations under the License. +// + +syntax = "proto3"; + +package google.api; + +option cc_enable_arenas = true; +option go_package = "google.golang.org/genproto/googleapis/api/annotations;annotations"; +option java_multiple_files = true; +option java_outer_classname = "HttpProto"; +option java_package = "com.google.api"; +option objc_class_prefix = "GAPI"; + +// Defines the HTTP configuration for an API service. It contains a list of +// [HttpRule][google.api.HttpRule], each specifying the mapping of an RPC method +// to one or more HTTP REST API methods. +message Http { + // A list of HTTP configuration rules that apply to individual API methods. + // + // **NOTE:** All service configuration rules follow "last one wins" order. + repeated HttpRule rules = 1; + + // When set to true, URL path parameters will be fully URI-decoded except in + // cases of single segment matches in reserved expansion, where "%2F" will be + // left encoded. + // + // The default behavior is to not decode RFC 6570 reserved characters in multi + // segment matches. + bool fully_decode_reserved_expansion = 2; +} + +// # gRPC Transcoding +// +// gRPC Transcoding is a feature for mapping between a gRPC method and one or +// more HTTP REST endpoints. It allows developers to build a single API service +// that supports both gRPC APIs and REST APIs. Many systems, including [Google +// APIs](https://github.com/googleapis/googleapis), +// [Cloud Endpoints](https://cloud.google.com/endpoints), [gRPC +// Gateway](https://github.com/grpc-ecosystem/grpc-gateway), +// and [Envoy](https://github.com/envoyproxy/envoy) proxy support this feature +// and use it for large scale production services. +// +// `HttpRule` defines the schema of the gRPC/REST mapping. The mapping specifies +// how different portions of the gRPC request message are mapped to the URL +// path, URL query parameters, and HTTP request body. It also controls how the +// gRPC response message is mapped to the HTTP response body. `HttpRule` is +// typically specified as an `google.api.http` annotation on the gRPC method. +// +// Each mapping specifies a URL path template and an HTTP method. The path +// template may refer to one or more fields in the gRPC request message, as long +// as each field is a non-repeated field with a primitive (non-message) type. +// The path template controls how fields of the request message are mapped to +// the URL path. +// +// Example: +// +// service Messaging { +// rpc GetMessage(GetMessageRequest) returns (Message) { +// option (google.api.http) = { +// get: "/v1/{name=messages/*}" +// }; +// } +// } +// message GetMessageRequest { +// string name = 1; // Mapped to URL path. +// } +// message Message { +// string text = 1; // The resource content. +// } +// +// This enables an HTTP REST to gRPC mapping as below: +// +// HTTP | gRPC +// -----|----- +// `GET /v1/messages/123456` | `GetMessage(name: "messages/123456")` +// +// Any fields in the request message which are not bound by the path template +// automatically become HTTP query parameters if there is no HTTP request body. +// For example: +// +// service Messaging { +// rpc GetMessage(GetMessageRequest) returns (Message) { +// option (google.api.http) = { +// get:"/v1/messages/{message_id}" +// }; +// } +// } +// message GetMessageRequest { +// message SubMessage { +// string subfield = 1; +// } +// string message_id = 1; // Mapped to URL path. +// int64 revision = 2; // Mapped to URL query parameter `revision`. +// SubMessage sub = 3; // Mapped to URL query parameter `sub.subfield`. +// } +// +// This enables a HTTP JSON to RPC mapping as below: +// +// HTTP | gRPC +// -----|----- +// `GET /v1/messages/123456?revision=2&sub.subfield=foo` | +// `GetMessage(message_id: "123456" revision: 2 sub: SubMessage(subfield: +// "foo"))` +// +// Note that fields which are mapped to URL query parameters must have a +// primitive type or a repeated primitive type or a non-repeated message type. +// In the case of a repeated type, the parameter can be repeated in the URL +// as `...?param=A¶m=B`. In the case of a message type, each field of the +// message is mapped to a separate parameter, such as +// `...?foo.a=A&foo.b=B&foo.c=C`. +// +// For HTTP methods that allow a request body, the `body` field +// specifies the mapping. Consider a REST update method on the +// message resource collection: +// +// service Messaging { +// rpc UpdateMessage(UpdateMessageRequest) returns (Message) { +// option (google.api.http) = { +// patch: "/v1/messages/{message_id}" +// body: "message" +// }; +// } +// } +// message UpdateMessageRequest { +// string message_id = 1; // mapped to the URL +// Message message = 2; // mapped to the body +// } +// +// The following HTTP JSON to RPC mapping is enabled, where the +// representation of the JSON in the request body is determined by +// protos JSON encoding: +// +// HTTP | gRPC +// -----|----- +// `PATCH /v1/messages/123456 { "text": "Hi!" }` | `UpdateMessage(message_id: +// "123456" message { text: "Hi!" })` +// +// The special name `*` can be used in the body mapping to define that +// every field not bound by the path template should be mapped to the +// request body. This enables the following alternative definition of +// the update method: +// +// service Messaging { +// rpc UpdateMessage(Message) returns (Message) { +// option (google.api.http) = { +// patch: "/v1/messages/{message_id}" +// body: "*" +// }; +// } +// } +// message Message { +// string message_id = 1; +// string text = 2; +// } +// +// +// The following HTTP JSON to RPC mapping is enabled: +// +// HTTP | gRPC +// -----|----- +// `PATCH /v1/messages/123456 { "text": "Hi!" }` | `UpdateMessage(message_id: +// "123456" text: "Hi!")` +// +// Note that when using `*` in the body mapping, it is not possible to +// have HTTP parameters, as all fields not bound by the path end in +// the body. This makes this option more rarely used in practice when +// defining REST APIs. The common usage of `*` is in custom methods +// which don't use the URL at all for transferring data. +// +// It is possible to define multiple HTTP methods for one RPC by using +// the `additional_bindings` option. Example: +// +// service Messaging { +// rpc GetMessage(GetMessageRequest) returns (Message) { +// option (google.api.http) = { +// get: "/v1/messages/{message_id}" +// additional_bindings { +// get: "/v1/users/{user_id}/messages/{message_id}" +// } +// }; +// } +// } +// message GetMessageRequest { +// string message_id = 1; +// string user_id = 2; +// } +// +// This enables the following two alternative HTTP JSON to RPC mappings: +// +// HTTP | gRPC +// -----|----- +// `GET /v1/messages/123456` | `GetMessage(message_id: "123456")` +// `GET /v1/users/me/messages/123456` | `GetMessage(user_id: "me" message_id: +// "123456")` +// +// ## Rules for HTTP mapping +// +// 1. Leaf request fields (recursive expansion nested messages in the request +// message) are classified into three categories: +// - Fields referred by the path template. They are passed via the URL path. +// - Fields referred by the [HttpRule.body][google.api.HttpRule.body]. They are passed via the HTTP +// request body. +// - All other fields are passed via the URL query parameters, and the +// parameter name is the field path in the request message. A repeated +// field can be represented as multiple query parameters under the same +// name. +// 2. If [HttpRule.body][google.api.HttpRule.body] is "*", there is no URL query parameter, all fields +// are passed via URL path and HTTP request body. +// 3. If [HttpRule.body][google.api.HttpRule.body] is omitted, there is no HTTP request body, all +// fields are passed via URL path and URL query parameters. +// +// ### Path template syntax +// +// Template = "/" Segments [ Verb ] ; +// Segments = Segment { "/" Segment } ; +// Segment = "*" | "**" | LITERAL | Variable ; +// Variable = "{" FieldPath [ "=" Segments ] "}" ; +// FieldPath = IDENT { "." IDENT } ; +// Verb = ":" LITERAL ; +// +// The syntax `*` matches a single URL path segment. The syntax `**` matches +// zero or more URL path segments, which must be the last part of the URL path +// except the `Verb`. +// +// The syntax `Variable` matches part of the URL path as specified by its +// template. A variable template must not contain other variables. If a variable +// matches a single path segment, its template may be omitted, e.g. `{var}` +// is equivalent to `{var=*}`. +// +// The syntax `LITERAL` matches literal text in the URL path. If the `LITERAL` +// contains any reserved character, such characters should be percent-encoded +// before the matching. +// +// If a variable contains exactly one path segment, such as `"{var}"` or +// `"{var=*}"`, when such a variable is expanded into a URL path on the client +// side, all characters except `[-_.~0-9a-zA-Z]` are percent-encoded. The +// server side does the reverse decoding. Such variables show up in the +// [Discovery +// Document](https://developers.google.com/discovery/v1/reference/apis) as +// `{var}`. +// +// If a variable contains multiple path segments, such as `"{var=foo/*}"` +// or `"{var=**}"`, when such a variable is expanded into a URL path on the +// client side, all characters except `[-_.~/0-9a-zA-Z]` are percent-encoded. +// The server side does the reverse decoding, except "%2F" and "%2f" are left +// unchanged. Such variables show up in the +// [Discovery +// Document](https://developers.google.com/discovery/v1/reference/apis) as +// `{+var}`. +// +// ## Using gRPC API Service Configuration +// +// gRPC API Service Configuration (service config) is a configuration language +// for configuring a gRPC service to become a user-facing product. The +// service config is simply the YAML representation of the `google.api.Service` +// proto message. +// +// As an alternative to annotating your proto file, you can configure gRPC +// transcoding in your service config YAML files. You do this by specifying a +// `HttpRule` that maps the gRPC method to a REST endpoint, achieving the same +// effect as the proto annotation. This can be particularly useful if you +// have a proto that is reused in multiple services. Note that any transcoding +// specified in the service config will override any matching transcoding +// configuration in the proto. +// +// Example: +// +// http: +// rules: +// # Selects a gRPC method and applies HttpRule to it. +// - selector: example.v1.Messaging.GetMessage +// get: /v1/messages/{message_id}/{sub.subfield} +// +// ## Special notes +// +// When gRPC Transcoding is used to map a gRPC to JSON REST endpoints, the +// proto to JSON conversion must follow the [proto3 +// specification](https://developers.google.com/protocol-buffers/docs/proto3#json). +// +// While the single segment variable follows the semantics of +// [RFC 6570](https://tools.ietf.org/html/rfc6570) Section 3.2.2 Simple String +// Expansion, the multi segment variable **does not** follow RFC 6570 Section +// 3.2.3 Reserved Expansion. The reason is that the Reserved Expansion +// does not expand special characters like `?` and `#`, which would lead +// to invalid URLs. As the result, gRPC Transcoding uses a custom encoding +// for multi segment variables. +// +// The path variables **must not** refer to any repeated or mapped field, +// because client libraries are not capable of handling such variable expansion. +// +// The path variables **must not** capture the leading "/" character. The reason +// is that the most common use case "{var}" does not capture the leading "/" +// character. For consistency, all path variables must share the same behavior. +// +// Repeated message fields must not be mapped to URL query parameters, because +// no client library can support such complicated mapping. +// +// If an API needs to use a JSON array for request or response body, it can map +// the request or response body to a repeated field. However, some gRPC +// Transcoding implementations may not support this feature. +message HttpRule { + // Selects a method to which this rule applies. + // + // Refer to [selector][google.api.DocumentationRule.selector] for syntax details. + string selector = 1; + + // Determines the URL pattern is matched by this rules. This pattern can be + // used with any of the {get|put|post|delete|patch} methods. A custom method + // can be defined using the 'custom' field. + oneof pattern { + // Maps to HTTP GET. Used for listing and getting information about + // resources. + string get = 2; + + // Maps to HTTP PUT. Used for replacing a resource. + string put = 3; + + // Maps to HTTP POST. Used for creating a resource or performing an action. + string post = 4; + + // Maps to HTTP DELETE. Used for deleting a resource. + string delete = 5; + + // Maps to HTTP PATCH. Used for updating a resource. + string patch = 6; + + // The custom pattern is used for specifying an HTTP method that is not + // included in the `pattern` field, such as HEAD, or "*" to leave the + // HTTP method unspecified for this rule. The wild-card rule is useful + // for services that provide content to Web (HTML) clients. + CustomHttpPattern custom = 8; + } + + // The name of the request field whose value is mapped to the HTTP request + // body, or `*` for mapping all request fields not captured by the path + // pattern to the HTTP body, or omitted for not having any HTTP request body. + // + // NOTE: the referred field must be present at the top-level of the request + // message type. + string body = 7; + + // Optional. The name of the response field whose value is mapped to the HTTP + // response body. When omitted, the entire response message will be used + // as the HTTP response body. + // + // NOTE: The referred field must be present at the top-level of the response + // message type. + string response_body = 12; + + // Additional HTTP bindings for the selector. Nested bindings must + // not contain an `additional_bindings` field themselves (that is, + // the nesting may only be one level deep). + repeated HttpRule additional_bindings = 11; +} + +// A custom pattern is used for defining custom HTTP verb. +message CustomHttpPattern { + // The name of this custom HTTP verb. + string kind = 1; + + // The path matched by this custom verb. + string path = 2; +} diff --git a/hs-iavl-client/protos/google/protobuf/descriptor.proto b/hs-iavl-client/protos/google/protobuf/descriptor.proto new file mode 100644 index 00000000..8c1273db --- /dev/null +++ b/hs-iavl-client/protos/google/protobuf/descriptor.proto @@ -0,0 +1,882 @@ +// Protocol Buffers - Google's data interchange format +// Copyright 2008 Google Inc. All rights reserved. +// https://developers.google.com/protocol-buffers/ +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are +// met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following disclaimer +// in the documentation and/or other materials provided with the +// distribution. +// * Neither the name of Google Inc. nor the names of its +// contributors may be used to endorse or promote products derived from +// this software without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +// OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +// SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +// LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +// DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +// THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +// (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +// Author: kenton@google.com (Kenton Varda) +// Based on original Protocol Buffers design by +// Sanjay Ghemawat, Jeff Dean, and others. +// +// The messages in this file describe the definitions found in .proto files. +// A valid .proto file can be translated directly to a FileDescriptorProto +// without any other information (e.g. without reading its imports). + + +syntax = "proto2"; + +package google.protobuf; +option go_package = "github.com/golang/protobuf/protoc-gen-go/descriptor;descriptor"; +option java_package = "com.google.protobuf"; +option java_outer_classname = "DescriptorProtos"; +option csharp_namespace = "Google.Protobuf.Reflection"; +option objc_class_prefix = "GPB"; +option cc_enable_arenas = true; + +// descriptor.proto must be optimized for speed because reflection-based +// algorithms don't work during bootstrapping. +option optimize_for = SPEED; + +// The protocol compiler can output a FileDescriptorSet containing the .proto +// files it parses. +message FileDescriptorSet { + repeated FileDescriptorProto file = 1; +} + +// Describes a complete .proto file. +message FileDescriptorProto { + optional string name = 1; // file name, relative to root of source tree + optional string package = 2; // e.g. "foo", "foo.bar", etc. + + // Names of files imported by this file. + repeated string dependency = 3; + // Indexes of the public imported files in the dependency list above. + repeated int32 public_dependency = 10; + // Indexes of the weak imported files in the dependency list. + // For Google-internal migration only. Do not use. + repeated int32 weak_dependency = 11; + + // All top-level definitions in this file. + repeated DescriptorProto message_type = 4; + repeated EnumDescriptorProto enum_type = 5; + repeated ServiceDescriptorProto service = 6; + repeated FieldDescriptorProto extension = 7; + + optional FileOptions options = 8; + + // This field contains optional information about the original source code. + // You may safely remove this entire field without harming runtime + // functionality of the descriptors -- the information is needed only by + // development tools. + optional SourceCodeInfo source_code_info = 9; + + // The syntax of the proto file. + // The supported values are "proto2" and "proto3". + optional string syntax = 12; +} + +// Describes a message type. +message DescriptorProto { + optional string name = 1; + + repeated FieldDescriptorProto field = 2; + repeated FieldDescriptorProto extension = 6; + + repeated DescriptorProto nested_type = 3; + repeated EnumDescriptorProto enum_type = 4; + + message ExtensionRange { + optional int32 start = 1; + optional int32 end = 2; + + optional ExtensionRangeOptions options = 3; + } + repeated ExtensionRange extension_range = 5; + + repeated OneofDescriptorProto oneof_decl = 8; + + optional MessageOptions options = 7; + + // Range of reserved tag numbers. Reserved tag numbers may not be used by + // fields or extension ranges in the same message. Reserved ranges may + // not overlap. + message ReservedRange { + optional int32 start = 1; // Inclusive. + optional int32 end = 2; // Exclusive. + } + repeated ReservedRange reserved_range = 9; + // Reserved field names, which may not be used by fields in the same message. + // A given name may only be reserved once. + repeated string reserved_name = 10; +} + +message ExtensionRangeOptions { + // The parser stores options it doesn't recognize here. See above. + repeated UninterpretedOption uninterpreted_option = 999; + + // Clients can define custom options in extensions of this message. See above. + extensions 1000 to max; +} + +// Describes a field within a message. +message FieldDescriptorProto { + enum Type { + // 0 is reserved for errors. + // Order is weird for historical reasons. + TYPE_DOUBLE = 1; + TYPE_FLOAT = 2; + // Not ZigZag encoded. Negative numbers take 10 bytes. Use TYPE_SINT64 if + // negative values are likely. + TYPE_INT64 = 3; + TYPE_UINT64 = 4; + // Not ZigZag encoded. Negative numbers take 10 bytes. Use TYPE_SINT32 if + // negative values are likely. + TYPE_INT32 = 5; + TYPE_FIXED64 = 6; + TYPE_FIXED32 = 7; + TYPE_BOOL = 8; + TYPE_STRING = 9; + // Tag-delimited aggregate. + // Group type is deprecated and not supported in proto3. However, Proto3 + // implementations should still be able to parse the group wire format and + // treat group fields as unknown fields. + TYPE_GROUP = 10; + TYPE_MESSAGE = 11; // Length-delimited aggregate. + + // New in version 2. + TYPE_BYTES = 12; + TYPE_UINT32 = 13; + TYPE_ENUM = 14; + TYPE_SFIXED32 = 15; + TYPE_SFIXED64 = 16; + TYPE_SINT32 = 17; // Uses ZigZag encoding. + TYPE_SINT64 = 18; // Uses ZigZag encoding. + }; + + enum Label { + // 0 is reserved for errors + LABEL_OPTIONAL = 1; + LABEL_REQUIRED = 2; + LABEL_REPEATED = 3; + }; + + optional string name = 1; + optional int32 number = 3; + optional Label label = 4; + + // If type_name is set, this need not be set. If both this and type_name + // are set, this must be one of TYPE_ENUM, TYPE_MESSAGE or TYPE_GROUP. + optional Type type = 5; + + // For message and enum types, this is the name of the type. If the name + // starts with a '.', it is fully-qualified. Otherwise, C++-like scoping + // rules are used to find the type (i.e. first the nested types within this + // message are searched, then within the parent, on up to the root + // namespace). + optional string type_name = 6; + + // For extensions, this is the name of the type being extended. It is + // resolved in the same manner as type_name. + optional string extendee = 2; + + // For numeric types, contains the original text representation of the value. + // For booleans, "true" or "false". + // For strings, contains the default text contents (not escaped in any way). + // For bytes, contains the C escaped value. All bytes >= 128 are escaped. + // TODO(kenton): Base-64 encode? + optional string default_value = 7; + + // If set, gives the index of a oneof in the containing type's oneof_decl + // list. This field is a member of that oneof. + optional int32 oneof_index = 9; + + // JSON name of this field. The value is set by protocol compiler. If the + // user has set a "json_name" option on this field, that option's value + // will be used. Otherwise, it's deduced from the field's name by converting + // it to camelCase. + optional string json_name = 10; + + optional FieldOptions options = 8; +} + +// Describes a oneof. +message OneofDescriptorProto { + optional string name = 1; + optional OneofOptions options = 2; +} + +// Describes an enum type. +message EnumDescriptorProto { + optional string name = 1; + + repeated EnumValueDescriptorProto value = 2; + + optional EnumOptions options = 3; + + // Range of reserved numeric values. Reserved values may not be used by + // entries in the same enum. Reserved ranges may not overlap. + // + // Note that this is distinct from DescriptorProto.ReservedRange in that it + // is inclusive such that it can appropriately represent the entire int32 + // domain. + message EnumReservedRange { + optional int32 start = 1; // Inclusive. + optional int32 end = 2; // Inclusive. + } + + // Range of reserved numeric values. Reserved numeric values may not be used + // by enum values in the same enum declaration. Reserved ranges may not + // overlap. + repeated EnumReservedRange reserved_range = 4; + + // Reserved enum value names, which may not be reused. A given name may only + // be reserved once. + repeated string reserved_name = 5; +} + +// Describes a value within an enum. +message EnumValueDescriptorProto { + optional string name = 1; + optional int32 number = 2; + + optional EnumValueOptions options = 3; +} + +// Describes a service. +message ServiceDescriptorProto { + optional string name = 1; + repeated MethodDescriptorProto method = 2; + + optional ServiceOptions options = 3; +} + +// Describes a method of a service. +message MethodDescriptorProto { + optional string name = 1; + + // Input and output type names. These are resolved in the same way as + // FieldDescriptorProto.type_name, but must refer to a message type. + optional string input_type = 2; + optional string output_type = 3; + + optional MethodOptions options = 4; + + // Identifies if client streams multiple client messages + optional bool client_streaming = 5 [default=false]; + // Identifies if server streams multiple server messages + optional bool server_streaming = 6 [default=false]; +} + + +// =================================================================== +// Options + +// Each of the definitions above may have "options" attached. These are +// just annotations which may cause code to be generated slightly differently +// or may contain hints for code that manipulates protocol messages. +// +// Clients may define custom options as extensions of the *Options messages. +// These extensions may not yet be known at parsing time, so the parser cannot +// store the values in them. Instead it stores them in a field in the *Options +// message called uninterpreted_option. This field must have the same name +// across all *Options messages. We then use this field to populate the +// extensions when we build a descriptor, at which point all protos have been +// parsed and so all extensions are known. +// +// Extension numbers for custom options may be chosen as follows: +// * For options which will only be used within a single application or +// organization, or for experimental options, use field numbers 50000 +// through 99999. It is up to you to ensure that you do not use the +// same number for multiple options. +// * For options which will be published and used publicly by multiple +// independent entities, e-mail protobuf-global-extension-registry@google.com +// to reserve extension numbers. Simply provide your project name (e.g. +// Objective-C plugin) and your project website (if available) -- there's no +// need to explain how you intend to use them. Usually you only need one +// extension number. You can declare multiple options with only one extension +// number by putting them in a sub-message. See the Custom Options section of +// the docs for examples: +// https://developers.google.com/protocol-buffers/docs/proto#options +// If this turns out to be popular, a web service will be set up +// to automatically assign option numbers. + + +message FileOptions { + + // Sets the Java package where classes generated from this .proto will be + // placed. By default, the proto package is used, but this is often + // inappropriate because proto packages do not normally start with backwards + // domain names. + optional string java_package = 1; + + + // If set, all the classes from the .proto file are wrapped in a single + // outer class with the given name. This applies to both Proto1 + // (equivalent to the old "--one_java_file" option) and Proto2 (where + // a .proto always translates to a single class, but you may want to + // explicitly choose the class name). + optional string java_outer_classname = 8; + + // If set true, then the Java code generator will generate a separate .java + // file for each top-level message, enum, and service defined in the .proto + // file. Thus, these types will *not* be nested inside the outer class + // named by java_outer_classname. However, the outer class will still be + // generated to contain the file's getDescriptor() method as well as any + // top-level extensions defined in the file. + optional bool java_multiple_files = 10 [default=false]; + + // This option does nothing. + optional bool java_generate_equals_and_hash = 20 [deprecated=true]; + + // If set true, then the Java2 code generator will generate code that + // throws an exception whenever an attempt is made to assign a non-UTF-8 + // byte sequence to a string field. + // Message reflection will do the same. + // However, an extension field still accepts non-UTF-8 byte sequences. + // This option has no effect on when used with the lite runtime. + optional bool java_string_check_utf8 = 27 [default=false]; + + + // Generated classes can be optimized for speed or code size. + enum OptimizeMode { + SPEED = 1; // Generate complete code for parsing, serialization, + // etc. + CODE_SIZE = 2; // Use ReflectionOps to implement these methods. + LITE_RUNTIME = 3; // Generate code using MessageLite and the lite runtime. + } + optional OptimizeMode optimize_for = 9 [default=SPEED]; + + // Sets the Go package where structs generated from this .proto will be + // placed. If omitted, the Go package will be derived from the following: + // - The basename of the package import path, if provided. + // - Otherwise, the package statement in the .proto file, if present. + // - Otherwise, the basename of the .proto file, without extension. + optional string go_package = 11; + + + + // Should generic services be generated in each language? "Generic" services + // are not specific to any particular RPC system. They are generated by the + // main code generators in each language (without additional plugins). + // Generic services were the only kind of service generation supported by + // early versions of google.protobuf. + // + // Generic services are now considered deprecated in favor of using plugins + // that generate code specific to your particular RPC system. Therefore, + // these default to false. Old code which depends on generic services should + // explicitly set them to true. + optional bool cc_generic_services = 16 [default=false]; + optional bool java_generic_services = 17 [default=false]; + optional bool py_generic_services = 18 [default=false]; + optional bool php_generic_services = 42 [default=false]; + + // Is this file deprecated? + // Depending on the target platform, this can emit Deprecated annotations + // for everything in the file, or it will be completely ignored; in the very + // least, this is a formalization for deprecating files. + optional bool deprecated = 23 [default=false]; + + // Enables the use of arenas for the proto messages in this file. This applies + // only to generated classes for C++. + optional bool cc_enable_arenas = 31 [default=false]; + + + // Sets the objective c class prefix which is prepended to all objective c + // generated classes from this .proto. There is no default. + optional string objc_class_prefix = 36; + + // Namespace for generated classes; defaults to the package. + optional string csharp_namespace = 37; + + // By default Swift generators will take the proto package and CamelCase it + // replacing '.' with underscore and use that to prefix the types/symbols + // defined. When this options is provided, they will use this value instead + // to prefix the types/symbols defined. + optional string swift_prefix = 39; + + // Sets the php class prefix which is prepended to all php generated classes + // from this .proto. Default is empty. + optional string php_class_prefix = 40; + + // Use this option to change the namespace of php generated classes. Default + // is empty. When this option is empty, the package name will be used for + // determining the namespace. + optional string php_namespace = 41; + + // Use this option to change the namespace of php generated metadata classes. + // Default is empty. When this option is empty, the proto file name will be used + // for determining the namespace. + optional string php_metadata_namespace = 44; + + // Use this option to change the package of ruby generated classes. Default + // is empty. When this option is not set, the package name will be used for + // determining the ruby package. + optional string ruby_package = 45; + + // The parser stores options it doesn't recognize here. + // See the documentation for the "Options" section above. + repeated UninterpretedOption uninterpreted_option = 999; + + // Clients can define custom options in extensions of this message. + // See the documentation for the "Options" section above. + extensions 1000 to max; + + reserved 38; +} + +message MessageOptions { + // Set true to use the old proto1 MessageSet wire format for extensions. + // This is provided for backwards-compatibility with the MessageSet wire + // format. You should not use this for any other reason: It's less + // efficient, has fewer features, and is more complicated. + // + // The message must be defined exactly as follows: + // message Foo { + // option message_set_wire_format = true; + // extensions 4 to max; + // } + // Note that the message cannot have any defined fields; MessageSets only + // have extensions. + // + // All extensions of your type must be singular messages; e.g. they cannot + // be int32s, enums, or repeated messages. + // + // Because this is an option, the above two restrictions are not enforced by + // the protocol compiler. + optional bool message_set_wire_format = 1 [default=false]; + + // Disables the generation of the standard "descriptor()" accessor, which can + // conflict with a field of the same name. This is meant to make migration + // from proto1 easier; new code should avoid fields named "descriptor". + optional bool no_standard_descriptor_accessor = 2 [default=false]; + + // Is this message deprecated? + // Depending on the target platform, this can emit Deprecated annotations + // for the message, or it will be completely ignored; in the very least, + // this is a formalization for deprecating messages. + optional bool deprecated = 3 [default=false]; + + // Whether the message is an automatically generated map entry type for the + // maps field. + // + // For maps fields: + // map map_field = 1; + // The parsed descriptor looks like: + // message MapFieldEntry { + // option map_entry = true; + // optional KeyType key = 1; + // optional ValueType value = 2; + // } + // repeated MapFieldEntry map_field = 1; + // + // Implementations may choose not to generate the map_entry=true message, but + // use a native map in the target language to hold the keys and values. + // The reflection APIs in such implementations still need to work as + // if the field is a repeated message field. + // + // NOTE: Do not set the option in .proto files. Always use the maps syntax + // instead. The option should only be implicitly set by the proto compiler + // parser. + optional bool map_entry = 7; + + reserved 8; // javalite_serializable + reserved 9; // javanano_as_lite + + // The parser stores options it doesn't recognize here. See above. + repeated UninterpretedOption uninterpreted_option = 999; + + // Clients can define custom options in extensions of this message. See above. + extensions 1000 to max; +} + +message FieldOptions { + // The ctype option instructs the C++ code generator to use a different + // representation of the field than it normally would. See the specific + // options below. This option is not yet implemented in the open source + // release -- sorry, we'll try to include it in a future version! + optional CType ctype = 1 [default = STRING]; + enum CType { + // Default mode. + STRING = 0; + + CORD = 1; + + STRING_PIECE = 2; + } + // The packed option can be enabled for repeated primitive fields to enable + // a more efficient representation on the wire. Rather than repeatedly + // writing the tag and type for each element, the entire array is encoded as + // a single length-delimited blob. In proto3, only explicit setting it to + // false will avoid using packed encoding. + optional bool packed = 2; + + // The jstype option determines the JavaScript type used for values of the + // field. The option is permitted only for 64 bit integral and fixed types + // (int64, uint64, sint64, fixed64, sfixed64). A field with jstype JS_STRING + // is represented as JavaScript string, which avoids loss of precision that + // can happen when a large value is converted to a floating point JavaScript. + // Specifying JS_NUMBER for the jstype causes the generated JavaScript code to + // use the JavaScript "number" type. The behavior of the default option + // JS_NORMAL is implementation dependent. + // + // This option is an enum to permit additional types to be added, e.g. + // goog.math.Integer. + optional JSType jstype = 6 [default = JS_NORMAL]; + enum JSType { + // Use the default type. + JS_NORMAL = 0; + + // Use JavaScript strings. + JS_STRING = 1; + + // Use JavaScript numbers. + JS_NUMBER = 2; + } + + // Should this field be parsed lazily? Lazy applies only to message-type + // fields. It means that when the outer message is initially parsed, the + // inner message's contents will not be parsed but instead stored in encoded + // form. The inner message will actually be parsed when it is first accessed. + // + // This is only a hint. Implementations are free to choose whether to use + // eager or lazy parsing regardless of the value of this option. However, + // setting this option true suggests that the protocol author believes that + // using lazy parsing on this field is worth the additional bookkeeping + // overhead typically needed to implement it. + // + // This option does not affect the public interface of any generated code; + // all method signatures remain the same. Furthermore, thread-safety of the + // interface is not affected by this option; const methods remain safe to + // call from multiple threads concurrently, while non-const methods continue + // to require exclusive access. + // + // + // Note that implementations may choose not to check required fields within + // a lazy sub-message. That is, calling IsInitialized() on the outer message + // may return true even if the inner message has missing required fields. + // This is necessary because otherwise the inner message would have to be + // parsed in order to perform the check, defeating the purpose of lazy + // parsing. An implementation which chooses not to check required fields + // must be consistent about it. That is, for any particular sub-message, the + // implementation must either *always* check its required fields, or *never* + // check its required fields, regardless of whether or not the message has + // been parsed. + optional bool lazy = 5 [default=false]; + + // Is this field deprecated? + // Depending on the target platform, this can emit Deprecated annotations + // for accessors, or it will be completely ignored; in the very least, this + // is a formalization for deprecating fields. + optional bool deprecated = 3 [default=false]; + + // For Google-internal migration only. Do not use. + optional bool weak = 10 [default=false]; + + + // The parser stores options it doesn't recognize here. See above. + repeated UninterpretedOption uninterpreted_option = 999; + + // Clients can define custom options in extensions of this message. See above. + extensions 1000 to max; + + reserved 4; // removed jtype +} + +message OneofOptions { + // The parser stores options it doesn't recognize here. See above. + repeated UninterpretedOption uninterpreted_option = 999; + + // Clients can define custom options in extensions of this message. See above. + extensions 1000 to max; +} + +message EnumOptions { + + // Set this option to true to allow mapping different tag names to the same + // value. + optional bool allow_alias = 2; + + // Is this enum deprecated? + // Depending on the target platform, this can emit Deprecated annotations + // for the enum, or it will be completely ignored; in the very least, this + // is a formalization for deprecating enums. + optional bool deprecated = 3 [default=false]; + + reserved 5; // javanano_as_lite + + // The parser stores options it doesn't recognize here. See above. + repeated UninterpretedOption uninterpreted_option = 999; + + // Clients can define custom options in extensions of this message. See above. + extensions 1000 to max; +} + +message EnumValueOptions { + // Is this enum value deprecated? + // Depending on the target platform, this can emit Deprecated annotations + // for the enum value, or it will be completely ignored; in the very least, + // this is a formalization for deprecating enum values. + optional bool deprecated = 1 [default=false]; + + // The parser stores options it doesn't recognize here. See above. + repeated UninterpretedOption uninterpreted_option = 999; + + // Clients can define custom options in extensions of this message. See above. + extensions 1000 to max; +} + +message ServiceOptions { + + // Note: Field numbers 1 through 32 are reserved for Google's internal RPC + // framework. We apologize for hoarding these numbers to ourselves, but + // we were already using them long before we decided to release Protocol + // Buffers. + + // Is this service deprecated? + // Depending on the target platform, this can emit Deprecated annotations + // for the service, or it will be completely ignored; in the very least, + // this is a formalization for deprecating services. + optional bool deprecated = 33 [default=false]; + + // The parser stores options it doesn't recognize here. See above. + repeated UninterpretedOption uninterpreted_option = 999; + + // Clients can define custom options in extensions of this message. See above. + extensions 1000 to max; +} + +message MethodOptions { + + // Note: Field numbers 1 through 32 are reserved for Google's internal RPC + // framework. We apologize for hoarding these numbers to ourselves, but + // we were already using them long before we decided to release Protocol + // Buffers. + + // Is this method deprecated? + // Depending on the target platform, this can emit Deprecated annotations + // for the method, or it will be completely ignored; in the very least, + // this is a formalization for deprecating methods. + optional bool deprecated = 33 [default=false]; + + // Is this method side-effect-free (or safe in HTTP parlance), or idempotent, + // or neither? HTTP based RPC implementation may choose GET verb for safe + // methods, and PUT verb for idempotent methods instead of the default POST. + enum IdempotencyLevel { + IDEMPOTENCY_UNKNOWN = 0; + NO_SIDE_EFFECTS = 1; // implies idempotent + IDEMPOTENT = 2; // idempotent, but may have side effects + } + optional IdempotencyLevel idempotency_level = + 34 [default=IDEMPOTENCY_UNKNOWN]; + + // The parser stores options it doesn't recognize here. See above. + repeated UninterpretedOption uninterpreted_option = 999; + + // Clients can define custom options in extensions of this message. See above. + extensions 1000 to max; +} + + +// A message representing a option the parser does not recognize. This only +// appears in options protos created by the compiler::Parser class. +// DescriptorPool resolves these when building Descriptor objects. Therefore, +// options protos in descriptor objects (e.g. returned by Descriptor::options(), +// or produced by Descriptor::CopyTo()) will never have UninterpretedOptions +// in them. +message UninterpretedOption { + // The name of the uninterpreted option. Each string represents a segment in + // a dot-separated name. is_extension is true iff a segment represents an + // extension (denoted with parentheses in options specs in .proto files). + // E.g.,{ ["foo", false], ["bar.baz", true], ["qux", false] } represents + // "foo.(bar.baz).qux". + message NamePart { + required string name_part = 1; + required bool is_extension = 2; + } + repeated NamePart name = 2; + + // The value of the uninterpreted option, in whatever type the tokenizer + // identified it as during parsing. Exactly one of these should be set. + optional string identifier_value = 3; + optional uint64 positive_int_value = 4; + optional int64 negative_int_value = 5; + optional double double_value = 6; + optional bytes string_value = 7; + optional string aggregate_value = 8; +} + +// =================================================================== +// Optional source code info + +// Encapsulates information about the original source file from which a +// FileDescriptorProto was generated. +message SourceCodeInfo { + // A Location identifies a piece of source code in a .proto file which + // corresponds to a particular definition. This information is intended + // to be useful to IDEs, code indexers, documentation generators, and similar + // tools. + // + // For example, say we have a file like: + // message Foo { + // optional string foo = 1; + // } + // Let's look at just the field definition: + // optional string foo = 1; + // ^ ^^ ^^ ^ ^^^ + // a bc de f ghi + // We have the following locations: + // span path represents + // [a,i) [ 4, 0, 2, 0 ] The whole field definition. + // [a,b) [ 4, 0, 2, 0, 4 ] The label (optional). + // [c,d) [ 4, 0, 2, 0, 5 ] The type (string). + // [e,f) [ 4, 0, 2, 0, 1 ] The name (foo). + // [g,h) [ 4, 0, 2, 0, 3 ] The number (1). + // + // Notes: + // - A location may refer to a repeated field itself (i.e. not to any + // particular index within it). This is used whenever a set of elements are + // logically enclosed in a single code segment. For example, an entire + // extend block (possibly containing multiple extension definitions) will + // have an outer location whose path refers to the "extensions" repeated + // field without an index. + // - Multiple locations may have the same path. This happens when a single + // logical declaration is spread out across multiple places. The most + // obvious example is the "extend" block again -- there may be multiple + // extend blocks in the same scope, each of which will have the same path. + // - A location's span is not always a subset of its parent's span. For + // example, the "extendee" of an extension declaration appears at the + // beginning of the "extend" block and is shared by all extensions within + // the block. + // - Just because a location's span is a subset of some other location's span + // does not mean that it is a descendant. For example, a "group" defines + // both a type and a field in a single declaration. Thus, the locations + // corresponding to the type and field and their components will overlap. + // - Code which tries to interpret locations should probably be designed to + // ignore those that it doesn't understand, as more types of locations could + // be recorded in the future. + repeated Location location = 1; + message Location { + // Identifies which part of the FileDescriptorProto was defined at this + // location. + // + // Each element is a field number or an index. They form a path from + // the root FileDescriptorProto to the place where the definition. For + // example, this path: + // [ 4, 3, 2, 7, 1 ] + // refers to: + // file.message_type(3) // 4, 3 + // .field(7) // 2, 7 + // .name() // 1 + // This is because FileDescriptorProto.message_type has field number 4: + // repeated DescriptorProto message_type = 4; + // and DescriptorProto.field has field number 2: + // repeated FieldDescriptorProto field = 2; + // and FieldDescriptorProto.name has field number 1: + // optional string name = 1; + // + // Thus, the above path gives the location of a field name. If we removed + // the last element: + // [ 4, 3, 2, 7 ] + // this path refers to the whole field declaration (from the beginning + // of the label to the terminating semicolon). + repeated int32 path = 1 [packed=true]; + + // Always has exactly three or four elements: start line, start column, + // end line (optional, otherwise assumed same as start line), end column. + // These are packed into a single field for efficiency. Note that line + // and column numbers are zero-based -- typically you will want to add + // 1 to each before displaying to a user. + repeated int32 span = 2 [packed=true]; + + // If this SourceCodeInfo represents a complete declaration, these are any + // comments appearing before and after the declaration which appear to be + // attached to the declaration. + // + // A series of line comments appearing on consecutive lines, with no other + // tokens appearing on those lines, will be treated as a single comment. + // + // leading_detached_comments will keep paragraphs of comments that appear + // before (but not connected to) the current element. Each paragraph, + // separated by empty lines, will be one comment element in the repeated + // field. + // + // Only the comment content is provided; comment markers (e.g. //) are + // stripped out. For block comments, leading whitespace and an asterisk + // will be stripped from the beginning of each line other than the first. + // Newlines are included in the output. + // + // Examples: + // + // optional int32 foo = 1; // Comment attached to foo. + // // Comment attached to bar. + // optional int32 bar = 2; + // + // optional string baz = 3; + // // Comment attached to baz. + // // Another line attached to baz. + // + // // Comment attached to qux. + // // + // // Another line attached to qux. + // optional double qux = 4; + // + // // Detached comment for corge. This is not leading or trailing comments + // // to qux or corge because there are blank lines separating it from + // // both. + // + // // Detached comment for corge paragraph 2. + // + // optional string corge = 5; + // /* Block comment attached + // * to corge. Leading asterisks + // * will be removed. */ + // /* Block comment attached to + // * grault. */ + // optional int32 grault = 6; + // + // // ignored detached comments. + optional string leading_comments = 3; + optional string trailing_comments = 4; + repeated string leading_detached_comments = 6; + } +} + +// Describes the relationship between generated code and its original source +// file. A GeneratedCodeInfo message is associated with only one generated +// source file, but may contain references to different source .proto files. +message GeneratedCodeInfo { + // An Annotation connects some span of text in generated code to an element + // of its generating .proto file. + repeated Annotation annotation = 1; + message Annotation { + // Identifies the element in the original source .proto file. This field + // is formatted the same as SourceCodeInfo.Location.path. + repeated int32 path = 1 [packed=true]; + + // Identifies the filesystem path to the original source .proto. + optional string source_file = 2; + + // Identifies the starting offset in bytes in the generated code + // that relates to the identified object. + optional int32 begin = 3; + + // Identifies the ending offset in bytes in the generated code that + // relates to the identified offset. The end offset should be one past + // the last relevant byte (so the length of the text = end - begin). + optional int32 end = 4; + } +} diff --git a/hs-iavl-client/protos/google/protobuf/empty.proto b/hs-iavl-client/protos/google/protobuf/empty.proto new file mode 100644 index 00000000..03cacd23 --- /dev/null +++ b/hs-iavl-client/protos/google/protobuf/empty.proto @@ -0,0 +1,52 @@ +// Protocol Buffers - Google's data interchange format +// Copyright 2008 Google Inc. All rights reserved. +// https://developers.google.com/protocol-buffers/ +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided that the following conditions are +// met: +// +// * Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// * Redistributions in binary form must reproduce the above +// copyright notice, this list of conditions and the following disclaimer +// in the documentation and/or other materials provided with the +// distribution. +// * Neither the name of Google Inc. nor the names of its +// contributors may be used to endorse or promote products derived from +// this software without specific prior written permission. +// +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +// OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +// SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +// LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +// DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +// THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +// (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +syntax = "proto3"; + +package google.protobuf; + +option csharp_namespace = "Google.Protobuf.WellKnownTypes"; +option go_package = "github.com/golang/protobuf/ptypes/empty"; +option java_package = "com.google.protobuf"; +option java_outer_classname = "EmptyProto"; +option java_multiple_files = true; +option objc_class_prefix = "GPB"; +option cc_enable_arenas = true; + +// A generic empty message that you can re-use to avoid defining duplicated +// empty messages in your APIs. A typical example is to use it as the request +// or the response type of an API method. For instance: +// +// service Foo { +// rpc Bar(google.protobuf.Empty) returns (google.protobuf.Empty); +// } +// +// The JSON representation for `Empty` is empty JSON object `{}`. +message Empty {} diff --git a/hs-iavl-client/protos/iavl/api.proto b/hs-iavl-client/protos/iavl/api.proto new file mode 100644 index 00000000..2daec57d --- /dev/null +++ b/hs-iavl-client/protos/iavl/api.proto @@ -0,0 +1,274 @@ +syntax = "proto3"; +package proto; + +import "google/protobuf/empty.proto"; +import "google/api/annotations.proto"; + +// ---------------------------------------------------------------------------- +// gRPC service +// ---------------------------------------------------------------------------- + +// IAVLService defines the gRPC service API contract for the IAVL tree. +service IAVLService { + // Has returns a result containing a boolean on whether or not the IAVL tree + // has a given key at a specific tree version. + rpc Has(HasRequest) returns (HasResponse) { + option (google.api.http) = { + get: "/v1/tree/{version}/has" + }; + } + + // Get returns a result containing the IAVL tree version and value for a given + // key based on the current state (version) of the tree. + rpc Get(GetRequest) returns (GetResponse) { + option (google.api.http) = { + get: "/v1/tree/get" + }; + } + + // GetWithProof returns a result containing the IAVL tree version and value for + // a given key based on the current state (version) of the tree including a + // verifiable Merkle proof. + rpc GetWithProof(GetRequest) returns (GetWithProofResponse) { + option (google.api.http) = { + get: "/v1/tree/get_with_proof" + }; + } + + // GetVersioned returns a result containing the IAVL tree version and value + // for a given key at a specific tree version. + rpc GetVersioned(GetVersionedRequest) returns (GetResponse) { + option (google.api.http) = { + get: "/v1/tree/{version}/get_versioned" + }; + } + + // GetVersionedWithProof returns a result containing the IAVL tree version and + // value for a given key at a specific tree version including a verifiable Merkle + // proof. + rpc GetVersionedWithProof(GetVersionedRequest) returns (GetWithProofResponse) { + option (google.api.http) = { + get: "/v1/tree/{version}/get_versioned_with_proof" + }; + } + + // Set returns a result after inserting a key/value pair into the IAVL tree + // based on the current state (version) of the tree. + rpc Set(SetRequest) returns (SetResponse) { + option (google.api.http) = { + post: "/v1/tree/set" + body: "*" + }; + } + + // Remove returns a result after removing a key/value pair from the IAVL tree + // based on the current state (version) of the tree. + rpc Remove(RemoveRequest) returns (RemoveResponse) { + option (google.api.http) = { + post: "/v1/tree/remove" + body: "*" + }; + } + + // SaveVersion saves a new IAVL tree version to the DB based on the current + // state (version) of the tree. It returns a result containing the hash and + // new version number. + rpc SaveVersion(google.protobuf.Empty) returns (SaveVersionResponse) { + option (google.api.http) = { + post: "/v1/tree/save_version" + body: "*" + }; + } + + // DeleteVersion deletes an IAVL tree version from the DB. The version can then + // no longer be accessed. It returns a result containing the version and root + // hash of the versioned tree that was deleted. + rpc DeleteVersion(DeleteVersionRequest) returns (DeleteVersionResponse) { + option (google.api.http) = { + post: "/v1/tree/delete_version" + body: "*" + }; + } + + // Version returns the IAVL tree version based on the current state. + rpc Version(google.protobuf.Empty) returns (VersionResponse) { + option (google.api.http) = { + get: "/v1/tree/version" + }; + } + + // Hash returns the IAVL tree root hash based on the current state. + rpc Hash(google.protobuf.Empty) returns (HashResponse) { + option (google.api.http) = { + get: "/v1/tree/hash" + }; + } + + // VersionExists returns a result containing a boolean on whether or not a given + // version exists in the IAVL tree. + rpc VersionExists(VersionExistsRequest) returns (VersionExistsResponse) { + option (google.api.http) = { + get: "/v1/tree/version_exists" + }; + } + + // Verify verifies an IAVL range proof returning an error if the proof is + // invalid. + rpc Verify(VerifyRequest) returns (google.protobuf.Empty) { + option (google.api.http) = { + get: "/v1/tree/range_proof/verify" + }; + } + + // VerifyItem verifies if a given key/value pair in an IAVL range proof returning + // an error if the proof or key is invalid. + rpc VerifyItem(VerifyItemRequest) returns (google.protobuf.Empty) { + option (google.api.http) = { + get: "/v1/tree/range_proof/verify_item" + }; + } + + // VerifyAbsence verifies the absence of a given key in an IAVL range proof + // returning an error if the proof or key is invalid. + rpc VerifyAbsence(VerifyAbsenceRequest) returns (google.protobuf.Empty) { + option (google.api.http) = { + get: "/v1/tree/range_proof/verify_absence" + }; + } + + // Rollback resets the working tree to the latest saved version, discarding + // any unsaved modifications. + rpc Rollback(google.protobuf.Empty) returns (google.protobuf.Empty) { + option (google.api.http) = { + post: "/v1/tree/rollback" + body: "*" + }; + } +} + +// ---------------------------------------------------------------------------- +// Request types +// ---------------------------------------------------------------------------- + +message HasRequest { + int64 version = 1; + bytes key = 2; +} + +message GetRequest { + bytes key = 1; +} + +message GetVersionedRequest { + int64 version = 1; + bytes key = 2; +} + +message SetRequest { + bytes key = 1; + bytes value = 2; +} + +message RemoveRequest { + bytes key = 1; +} + +message DeleteVersionRequest { + int64 version = 1; +} + +message VersionExistsRequest { + int64 version = 1; +} + +message VerifyRequest { + bytes root_hash = 1; + RangeProof proof = 2; +} + +message VerifyItemRequest { + bytes root_hash = 1; + RangeProof proof = 2; + bytes key = 3; + bytes value = 4; +} + +message VerifyAbsenceRequest { + bytes root_hash = 1; + RangeProof proof = 2; + bytes key = 3; +} + +// ---------------------------------------------------------------------------- +// Response types +// ---------------------------------------------------------------------------- + +message HasResponse { + bool result = 1; +} + +message GetResponse { + int64 index = 1; + bytes value = 2; +} + +message SetResponse { + bool result = 1; +} + +message RemoveResponse { + bytes value = 1; + bool removed = 2; +} + +message SaveVersionResponse { + bytes root_hash = 1; + int64 version = 2; +} + +message DeleteVersionResponse{ + bytes root_hash = 1; + int64 version = 2; +} + +message VersionResponse { + int64 version = 1; +} + +message HashResponse { + bytes root_hash = 1; +} + +message VersionExistsResponse { + bool result = 1; +} + +message GetWithProofResponse { + bytes value = 1; + RangeProof proof = 2; +} + +message ProofInnerNode { + int32 height = 1; + int64 size = 2; + int64 version = 3; + bytes left = 4; + bytes right = 5; +} + +message ProofLeafNode { + bytes key = 1; + bytes value_hash = 2; + int64 version = 3; +} + +message PathToLeaf { + repeated ProofInnerNode nodes = 1; +} + +message RangeProof { + bytes key = 1; + PathToLeaf left_path = 2; + repeated PathToLeaf inner_nodes = 3; + repeated ProofLeafNode leaves = 4; +} diff --git a/hs-iavl-client/src/Database/IAVL/RPC.hs b/hs-iavl-client/src/Database/IAVL/RPC.hs new file mode 100644 index 00000000..7438983c --- /dev/null +++ b/hs-iavl-client/src/Database/IAVL/RPC.hs @@ -0,0 +1,150 @@ +module Database.IAVL.RPC where + +import Data.ProtoLens.Message (defMessage) +import Network.GRPC.Client (RPC (..), RawReply) +import Network.GRPC.Client.Helpers (GrpcClient, rawUnary) +import Network.HTTP2.Client (ClientIO, TooMuchConcurrency) + +import qualified Proto.Google.Protobuf.Empty as PT (Empty) +import qualified Proto.Iavl.Api as Api + + +-------------------------------------------------------------------------------- +-- | get +-------------------------------------------------------------------------------- +get + :: GrpcClient + -> Api.GetRequest + -> ClientIO (Either TooMuchConcurrency (RawReply Api.GetResponse)) +get = rawUnary (RPC :: RPC Api.IAVLService "get") + +-------------------------------------------------------------------------------- +-- | getVersioned +-------------------------------------------------------------------------------- +getVersioned + :: GrpcClient + -> Api.GetVersionedRequest + -> ClientIO (Either TooMuchConcurrency (RawReply Api.GetResponse)) +getVersioned = rawUnary (RPC :: RPC Api.IAVLService "getVersioned") + +-------------------------------------------------------------------------------- +-- | getVersionededWithProof +-------------------------------------------------------------------------------- +getVersionedWithProof + :: GrpcClient + -> Api.GetVersionedRequest + -> ClientIO (Either TooMuchConcurrency (RawReply Api.GetWithProofResponse)) +getVersionedWithProof = rawUnary (RPC :: RPC Api.IAVLService "getVersionedWithProof") + +-------------------------------------------------------------------------------- +-- | getWithProof +-------------------------------------------------------------------------------- +getWithProof + :: GrpcClient + -> Api.GetRequest + -> ClientIO (Either TooMuchConcurrency (RawReply Api.GetWithProofResponse)) +getWithProof = rawUnary (RPC :: RPC Api.IAVLService "getWithProof") + +-------------------------------------------------------------------------------- +-- | set +-------------------------------------------------------------------------------- +set + :: GrpcClient + -> Api.SetRequest + -> ClientIO (Either TooMuchConcurrency (RawReply Api.SetResponse)) +set = rawUnary (RPC :: RPC Api.IAVLService "set") + +-------------------------------------------------------------------------------- +-- | remove +-------------------------------------------------------------------------------- +remove + :: GrpcClient + -> Api.RemoveRequest + -> ClientIO (Either TooMuchConcurrency (RawReply Api.RemoveResponse)) +remove = rawUnary (RPC :: RPC Api.IAVLService "remove") + +-------------------------------------------------------------------------------- +-- | saveVersion +-------------------------------------------------------------------------------- +saveVersion + :: GrpcClient + -> ClientIO (Either TooMuchConcurrency (RawReply Api.SaveVersionResponse)) +saveVersion gc = rawUnary (RPC :: RPC Api.IAVLService "saveVersion") gc defMessage + +-------------------------------------------------------------------------------- +-- | deleteVersion +-------------------------------------------------------------------------------- +deleteVersion + :: GrpcClient + -> Api.DeleteVersionRequest + -> ClientIO (Either TooMuchConcurrency (RawReply Api.DeleteVersionResponse)) +deleteVersion = rawUnary (RPC :: RPC Api.IAVLService "deleteVersion") + +-------------------------------------------------------------------------------- +-- | version +-------------------------------------------------------------------------------- +version + :: GrpcClient + -> ClientIO (Either TooMuchConcurrency (RawReply Api.VersionResponse)) +version gc = rawUnary (RPC :: RPC Api.IAVLService "version") gc defMessage + +-------------------------------------------------------------------------------- +-- | hash +-------------------------------------------------------------------------------- +hash + :: GrpcClient + -> ClientIO (Either TooMuchConcurrency (RawReply Api.HashResponse)) +hash gc = rawUnary (RPC :: RPC Api.IAVLService "hash") gc defMessage + +-------------------------------------------------------------------------------- +-- | versionExists +-------------------------------------------------------------------------------- +versionExists + :: GrpcClient + -> Api.VersionExistsRequest + -> ClientIO (Either TooMuchConcurrency (RawReply Api.VersionExistsResponse)) +versionExists = rawUnary (RPC :: RPC Api.IAVLService "versionExists") + +-------------------------------------------------------------------------------- +-- | verify +-------------------------------------------------------------------------------- +verify + :: GrpcClient + -> Api.VerifyRequest + -> ClientIO (Either TooMuchConcurrency (RawReply PT.Empty)) +verify = rawUnary (RPC :: RPC Api.IAVLService "verify") + +-------------------------------------------------------------------------------- +-- | verifyItem +-------------------------------------------------------------------------------- +verifyItem + :: GrpcClient + -> Api.VerifyItemRequest + -> ClientIO (Either TooMuchConcurrency (RawReply PT.Empty)) +verifyItem = rawUnary (RPC :: RPC Api.IAVLService "verifyItem") + +-------------------------------------------------------------------------------- +-- | verifyAbsence +-------------------------------------------------------------------------------- +verifyAbsence + :: GrpcClient + -> Api.VerifyAbsenceRequest + -> ClientIO (Either TooMuchConcurrency (RawReply PT.Empty)) +verifyAbsence = rawUnary (RPC :: RPC Api.IAVLService "verifyAbsence") + +-------------------------------------------------------------------------------- +-- | rollback +-------------------------------------------------------------------------------- +rollback + :: GrpcClient + -> ClientIO (Either TooMuchConcurrency (RawReply PT.Empty)) +rollback gc = rawUnary (RPC :: RPC Api.IAVLService "rollback") gc defMessage + +-------------------------------------------------------------------------------- +-- | has +-------------------------------------------------------------------------------- +has + :: GrpcClient + -> Api.HasRequest + -> ClientIO (Either TooMuchConcurrency (RawReply Api.HasResponse)) +has = rawUnary (RPC :: RPC Api.IAVLService "has") diff --git a/hs-iavl-client/src/Database/IAVL/RPC/Types.hs b/hs-iavl-client/src/Database/IAVL/RPC/Types.hs new file mode 100644 index 00000000..99fa083c --- /dev/null +++ b/hs-iavl-client/src/Database/IAVL/RPC/Types.hs @@ -0,0 +1,37 @@ +module Database.IAVL.RPC.Types where + +import Control.Exception (Exception, throwIO) +import Data.Text (Text, pack) +import Network.GRPC.Client (uncompressed) +import Network.GRPC.Client.Helpers (GrpcClient, GrpcClientConfig (..), + grpcClientConfigSimple, + setupGrpcClient) +import Network.HTTP2.Client (runClientIO) + + +-------------------------------------------------------------------------------- +-- | GRPCClientError +-------------------------------------------------------------------------------- +-- | This type represents error with the GRPC Client +data GRPCClientError = ClientSetupError Text + deriving Show + +instance Exception GRPCClientError + +-------------------------------------------------------------------------------- +-- | initGrpcClient +-------------------------------------------------------------------------------- + +data GrpcConfig = GrpcConfig + { grpcHost :: String + , grpcPort :: Integer + } + +-- | Initialize the GRPC Client +initGrpcClient :: GrpcConfig -> IO GrpcClient +initGrpcClient (GrpcConfig host port) = +-- usually 0.0.0.0:8090 + let grpcClient = grpcClientConfigSimple host (fromInteger port) False + in runClientIO (setupGrpcClient (grpcClient{_grpcClientConfigCompression=uncompressed})) >>= \case + Right gc -> pure gc + Left err -> throwIO . ClientSetupError . pack $ show err diff --git a/hs-iavl-client/test/Database/IAVL/RPCSpec.hs b/hs-iavl-client/test/Database/IAVL/RPCSpec.hs new file mode 100644 index 00000000..15990e07 --- /dev/null +++ b/hs-iavl-client/test/Database/IAVL/RPCSpec.hs @@ -0,0 +1,226 @@ +module Database.IAVL.RPCSpec (spec) where + +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (void) +import Data.ProtoLens.Message (defMessage) +import Database.IAVL.RPC +import Database.IAVL.RPC.Types +import Network.GRPC.Client (RawReply) +import Network.HTTP2.Client (ClientIO, TooMuchConcurrency, + runClientIO) +import qualified Proto.Iavl.Api_Fields as Api +import Test.Hspec + +spec :: Spec +spec = beforeAll (initGrpcClient $ GrpcConfig "0.0.0.0" 8090) $ do + let testKey = "test-key" + testValue = "test-value" + testKey2 = "test-key-2" + testValue2 = "test-value-2" + rootWithTestKey = "`\241\167\226\242u\194\221L!\200\202\159\232\131\\\ESC\ESC\158wZ\164yw\248\194jW\145:\206\209" + describe "IAVL RPC calls" $ do + + it "should call `hash` RPC method on empty Iavl store and get empty root hash" $ \gc -> do + res <- runGrpc $ hash gc + res ^. Api.rootHash `shouldBe` "" + + it "should call `set` RPC method and get false as result since it does not already exist" $ \gc -> do + let setReq = defMessage & Api.key .~ testKey + & Api.value .~ testValue + res <- runGrpc $ set gc setReq + res ^. Api.result `shouldBe` False + + it "should call `get` RPC method and get the expected value" $ \gc -> do + let getReq = defMessage & Api.key .~ testKey + res <- runGrpc $ get gc getReq + res ^. Api.value `shouldBe` testValue + res ^. Api.index `shouldBe` 0 + + it "should call `get` RPC method on a newly set key and get the expected value and index" $ \gc -> do + let setReq = defMessage & Api.key .~ testKey2 + & Api.value .~ testValue2 + sres <- runGrpc $ set gc setReq + sres ^. Api.result `shouldBe` False + + let getReq = defMessage & Api.key .~ testKey2 + gres <- runGrpc $ get gc getReq + gres ^. Api.value `shouldBe` testValue2 + gres ^. Api.index `shouldBe` 1 + + it "should call `get` RPC method and fail to get the expected value" $ \gc -> do + let getReq = defMessage & Api.key .~ "non-existing-key" + res <- runGrpc $ get gc getReq + res ^. Api.value `shouldBe` "" + + it "should call `saveVersion` RPC method and get the latest hash" $ \gc -> do + _ <- runGrpc $ saveVersion gc + res <- runGrpc $ hash gc + res ^. Api.rootHash `shouldBe` rootWithTestKey + + it "should call `getWithProof` RPC method and get value from earlier version" $ \gc -> do + let getReq = defMessage & Api.key .~ testKey + getRes <- runGrpc $ getWithProof gc getReq + getRes ^. Api.value `shouldBe` testValue + + it "should call `getVersioned` RPC method and get value from earlier version" $ \gc -> do + let newVal = "new-value" + setReq = defMessage & Api.key .~ testKey + & Api.value .~ newVal + res <- runGrpc $ set gc setReq + res ^. Api.result `shouldBe` True + _ <- runGrpc $ saveVersion gc + + let getReq = defMessage & Api.key .~ testKey + & Api.version .~ 1 + getRes <- runGrpc $ getVersioned gc getReq + getRes ^. Api.value `shouldBe` testValue + + it "should call `getVersionedWithProof` RPC method and get value from earlier version" $ \gc -> do + let newVal = "new-value-2" + setReq = defMessage & Api.key .~ testKey + & Api.value .~ newVal + res <- runGrpc $ set gc setReq + res ^. Api.result `shouldBe` True + _ <- runGrpc $ saveVersion gc + + let getReq = defMessage & Api.key .~ testKey + & Api.version .~ 1 + getRes <- runGrpc $ getVersionedWithProof gc getReq + getRes ^. Api.value `shouldBe` testValue + + it "should call `remove` RPC method" $ \gc -> do + let key = "key-to-remove" + value = "value-to-remove" + setReq = defMessage & Api.key .~ key + & Api.value .~ value + res <- runGrpc $ set gc setReq + res ^. Api.result `shouldBe` False + _ <- runGrpc $ saveVersion gc + + let removeReq = defMessage & Api.key .~ key + removeRes <- runGrpc $ remove gc removeReq + removeRes ^. Api.value `shouldBe` value + + let getReq = defMessage & Api.key .~ key + getRes <- runGrpc $ get gc getReq + getRes ^. Api.value `shouldBe` "" + + it "should call `verify` RPC method" $ \gc -> do + let getReq = defMessage & Api.key .~ testKey + & Api.version .~ 1 + getRes <- runGrpc $ getVersionedWithProof gc getReq + + let verifyReq = defMessage & Api.rootHash .~ rootWithTestKey + & Api.proof .~ (getRes ^. Api.proof) + void . runGrpc $ verify gc verifyReq + + it "should call `verifyItem` RPC method" $ \gc -> do + let getReq = defMessage & Api.key .~ testKey + & Api.version .~ 1 + getRes <- runGrpc $ getVersionedWithProof gc getReq + + let verifyReq = defMessage & Api.rootHash .~ rootWithTestKey + & Api.proof .~ (getRes ^. Api.proof) + & Api.key .~ testKey + & Api.value .~ testValue + void . runGrpc $ verifyItem gc verifyReq + + it "should call `verifyAbsence` RPC method" $ \gc -> do + let getReq = defMessage & Api.key .~ testKey + & Api.version .~ 1 + getRes <- runGrpc $ getVersionedWithProof gc getReq + + let verifyAbReq = defMessage & Api.rootHash .~ rootWithTestKey + & Api.proof .~ (getRes ^. Api.proof) + & Api.key .~ "non-existing key" + void . runGrpc $ verifyAbsence gc verifyAbReq + + it "should call `versionExists` RPC method on existing version" $ \gc -> do + let verExistsReq = defMessage & Api.version .~ 1 + verExistsRes <- runGrpc $ versionExists gc verExistsReq + verExistsRes ^. Api.result `shouldBe` True + + it "should call `version` RPC method and get latest version number" $ \gc -> do + verRes <- runGrpc $ version gc + verRes ^. Api.version `shouldBe` 4 + + it "should call `versionExists` RPC method on non-existing version" $ \gc -> do + let verExistsReq = defMessage & Api.version .~ 25 + verExistsRes <- runGrpc $ versionExists gc verExistsReq + verExistsRes ^. Api.result `shouldBe` False + + it "should call `has` RPC method" $ \gc -> do + let hasReq = defMessage & Api.key .~ testKey + & Api.version .~ 1 + hasRes <- runGrpc $ has gc hasReq + hasRes ^. Api.result `shouldBe` True + + it "should call `has` RPC method and fail" $ \gc -> do + let hasReq = defMessage & Api.key .~ "non-existing-key" + & Api.version .~ 1 + hasRes <- runGrpc $ has gc hasReq + hasRes ^. Api.result `shouldBe` False + + it "should call `deleteVersion` RPC method and get False for non-existing version" $ \gc -> do + let delVerReq = defMessage & Api.version .~ 1 + let verExistsReq = defMessage & Api.version .~ 1 + delVerRes <- runGrpc $ deleteVersion gc delVerReq + verExistsRes <- runGrpc $ versionExists gc verExistsReq + delVerRes ^. Api.rootHash `shouldBe` rootWithTestKey + verExistsRes ^. Api.result `shouldBe` False + + it "should call `rollback` RPC method without changing the version" $ \gc -> do + verRes <- runGrpc $ version gc + let oldVersion = verRes ^. Api.version + + _ <- runGrpc $ rollback gc + + verRes' <- runGrpc $ version gc + let newVersion = verRes' ^. Api.version + + oldVersion `shouldBe` newVersion + + it "should call `rollback` RPC method" $ \gc -> do + let key = "key-with-rollback" + value = "value-with-rollback" + setReq = defMessage & Api.key .~ key + & Api.value .~ value + res <- runGrpc $ set gc setReq + res ^. Api.result `shouldBe` False + + let getReq = defMessage & Api.key .~ key + getRes <- runGrpc $ get gc getReq + getRes ^. Api.value `shouldBe` value + getRes ^. Api.index `shouldBe` 1 + + _ <- runGrpc $ rollback gc + + getRes' <- runGrpc $ get gc getReq + getRes' ^. Api.value `shouldBe` "" + + it "should call `has` RPC method on current working tree" $ \gc -> do + let key = "key-has" + value = "value-has" + setReq = defMessage & Api.key .~ key + & Api.value .~ value + res <- runGrpc $ set gc setReq + res ^. Api.result `shouldBe` False + verRes <- runGrpc $ version gc + let currentVersion = verRes ^. Api.version + hasReq = defMessage & Api.key .~ key + & Api.version .~ currentVersion + print $ "The current version is " <> show currentVersion + hasRes <- runGrpc $ has gc hasReq + hasRes ^. Api.result `shouldBe` False + + +runGrpc :: ClientIO (Either TooMuchConcurrency (RawReply a)) -> IO a +runGrpc f = runClientIO f >>= \case + Right (Right (Right (_, _, Right res))) -> pure res + Right (Right (Right (_, _, Left err))) -> error ("Error running grpc call: " <> show err) + Right (Right (Left err)) -> error ("Error running grpc call: " <> show err) + Right (Left err) -> error ("Error running grpc call: " <> show err) + Left err -> error ("Error running grpc call: " <> show err) + + + diff --git a/hs-iavl-client/test/Spec.hs b/hs-iavl-client/test/Spec.hs new file mode 100644 index 00000000..fcb16768 --- /dev/null +++ b/hs-iavl-client/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} diff --git a/hs-tendermint-client/Dockerfile.abci-cli b/hs-tendermint-client/Dockerfile.abci-cli new file mode 100644 index 00000000..287cad9a --- /dev/null +++ b/hs-tendermint-client/Dockerfile.abci-cli @@ -0,0 +1,13 @@ +FROM golang:1.13-alpine +ARG TENDERMINT_VERSION +RUN echo "Will clone tendermint/tendermint#${TENDERMINT_VERSION}" && \ + apk add --no-cache ca-certificates git make && \ + mkdir -p $GOPATH/src/github.com/tendermint && \ + cd $GOPATH/src/github.com/tendermint && \ + git clone --branch "${TENDERMINT_VERSION}" https://github.com/tendermint/tendermint.git && \ + cd tendermint && \ + make tools && \ + make install_abci && \ + ln -s `which abci-cli` /abci-cli && \ + apk del git make +ENTRYPOINT ["/abci-cli"] diff --git a/hs-tendermint-client/docker-compose.yaml b/hs-tendermint-client/docker-compose.yaml new file mode 100644 index 00000000..519fcfa8 --- /dev/null +++ b/hs-tendermint-client/docker-compose.yaml @@ -0,0 +1,30 @@ +version: '3.7' +services: + tendermint-init: + image: tendermint/tendermint:v0.32.8 + command: init + volumes: + - tendermint-storage:/tendermint + tendermint: + depends_on: + - tendermint-init + - kvstore + image: tendermint/tendermint:v0.32.8 + command: node --rpc.laddr tcp://0.0.0.0:26657 --proxy_app=tcp://kvstore:26658 + volumes: + - tendermint-storage:/tendermint + restart: always + ports: + - "26656-26657:26656-26657" + kvstore: + build: + context: ./ + dockerfile: Dockerfile.abci-cli + args: + TENDERMINT_VERSION: v0.32.8 + restart: always + command: kvstore + expose: + - "26658" +volumes: + tendermint-storage: diff --git a/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs b/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs index 3fb24b22..0009cdf6 100644 --- a/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs +++ b/hs-tendermint-client/kv-test/KVStore/Test/KVSpec.hs @@ -1,99 +1,163 @@ -module KVStore.Test.KVSpec where - -import Control.Lens (to, (^.)) -import Control.Monad.Catch (try) -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.Either (isRight) -import Data.String.Conversions (cs) -import qualified Network.ABCI.Types.Messages.Response as Response -import qualified Network.Tendermint.Client as RPC +module KVStore.Test.KVSpec (spec) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, modifyMVar_, + newMVar, readMVar) +import Control.Lens ((^.)) +import Control.Monad (replicateM) +import Control.Monad.Catch (try) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.Aeson as A +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.Conduit (awaitForever, + runConduit, (.|)) +import Data.Default.Class (def) +import Data.Either (isRight) +import Data.HashSet (fromList) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Network.ABCI.Types.Messages.FieldTypes as FieldTypes +import qualified Network.ABCI.Types.Messages.Response as Response +import qualified Network.Tendermint.Client as RPC +import System.Random (randomIO) import Test.Hspec spec :: Spec spec = do - describe "Tendermint KV Store - via hs-tendermint-client" $ do - - it "Can query /health to make sure the node is alive" $ do - resp <- runRPC RPC.health - resp `shouldBe` RPC.ResultHealth - - it "Can query /abci_info and parse the result" $ do - result :: Either RPC.JsonRpcException RPC.ResultABCIInfo <- try $ runRPC RPC.abciInfo - result `shouldSatisfy` isRight - - it "Can query /block and parse the result" $ do - -- @NOTE: this defaults to latest block - result :: Either RPC.JsonRpcException RPC.ResultBlock <- try $ runRPC (RPC.block def) - result `shouldSatisfy` isRight - - it "Can submit a async tx and the response code is 0 (success)" $ do - let asyncTxReq = RPC.RequestBroadcastTxAsync { RPC.requestBroadcastTxAsyncTx = encodeTx "abcd" } - -- async returns nothing - resp <- runRPC $ RPC.broadcastTxAsync asyncTxReq - RPC.resultBroadcastTxCode resp `shouldBe` 0 - - it "Can submit a sync tx and the response code is 0 (success)" $ do - let txReq = RPC.RequestBroadcastTxSync { RPC.requestBroadcastTxSyncTx = encodeTx "efgh" } - -- sync only returns a CheckTx - resp <- runRPC $ RPC.broadcastTxSync txReq - RPC.resultBroadcastTxCode resp `shouldBe` 0 - - it "Can submit a commit tx, make sure the response code is 0 (success), and get the result(s)" $ do - -- /broadcast_tx_commit - -- set name key - let broadcastTxReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeTx "name=satoshi" } - broadcastResp <- runRPC $ RPC.broadcastTxCommit broadcastTxReq - let deliverResp = RPC.resultBroadcastTxCommitDeliverTx broadcastResp - deliverRespCode = deliverResp ^. Response._deliverTxCode - deliverRespCode `shouldBe` 0 - -- /abci_query (w+w/o proof) - -- get name key value - let dName = Hex.fromBytes $ cs @String @ByteString "name" - queryReq = def { RPC.requestABCIQueryData = dName } - queryReqWProof = def { RPC.requestABCIQueryData = dName - , RPC.requestABCIQueryProve = True - } - queryResp <- fmap RPC.resultABCIQueryResponse . runRPC $ - RPC.abciQuery queryReq - queryRespWProof <- fmap RPC.resultABCIQueryResponse . runRPC $ - RPC.abciQuery queryReqWProof - let foundName = queryResp ^. Response._queryValue . to decodeName - foundNameWProof = queryRespWProof ^. Response._queryValue . to decodeName - foundName `shouldBe` "satoshi" - foundNameWProof `shouldBe` "satoshi" - -- check with /tx endpoint (w+w/o proof) - let hash = RPC.resultBroadcastTxCommitHash $ broadcastResp - -- convert hex to base64 - baseHash = Base64.fromBytes . Hex.toBytes @ByteString $ hash - txReq = def { RPC.requestTxHash = Just baseHash } - txReqWP = RPC.RequestTx { RPC.requestTxHash = Just baseHash - , RPC.requestTxProve = True - } - -- check the hashes are the same - txResultHash <- fmap RPC.resultTxHash . runRPC $ RPC.tx txReq - txResultWPHash <- fmap RPC.resultTxHash . runRPC $ RPC.tx txReqWP - txResultHash `shouldBe` hash - txResultWPHash `shouldBe` hash + beforeAll testInit $ do + describe "Tendermint KV Store - via hs-tendermint-client" $ do -encodeTx :: String -> Base64String -encodeTx = Base64.fromBytes . cs @String @ByteString + it "Can query /health to make sure the node is alive" $ const $ do + resp <- runRPC RPC.health + resp `shouldBe` RPC.ResultHealth + + it "Can query /abci_info and parse the result" $ const $ do + result :: Either RPC.JsonRpcException RPC.ResultABCIInfo <- try $ runRPC RPC.abciInfo + result `shouldSatisfy` isRight + + it "Can query /block and parse the result" $ const $ do + -- @NOTE: this defaults to latest block + result :: Either RPC.JsonRpcException RPC.ResultBlock <- try $ runRPC (RPC.block def) + result `shouldSatisfy` isRight + + it "Can submit a async tx and the response code is 0 (success)" $ \tenv -> do + a <- replicateM 10 $ randomIO @Char + addEventToCheck tenv "name" + let asyncTxReq = RPC.RequestBroadcastTxAsync { RPC.requestBroadcastTxAsyncTx = encodeTx $ "name=" <> a } + -- async returns nothing + resp <- runRPC $ RPC.broadcastTxAsync asyncTxReq + RPC.resultBroadcastTxCode resp `shouldBe` 0 + + it "Can submit a sync tx and the response code is 0 (success)" $ \tenv -> do + a <- replicateM 10 $ randomIO @Char + addEventToCheck tenv "name" + let txReq = RPC.RequestBroadcastTxSync { RPC.requestBroadcastTxSyncTx = encodeTx $ "name=" <> a } + -- sync only returns a CheckTx + resp <- runRPC $ RPC.broadcastTxSync txReq + RPC.resultBroadcastTxCode resp `shouldBe` 0 + + it "Can submit a commit tx, make sure the response code is 0 (success), and get the result(s)" $ \tenv -> do + -- /broadcast_tx_commit + -- set name key + addEventToCheck tenv "name" + a <- replicateM 10 $ randomIO @Char + let broadcastTxReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeTx $ "name=" <> a } + broadcastResp <- runRPC $ RPC.broadcastTxCommit broadcastTxReq + let deliverResp = RPC.resultBroadcastTxCommitDeliverTx broadcastResp + deliverRespCode = deliverResp ^. Response._deliverTxCode + deliverRespCode `shouldBe` 0 + -- /abci_query (w+w/o proof) + -- get name key value + let dName = Hex.fromBytes $ cs @String @ByteString "name" + queryReq = def { RPC.requestABCIQueryData = dName } + queryReqWProof = def { RPC.requestABCIQueryData = dName + , RPC.requestABCIQueryProve = True + } + queryResp <- fmap RPC.resultABCIQueryResponse . runRPC $ + RPC.abciQuery queryReq + queryRespWProof <- fmap RPC.resultABCIQueryResponse . runRPC $ + RPC.abciQuery queryReqWProof + let foundName = queryResp ^. Response._queryValue + foundNameWProof = queryRespWProof ^. Response._queryValue + decodeQuery foundName `shouldBe` a + decodeQuery foundNameWProof `shouldBe` a + -- check with /tx endpoint (w+w/o proof) + let hash = RPC.resultBroadcastTxCommitHash $ broadcastResp + -- convert hex to base64 + baseHash = Base64.fromBytes . Hex.toBytes @ByteString $ hash + txReq = def { RPC.requestTxHash = Just baseHash } + txReqWP = RPC.RequestTx { RPC.requestTxHash = Just baseHash + , RPC.requestTxProve = True + } + -- check the hashes are the same + txResultHash <- fmap RPC.resultTxHash . runRPC $ RPC.tx txReq + txResultWPHash <- fmap RPC.resultTxHash . runRPC $ RPC.tx txReqWP + txResultHash `shouldBe` hash + txResultWPHash `shouldBe` hash + + + it "Can monitor all events" $ \(TestEnv mvex mvres _) -> do + expected <- readMVar mvex + res <- readMVar mvres + fromList (map A.toJSON expected) `shouldBe` fromList (map A.toJSON res) -decodeName :: Base64String -> String -decodeName = cs @ByteString @String . Base64.toBytes 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 () + let RPC.Config baseReq _ _ host port tls = RPC.defaultConfig "localhost" 26657 False + prettyPrint :: forall b. A.ToJSON b => String -> b -> IO () prettyPrint prefix a = putStrLn $ prefix <> "\n" <> (cs . encodePretty $ a) - in RPC.Config baseReq (prettyPrint "RPC Request") (prettyPrint "RPC Response") + in RPC.Config baseReq (prettyPrint "RPC Request") (prettyPrint "RPC Response") host port tls + +-- See https://github.com/tendermint/tendermint/blob/master/abci/example/kvstore/kvstore.go#L101 +mkAppEvent :: String -> FieldTypes.Event +mkAppEvent k = FieldTypes.Event + { eventType = "app" + , eventAttributes = + [ FieldTypes.KVPair (encode "creator") (encode "Cosmoshi Netowoko") + , FieldTypes.KVPair (encode "key") (encode k) + ] + } + where + encode = Base64.fromBytes . cs @String @ByteString + +encodeTx :: String -> Base64String +encodeTx = Base64.fromBytes . cs @_ @ByteString + +decodeQuery :: Base64String -> String +decodeQuery = cs @ByteString . Base64.toBytes + +-- Test Init +data TestEnv = TestEnv (MVar [FieldTypes.Event]) (MVar [FieldTypes.Event]) (MVar [Text]) + +testInit :: IO TestEnv +testInit = TestEnv <$> newMVar [] <*> newMVar [] <*> newMVar [] + +addEventToCheck :: TestEnv -> String -> IO () +addEventToCheck (TestEnv mvexpected mvseen mveventTypes) ev = do + let appEv = mkAppEvent ev + modifyMVar_ mvexpected $ pure . (appEv :) + ses <- readMVar mveventTypes + let evType = FieldTypes.eventType appEv + if evType`elem` ses + then pure () + else do + _ <- startNewListener evType + modifyMVar_ mveventTypes $ pure . (evType :) + where + startNewListener evType = + let subReq = RPC.RequestSubscribe ("tm.event = 'Tx' AND " <> evType <> " EXISTS") + eventStorer = awaitForever $ \as -> + liftIO $ modifyMVar_ mvseen $ \es -> pure $ + RPC.txEventEvents as <> es + forkTendermintM = forkIO . runRPC . runResourceT . runConduit + in forkTendermintM $ RPC.subscribe subReq .| eventStorer diff --git a/hs-tendermint-client/package.yaml b/hs-tendermint-client/package.yaml index ab18b00f..c6a25eb5 100644 --- a/hs-tendermint-client/package.yaml +++ b/hs-tendermint-client/package.yaml @@ -1,19 +1,12 @@ name: hs-tendermint-client version: 0.1.0.0 -github: "f-o-a-m/hs-abci/hs-tendermint-client" -license: BSD3 -author: "Author name here" -maintainer: "example@example.com" -copyright: "2019 Author name here" +github: "f-o-a-m/kepler/hs-tendermint-client" +license: Apache +author: "Martin Allen" +maintainer: "martin@foam.spacem" +copyright: "2020 FOAM" -# 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 +description: Please see the README on GitHub at default-extensions: - NamedFieldPuns @@ -32,31 +25,42 @@ default-extensions: - OverloadedStrings - GeneralizedNewtypeDeriving - dependencies: - aeson -- aeson-casing - base >= 4.7 && < 5 -- base16-bytestring - bytestring -- data-default-class - exceptions -- hs-abci-types -- http-client -- http-conduit -- memory -- mtl -- random -- text -- time +- data-default-class + library: source-dirs: src + dependencies: + - aeson-casing + - conduit + - hs-abci-types + - http-client + - http-conduit + - lens + - lens-aeson + - mtl + - random + - resourcet + - stm + - stm-conduit + - text + - websockets + - wuss ghc-options: - -Werror - -Wall + - -Wcompat + - -Widentities + - -Wincomplete-record-updates + - -Wredundant-constraints exposed-modules: - Network.Tendermint.Client + - Network.Tendermint.Client.Internal.RPCClient tests: hs-tendermint-client-kv: @@ -71,12 +75,14 @@ tests: - -rtsopts - -with-rtsopts=-N dependencies: - - aeson - aeson-pretty - - binary + - conduit - hs-abci-types - hs-tendermint-client - hspec - lens - - QuickCheck + - text + - random + - resourcet - string-conversions + - unordered-containers diff --git a/hs-tendermint-client/src/Network/Tendermint/Client.hs b/hs-tendermint-client/src/Network/Tendermint/Client.hs index 59f03ba2..431210b0 100644 --- a/hs-tendermint-client/src/Network/Tendermint/Client.hs +++ b/hs-tendermint-client/src/Network/Tendermint/Client.hs @@ -4,11 +4,21 @@ module Network.Tendermint.Client -- * ReExports , RPC.Config(..) , RPC.JsonRpcException(..) + , RPC.RpcError(..) ) where -import Control.Monad.Reader (ReaderT, +import Control.Concurrent (forkIO, + killThread) +import Control.Concurrent.STM.TQueue (newTQueueIO, + writeTQueue) +import Control.Lens ((^?)) +import Control.Monad.Catch (throwM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.STM (atomically) +import Control.Monad.Trans.Resource (ResourceT) import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, @@ -16,9 +26,13 @@ import Data.Aeson (FromJSON (..), import qualified Data.Aeson as Aeson import Data.Aeson.Casing (aesonDrop, snakeCase) +import qualified Data.Aeson.Lens as AL import qualified Data.ByteArray.Base64String as Base64 import Data.ByteArray.HexString (HexString) import Data.ByteString (ByteString) +import Data.Conduit (ConduitT, + bracketP) +import Data.Conduit.TQueue (sourceTQueue) import Data.Default.Class (Default (..)) import Data.Int (Int64) import Data.Text (Text) @@ -31,7 +45,7 @@ import qualified Network.Tendermint.Client.Internal.RPCClient as RPC -type TendermintM a = ReaderT RPC.Config IO a +type TendermintM = ReaderT RPC.Config IO -- | Execute an RPC request with the given configuration. runTendermintM :: RPC.Config -> TendermintM a -> IO a @@ -42,13 +56,15 @@ defaultConfig -- ^ Hostname or IP (e.g. "localhost", "127.0.0.1", "151.101.208.68") -> Int -- ^ Port + -> Bool + -- ^ TLS True/False -> RPC.Config -defaultConfig host port = +defaultConfig host port tls = let baseReq = HTTP.setRequestHost host $ HTTP.setRequestPort port $ HTTP.defaultRequest - in RPC.Config baseReq mempty mempty + in RPC.Config baseReq mempty mempty host port tls -------------------------------------------------------------------------------- -- ABCI Query @@ -235,6 +251,66 @@ data ResultABCIInfo = ResultABCIInfo instance FromJSON ResultABCIInfo where parseJSON = genericParseJSON $ defaultRPCOptions "resultABCIInfo" +-------------------------------------------------------------------------------- +-- Subscribe +-------------------------------------------------------------------------------- + +data TxResultEvent a = TxEvent + { txEventBlockHeight :: FieldTypes.WrappedVal Int64 + , txEventTxIndex :: Int64 + , txEventEvents :: a + } deriving (Generic) + +instance FromJSON (TxResultEvent [FieldTypes.Event]) where + parseJSON val = do + let mtxRes = val ^? AL.key "result" + . AL.key "data" + . AL.key "value" + . AL.key "TxResult" + . AL._Object + txRes <- maybe (fail "key not found: result.data.value.TxResult") pure mtxRes + height <- txRes Aeson..: "height" + idx <- txRes Aeson..: "index" + res' <- txRes Aeson..: "result" + es <- res' Aeson..: "events" + pure TxEvent + { txEventBlockHeight = height + , txEventTxIndex = idx + , txEventEvents = es + } + +-- | invokes [/subscribe](https://tendermint.com/rpc/#subscribe) rpc call +-- https://github.com/tendermint/tendermint/blob/master/rpc/core/events.go#L17 +subscribe + :: RequestSubscribe + -> ConduitT () (TxResultEvent [FieldTypes.Event]) (ResourceT TendermintM) () +subscribe req = do + queue <- liftIO newTQueueIO + let handler (val :: Aeson.Value) = + let isEmptyResult = val ^? AL.key "result" == Just (Aeson.Object mempty) + in if isEmptyResult + then pure () + else case Aeson.eitherDecode . Aeson.encode $ val of + Left err -> throwM (RPC.ParsingException err) + Right a -> atomically $ writeTQueue queue a + cfg <- ask + bracketP + (forkIO $ RPC.remoteWS cfg (RPC.MethodName "subscribe") req handler) + killThread + (const $ sourceTQueue queue) + +newtype RequestSubscribe = RequestSubscribe + { requestSubscribeQuery :: Text + } deriving (Eq, Show, Generic) +instance ToJSON RequestSubscribe where + toJSON = genericToJSON $ defaultRPCOptions "requestSubscribe" + +-- https://github.com/tendermint/tendermint/blob/v0.32.2/rpc/core/types/responses.go#L208 +data ResultSubscribe = ResultSubscribe deriving (Eq, Show) + +instance FromJSON ResultSubscribe where + parseJSON = Aeson.withObject "Expected emptyObject" $ \_ -> pure ResultSubscribe + -------------------------------------------------------------------------------- -- https://github.com/tendermint/tendermint/blob/v0.32.2/rpc/core/types/responses.go#L147 diff --git a/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs b/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs index d4532050..d2d2fec9 100644 --- a/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs +++ b/hs-tendermint-client/src/Network/Tendermint/Client/Internal/RPCClient.hs @@ -2,16 +2,21 @@ module Network.Tendermint.Client.Internal.RPCClient where import Control.Applicative ((<|>)) import Control.Exception (Exception) -import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad (forever) +import Control.Monad.Catch (throwM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader, ask) import Data.Aeson (FromJSON (..), Result (..), ToJSON (..), Value (..), fromJSON, (.:), (.:?), (.=)) import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS import Data.Text (Text, unpack) import qualified Network.HTTP.Simple as HTTP +import qualified Network.WebSockets as WS import System.Random (randomIO) +import Wuss (runSecureClient) -- | JSON-RPC request. data Request = Request @@ -95,11 +100,50 @@ data Config = Config -- ^ An acion to perform before sending the 'HTTP.Request' , withResponse :: Response -> IO () -- ^ An acion to perform before handling the 'HTTP.Response' + , cHost :: ByteString + -- ^ The host for client to connect + , cPort :: Int + -- ^ Port for client to use + , tlsEnabled :: Bool + -- ^ Whether to use TLS or not } +remoteWS :: + ( FromJSON output + , ToJSON input + ) + => Config + -> MethodName + -> input + -> (output -> IO ()) + -> IO () +remoteWS Config{..} method input handler = do + let host = BS.unpack cHost + port = fromInteger $ toInteger cPort + tlsPort = fromInteger $ toInteger port + path = "/websocket" + if tlsEnabled + then runSecureClient host tlsPort path ws + else WS.runClient host port path ws + where + ws c = do + rid <- abs <$> randomIO + let rpcParams = Aeson.toJSON input + rpcRequest = Request method rid rpcParams + msg = WS.Binary $ Aeson.encode rpcRequest + WS.sendDataMessage c msg + forever $ do + bs <- WS.receiveData c + message <- decodeRPCResponse bs + handler message + decodeRPCResponse bs = case Aeson.eitherDecodeStrict bs of + Left err -> throwM $ ParsingException err + Right response -> pure response + + + remote :: ( MonadIO m - , MonadThrow m , MonadReader Config m , FromJSON output , ToJSON input @@ -110,7 +154,7 @@ remote :: {-# INLINE remote #-} remote method input = do rid <- abs <$> liftIO randomIO - Config baseHTTPRequest withReq withResp <- ask + Config baseHTTPRequest withReq withResp _ _ _ <- ask let req = Request method rid (toJSON input) httpReq = HTTP.setRequestBodyJSON req $ HTTP.setRequestHeaders [("Content-Type", "application/json")] diff --git a/stack.yaml b/stack.yaml index 5eac516f..921ef17e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,19 +11,44 @@ packages: - ./hs-abci-server - ./hs-abci-extra - ./hs-abci-sdk -- ./hs-abci-examples/simple-storage -- ./hs-abci-examples/nameservice +- ./hs-abci-test-utils +- ./hs-abci-docs/simple-storage +- ./hs-abci-docs/nameservice +- ./hs-iavl-client extra-deps: + - async-2.2.2 + - faker-0.0.0.2 + - gimlh-0.1.3.0 + - random-strings-0.1.1.0 - proto-lens-runtime-0.5.0.0 - proto-lens-setup-0.4.0.2 - lens-labels-0.3.0.1 - 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 + - 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 + - hpc-0.6.0.3@sha256:de3f7982345d315f1d7713df38b4f2cf09bd274f7d64dffec0cf2a0d9c8aab19,1185 + - katip-datadog-0.1.0.0 + - prometheus-2.1.3 - git: https://github.com/oscoin/avl-auth commit: dfc468845a82cdd7d759943b20853999bc026505 - - stylish-haskell-0.9.4.3@sha256:98f60e087ee3e661220cd3e1cf77677d4cecd3b90d110f7ce6f36babb5c2f895,4953 - - hlint-2.1.26@sha256:e0489fd31bc4a531aaf27d7e6b9814b50863b2a78c10e1d77e7b652b00933c9b,3231 + - 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 explicit-setup-deps: hs-abci-server: true + +ghc-options: {"$locals": -ddump-to-file -ddump-hi} diff --git a/stack.yaml.lock b/stack.yaml.lock index 1654ffb9..4146e7a1 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,6 +4,34 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: +- completed: + hackage: async-2.2.2@sha256:ed46f0f5be36cf8a3e3aebc6827d015e1f3bf9615c245e057b9e9bd35faddd21,2895 + pantry-tree: + size: 501 + sha256: dab5a4c2126fbce3f4a7c15ccf66e60de61d3eccae071f4bfbad036087399f32 + original: + hackage: async-2.2.2 +- completed: + hackage: faker-0.0.0.2@sha256:e181a9dba8022098d2cca9822b6a616a28d3013ee978076b7c7cd18b6e15c8eb,980 + pantry-tree: + size: 792 + sha256: d1fd5fcf4175f259b84f9036ab8d53d23457eb1ab9eab163dce83e8a8d7fca65 + original: + hackage: faker-0.0.0.2 +- completed: + hackage: gimlh-0.1.3.0@sha256:0cb3513ec36b7f935956b68875de40a05e934cf75499918e1db533b7d32dfc46,747 + pantry-tree: + size: 201 + sha256: 106e63ee076f0339ae5e15c599f5eb15d1e663f1f2303417000f26c9514f24c6 + original: + hackage: gimlh-0.1.3.0 +- completed: + hackage: random-strings-0.1.1.0@sha256:935a7a23dab45411960df77636a29b44ce42b89eeb15f2b1e809d771491fa677,2517 + pantry-tree: + size: 663 + sha256: 5a382966fdd8d5220b5791f3bff6db00d2ea29235e2716dadd52461b8a8beb97 + original: + hackage: random-strings-0.1.1.0 - completed: hackage: proto-lens-runtime-0.5.0.0@sha256:cb39cf13ce4f7dac5414f94a7afe0adc9b831312e6b60588a23bd816accc385f,3132 pantry-tree: @@ -39,6 +67,69 @@ packages: sha256: 30942e172639508c45742e4b0cb6bf3493bee24b291b6cd4c1ad0785f1e9057c original: hackage: proto-lens-protoc-0.5.0.0 +- 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: http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348 + pantry-tree: + size: 2457 + sha256: 02bcffba9cad572fefb4640f5fc9be68e770b32ab73efcac649db20290994c6d + original: + hackage: http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348 +- completed: + hackage: binary-0.8.7.0@sha256:ae3e6cca723ac55c54bbb3fa771bcf18142bc727afd57818e66d6ee6c8044f12,7705 + pantry-tree: + size: 1976 + 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: + size: 4812 + sha256: 7f21ce00e92f7fd24a91dd19a82aab38f62047c1b93f2cc070481760b41a4d37 + original: + hackage: bloodhound-0.16.0.0@sha256:b7be3a83e7b914fbe80a9b9de29009ad60cff072f5f8d4af4ee64de8e6406d32,5508 +- completed: + hackage: hpc-0.6.0.3@sha256:de3f7982345d315f1d7713df38b4f2cf09bd274f7d64dffec0cf2a0d9c8aab19,1185 + pantry-tree: + size: 432 + sha256: 4686c367eb25eb4d32d66bd4c080d6caa2b5e78c73beea3993db690137e1d6cb + original: + hackage: hpc-0.6.0.3@sha256:de3f7982345d315f1d7713df38b4f2cf09bd274f7d64dffec0cf2a0d9c8aab19,1185 +- 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: prometheus-2.1.3@sha256:4fdf8602f7c74367cda182cf71dab108f78a86993b428bf96b61dd6c519b6f22,4296 + pantry-tree: + size: 1559 + sha256: a8d0a0150abddf0d7b673fcb19ff2ef235d4005161826e1538ad802394c9fc0e + original: + hackage: prometheus-2.1.3 - completed: cabal-file: size: 1872 @@ -54,19 +145,75 @@ packages: git: https://github.com/oscoin/avl-auth commit: dfc468845a82cdd7d759943b20853999bc026505 - completed: - hackage: stylish-haskell-0.9.4.3@sha256:98f60e087ee3e661220cd3e1cf77677d4cecd3b90d110f7ce6f36babb5c2f895,4953 + cabal-file: + size: 5720 + sha256: 51545a2592f22d1bf612a2f55ca3af8b0083fb5c620c8996bc6d48f742d1faa1 + name: proto3-suite + version: 0.4.0.0 + git: https://github.com/awakesecurity/proto3-suite + pantry-tree: + size: 4272 + sha256: c8dfec249b4db1d4f0e15332153ed539cb10343ae73345d8cdbf1cf09c714cfc + commit: 3f6dd6f612cf2eba3c05798926ff924b0d5ab4fa + original: + git: https://github.com/awakesecurity/proto3-suite + commit: 3f6dd6f612cf2eba3c05798926ff924b0d5ab4fa +- completed: + cabal-file: + size: 1928 + sha256: 5e750211a8fdae75ffcdd0a70581ae635be5510b321924c5196ac44189fd1432 + name: proto3-wire + version: 1.1.0 + git: https://github.com/awakesecurity/proto3-wire + pantry-tree: + size: 978 + sha256: d3a5d569e005d87e4eb343b150a1c4cbc455cc9833e7713efb937d66b6679b87 + commit: 23015cf6363d1962fde6bdff0de111f7ec59ab75 + 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: 2863 - sha256: 731ad0ffd18ef72bfa4935d717d31598b3286325c9e8d1370ca6406ab104f954 + size: 3012 + sha256: 9a8ddbf6c0a5ed2e254202c2990aae99dc4a66fa24949622a123c48795ec6547 original: - hackage: stylish-haskell-0.9.4.3@sha256:98f60e087ee3e661220cd3e1cf77677d4cecd3b90d110f7ce6f36babb5c2f895,4953 + hackage: polysemy-zoo-0.6.0.0 - completed: - hackage: hlint-2.1.26@sha256:e0489fd31bc4a531aaf27d7e6b9814b50863b2a78c10e1d77e7b652b00933c9b,3231 + 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 + sha256: 414ea9a90a92d1e0e96b3a9892c856c86a606f5464706963422fdb235cf84d13 + name: http2-client-grpc + version: 0.7.0.1 + git: https://github.com/lucasdicioccio/http2-client-grpc pantry-tree: - size: 4036 - sha256: b424391b338be3eb5da8c0ba97117e8373848830592445828a3cb9694cbf8988 + size: 625 + sha256: 92a9ff8a51c40678a839a92919add1744ce1da786de01747baaf02679052ea4e + commit: 6a1aacfc18e312ef57552133f13dd1024c178706 original: - hackage: hlint-2.1.26@sha256:e0489fd31bc4a531aaf27d7e6b9814b50863b2a78c10e1d77e7b652b00933c9b,3231 + git: https://github.com/lucasdicioccio/http2-client-grpc + commit: 6a1aacfc18e312ef57552133f13dd1024c178706 snapshots: - completed: size: 524786