diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0d1a24d1844b4489a46befd3f0551fc75d9ff054..45d6f470c95da833857b43102b6105bf25ed9846 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -2,7 +2,7 @@ variables: ## Please update `scripts/version.sh` accordingly - build_deps_image_version: c916fd9f0698d7ae0d30114a328c78608b693d6a + build_deps_image_version: b7b6954bce4612682abc76139171caeb2abd1b80 build_deps_image_name: registry.gitlab.com/tezos/opam-repository public_docker_image_name: docker.io/${CI_PROJECT_PATH} GIT_STRATEGY: fetch @@ -16,8 +16,8 @@ stages: - test - doc - packaging - - publish - - publish_manifest + - build_release + - publish_release - test_coverage - publish_coverage @@ -26,7 +26,7 @@ stages: ############################################################ sanity: - image: ${build_deps_image_name}:${build_deps_image_version} + image: ${build_deps_image_name}:runtime-build-test-dependencies--${build_deps_image_version} stage: sanity except: - tags@tezos/tezos @@ -52,7 +52,7 @@ sanity: ############################################################ .build_template: &build_definition - image: ${build_deps_image_name}:${build_deps_image_version} + image: ${build_deps_image_name}:runtime-build-test-dependencies--${build_deps_image_version} stage: build except: - master @@ -150,7 +150,7 @@ build_arm64: ############################################################ test-script-gen-genesis: - image: ${build_deps_image_name}:${build_deps_image_version} + image: ${build_deps_image_name}:runtime-build-test-dependencies--${build_deps_image_version} stage: test except: - master @@ -162,6 +162,16 @@ test-script-gen-genesis: - dune build gen_genesis.exe interruptible: true +test-static-libs-patch: + image: ${build_deps_image_name}:runtime-build-test-dependencies--${build_deps_image_version} + stage: test + except: + - master + - tags@tezos/tezos + - /-release$/@tezos/tezos + script: + - git apply packaging/build/static_libs.patch + .test_template: &test_definition <<: *build_definition stage: test @@ -207,8 +217,8 @@ unit:alltest: - scripts/test_wrapper.sh src/proto_006_PsCARTHA/lib_protocol 006_PsCARTHA_lib_protocol - scripts/test_wrapper.sh src/proto_007_PsDELPH1/lib_client 007_PsDELPH1_lib_client - scripts/test_wrapper.sh src/proto_007_PsDELPH1/lib_protocol 007_PsDELPH1_lib_protocol - - scripts/test_wrapper.sh src/proto_008_PtEdoTez/lib_client 008_PtEdoTez_lib_client - - scripts/test_wrapper.sh src/proto_008_PtEdoTez/lib_protocol 008_PtEdoTez_lib_protocol + - scripts/test_wrapper.sh src/proto_008_PtEdo2Zk/lib_client 008_PtEdo2Zk_lib_client + - scripts/test_wrapper.sh src/proto_008_PtEdo2Zk/lib_protocol 008_PtEdo2Zk_lib_protocol - scripts/test_wrapper.sh src/proto_alpha/lib_client alpha_lib_client - scripts/test_wrapper.sh src/proto_alpha/lib_protocol alpha_lib_protocol - scripts/test_wrapper.sh src/tooling src_tooling @@ -625,7 +635,7 @@ documentation:build: expire_in: 1 week documentation:linkcheck: - image: ${build_deps_image_name}:${build_deps_image_version} + image: ${build_deps_image_name}:runtime-build-test-dependencies--${build_deps_image_version} stage: doc before_script: - . ./scripts/version.sh @@ -653,7 +663,7 @@ documentation:linkcheck: ############################################################ .opam_template: &opam_definition - image: ${build_deps_image_name}:opam--${build_deps_image_version} + image: ${build_deps_image_name}:runtime-prebuild-dependencies--${build_deps_image_version} stage: packaging dependencies: [] rules: @@ -723,11 +733,6 @@ opam:pyml-plot: variables: package: pyml-plot -opam:sapling: - <<: *opam_definition - variables: - package: sapling - opam:staTz: <<: *opam_definition variables: @@ -743,10 +748,10 @@ opam:tezos-007-PsDELPH1-test-helpers: variables: package: tezos-007-PsDELPH1-test-helpers -opam:tezos-008-PtEdoTez-test-helpers: +opam:tezos-008-PtEdo2Zk-test-helpers: <<: *opam_definition variables: - package: tezos-008-PtEdoTez-test-helpers + package: tezos-008-PtEdo2Zk-test-helpers opam:tezos-accuser-006-PsCARTHA: <<: *opam_definition @@ -768,15 +773,15 @@ opam:tezos-accuser-007-PsDELPH1-commands: variables: package: tezos-accuser-007-PsDELPH1-commands -opam:tezos-accuser-008-PtEdoTez: +opam:tezos-accuser-008-PtEdo2Zk: <<: *opam_definition variables: - package: tezos-accuser-008-PtEdoTez + package: tezos-accuser-008-PtEdo2Zk -opam:tezos-accuser-008-PtEdoTez-commands: +opam:tezos-accuser-008-PtEdo2Zk-commands: <<: *opam_definition variables: - package: tezos-accuser-008-PtEdoTez-commands + package: tezos-accuser-008-PtEdo2Zk-commands opam:tezos-accuser-alpha: <<: *opam_definition @@ -803,10 +808,10 @@ opam:tezos-baker-007-PsDELPH1: variables: package: tezos-baker-007-PsDELPH1 -opam:tezos-baker-008-PtEdoTez: +opam:tezos-baker-008-PtEdo2Zk: <<: *opam_definition variables: - package: tezos-baker-008-PtEdoTez + package: tezos-baker-008-PtEdo2Zk opam:tezos-baker-alpha: <<: *opam_definition @@ -833,15 +838,15 @@ opam:tezos-baking-007-PsDELPH1-commands: variables: package: tezos-baking-007-PsDELPH1-commands -opam:tezos-baking-008-PtEdoTez: +opam:tezos-baking-008-PtEdo2Zk: <<: *opam_definition variables: - package: tezos-baking-008-PtEdoTez + package: tezos-baking-008-PtEdo2Zk -opam:tezos-baking-008-PtEdoTez-commands: +opam:tezos-baking-008-PtEdo2Zk-commands: <<: *opam_definition variables: - package: tezos-baking-008-PtEdoTez-commands + package: tezos-baking-008-PtEdo2Zk-commands opam:tezos-baking-alpha: <<: *opam_definition @@ -963,20 +968,20 @@ opam:tezos-client-007-PsDELPH1-commands-registration: variables: package: tezos-client-007-PsDELPH1-commands-registration -opam:tezos-client-008-PtEdoTez: +opam:tezos-client-008-PtEdo2Zk: <<: *opam_definition variables: - package: tezos-client-008-PtEdoTez + package: tezos-client-008-PtEdo2Zk -opam:tezos-client-008-PtEdoTez-commands: +opam:tezos-client-008-PtEdo2Zk-commands: <<: *opam_definition variables: - package: tezos-client-008-PtEdoTez-commands + package: tezos-client-008-PtEdo2Zk-commands -opam:tezos-client-008-PtEdoTez-commands-registration: +opam:tezos-client-008-PtEdo2Zk-commands-registration: <<: *opam_definition variables: - package: tezos-client-008-PtEdoTez-commands-registration + package: tezos-client-008-PtEdo2Zk-commands-registration opam:tezos-client-alpha: <<: *opam_definition @@ -1023,10 +1028,10 @@ opam:tezos-client-genesis-carthagenet: variables: package: tezos-client-genesis-carthagenet -opam:tezos-client-sapling-008-PtEdoTez: +opam:tezos-client-sapling-008-PtEdo2Zk: <<: *opam_definition variables: - package: tezos-client-sapling-008-PtEdoTez + package: tezos-client-sapling-008-PtEdo2Zk opam:tezos-codec: <<: *opam_definition @@ -1083,6 +1088,11 @@ opam:tezos-embedded-protocol-007-PsDELPH1: variables: package: tezos-embedded-protocol-007-PsDELPH1 +opam:tezos-embedded-protocol-008-PtEdo2Zk: + <<: *opam_definition + variables: + package: tezos-embedded-protocol-008-PtEdo2Zk + opam:tezos-embedded-protocol-008-PtEdoTez: <<: *opam_definition variables: @@ -1133,15 +1143,15 @@ opam:tezos-endorser-007-PsDELPH1-commands: variables: package: tezos-endorser-007-PsDELPH1-commands -opam:tezos-endorser-008-PtEdoTez: +opam:tezos-endorser-008-PtEdo2Zk: <<: *opam_definition variables: - package: tezos-endorser-008-PtEdoTez + package: tezos-endorser-008-PtEdo2Zk -opam:tezos-endorser-008-PtEdoTez-commands: +opam:tezos-endorser-008-PtEdo2Zk-commands: <<: *opam_definition variables: - package: tezos-endorser-008-PtEdoTez-commands + package: tezos-endorser-008-PtEdo2Zk-commands opam:tezos-endorser-alpha: <<: *opam_definition @@ -1178,21 +1188,6 @@ opam:tezos-mempool-006-PsCARTHA: variables: package: tezos-mempool-006-PsCARTHA -opam:tezos-mempool-007-PsDELPH1: - <<: *opam_definition - variables: - package: tezos-mempool-007-PsDELPH1 - -opam:tezos-mempool-008-PtEdoTez: - <<: *opam_definition - variables: - package: tezos-mempool-008-PtEdoTez - -opam:tezos-mempool-alpha: - <<: *opam_definition - variables: - package: tezos-mempool-alpha - opam:tezos-micheline: <<: *opam_definition variables: @@ -1298,20 +1293,25 @@ opam:tezos-protocol-007-PsDELPH1-tests: variables: package: tezos-protocol-007-PsDELPH1-tests -opam:tezos-protocol-008-PtEdoTez: +opam:tezos-protocol-008-PtEdo2Zk: <<: *opam_definition variables: - package: tezos-protocol-008-PtEdoTez + package: tezos-protocol-008-PtEdo2Zk + +opam:tezos-protocol-008-PtEdo2Zk-parameters: + <<: *opam_definition + variables: + package: tezos-protocol-008-PtEdo2Zk-parameters -opam:tezos-protocol-008-PtEdoTez-parameters: +opam:tezos-protocol-008-PtEdo2Zk-tests: <<: *opam_definition variables: - package: tezos-protocol-008-PtEdoTez-parameters + package: tezos-protocol-008-PtEdo2Zk-tests -opam:tezos-protocol-008-PtEdoTez-tests: +opam:tezos-protocol-008-PtEdoTez: <<: *opam_definition variables: - package: tezos-protocol-008-PtEdoTez-tests + package: tezos-protocol-008-PtEdoTez opam:tezos-protocol-alpha: <<: *opam_definition @@ -1363,6 +1363,86 @@ opam:tezos-protocol-environment-structs: variables: package: tezos-protocol-environment-structs +opam:tezos-protocol-functor-000-Ps9mPmXa: + <<: *opam_definition + variables: + package: tezos-protocol-functor-000-Ps9mPmXa + +opam:tezos-protocol-functor-001-PtCJ7pwo: + <<: *opam_definition + variables: + package: tezos-protocol-functor-001-PtCJ7pwo + +opam:tezos-protocol-functor-002-PsYLVpVv: + <<: *opam_definition + variables: + package: tezos-protocol-functor-002-PsYLVpVv + +opam:tezos-protocol-functor-003-PsddFKi3: + <<: *opam_definition + variables: + package: tezos-protocol-functor-003-PsddFKi3 + +opam:tezos-protocol-functor-004-Pt24m4xi: + <<: *opam_definition + variables: + package: tezos-protocol-functor-004-Pt24m4xi + +opam:tezos-protocol-functor-005-PsBABY5H: + <<: *opam_definition + variables: + package: tezos-protocol-functor-005-PsBABY5H + +opam:tezos-protocol-functor-005-PsBabyM1: + <<: *opam_definition + variables: + package: tezos-protocol-functor-005-PsBabyM1 + +opam:tezos-protocol-functor-006-PsCARTHA: + <<: *opam_definition + variables: + package: tezos-protocol-functor-006-PsCARTHA + +opam:tezos-protocol-functor-007-PsDELPH1: + <<: *opam_definition + variables: + package: tezos-protocol-functor-007-PsDELPH1 + +opam:tezos-protocol-functor-008-PtEdo2Zk: + <<: *opam_definition + variables: + package: tezos-protocol-functor-008-PtEdo2Zk + +opam:tezos-protocol-functor-008-PtEdoTez: + <<: *opam_definition + variables: + package: tezos-protocol-functor-008-PtEdoTez + +opam:tezos-protocol-functor-alpha: + <<: *opam_definition + variables: + package: tezos-protocol-functor-alpha + +opam:tezos-protocol-functor-demo-counter: + <<: *opam_definition + variables: + package: tezos-protocol-functor-demo-counter + +opam:tezos-protocol-functor-demo-noops: + <<: *opam_definition + variables: + package: tezos-protocol-functor-demo-noops + +opam:tezos-protocol-functor-genesis: + <<: *opam_definition + variables: + package: tezos-protocol-functor-genesis + +opam:tezos-protocol-functor-genesis-carthagenet: + <<: *opam_definition + variables: + package: tezos-protocol-functor-genesis-carthagenet + opam:tezos-protocol-genesis: <<: *opam_definition variables: @@ -1373,6 +1453,26 @@ opam:tezos-protocol-genesis-carthagenet: variables: package: tezos-protocol-genesis-carthagenet +opam:tezos-protocol-plugin-007-PsDELPH1: + <<: *opam_definition + variables: + package: tezos-protocol-plugin-007-PsDELPH1 + +opam:tezos-protocol-plugin-007-PsDELPH1-registerer: + <<: *opam_definition + variables: + package: tezos-protocol-plugin-007-PsDELPH1-registerer + +opam:tezos-protocol-plugin-008-PtEdo2Zk: + <<: *opam_definition + variables: + package: tezos-protocol-plugin-008-PtEdo2Zk + +opam:tezos-protocol-plugin-008-PtEdo2Zk-registerer: + <<: *opam_definition + variables: + package: tezos-protocol-plugin-008-PtEdo2Zk-registerer + opam:tezos-protocol-updater: <<: *opam_definition variables: @@ -1408,6 +1508,11 @@ opam:tezos-rpc-http-server: variables: package: tezos-rpc-http-server +opam:tezos-sapling: + <<: *opam_definition + variables: + package: tezos-sapling + opam:tezos-shell: <<: *opam_definition variables: @@ -1495,20 +1600,18 @@ opam:uecc: ##END_OPAM## - - ############################################################ ## Stage: publish ## ############################################################ -.publish_template: &publish_definition +.build_docker_release_template: &build_docker_release_definition image: docker:latest services: - docker:dind variables: DOCKER_DRIVER: overlay2 IMAGE_ARCH_PREFIX: "" - stage: publish + stage: build_release only: - master@tezos/tezos - tags@tezos/tezos @@ -1528,22 +1631,108 @@ opam:uecc: - docker push "${public_docker_image_name}-debug:${IMAGE_ARCH_PREFIX}${CI_COMMIT_REF_NAME}" interruptible: false -publish:docker_amd64: - <<: *publish_definition +build_docker_amd64: + <<: *build_docker_release_definition variables: DOCKER_DRIVER: overlay2 IMAGE_ARCH_PREFIX: "amd64-" tags: - safe_docker -publish:docker_arm64: - <<: *publish_definition +build_docker_arm64: + <<: *build_docker_release_definition variables: DOCKER_DRIVER: overlay2 IMAGE_ARCH_PREFIX: "arm64-" tags: - arm64 +.build_static_binaries_template: &build_static_binaries_definition + stage: build_release + image: ${build_deps_image_name}:runtime-build-dependencies--${build_deps_image_version} + rules: + - if: '$CI_COMMIT_BRANCH == "master"' + when: on_success + - if: '$CI_COMMIT_BRANCH =~ /-release$/' + when: on_success + - if: '$CI_COMMIT_TAG != null' + when: on_success + before_script: + - sudo apk --no-cache --virtual add unzip wget eudev-dev autoconf automake libtool linux-headers binutils + # TODO: include static version of this libraries to the default docker image + - packaging/build/build-libusb-and-hidapi.sh + # TODO: patch approach is very fragile, we should think about something + # more reliable + - git apply packaging/build/static_libs.patch + - dune build @install --profile release + - dune install --prefix install_root + # Strip debug symbols in binaries + - find . -maxdepth 1 -type f ! -name "*.*" -exec strip --strip-debug {} \; + artifacts: + paths: + - install_root/bin/* + +build_static-x86_64-linux-binaries: + <<: *build_static_binaries_definition + script: + - sudo apk --no-cache --virtual add upx + # Compress resulting binaries + - find . -maxdepth 1 -type f ! -name "*.*" -exec upx {} \; + +build_static-arm64-linux-binaries: + <<: *build_static_binaries_definition + rules: + - if: '$CI_COMMIT_BRANCH == "master" && $CI_PROJECT_NAMESPACE == "tezos"' + when: on_success + - if: '$CI_COMMIT_BRANCH =~ /-release$/ && $CI_PROJECT_NAMESPACE == "tezos"' + when: on_success + - if: '$CI_COMMIT_TAG != null && $CI_PROJECT_NAMESPACE == "tezos"' + when: on_success + script: + - echo "No compression for now" + tags: + - arm64 + +.release_static_binaries_template: &release_static_binaries_definition + image: registry.gitlab.com/gitlab-org/release-cli + variables: + ARCH_PREFIX: "" + rules: + - if: '$CI_COMMIT_TAG =~ /\A\d+\.\d+\.\d+\z/ && $CI_PROJECT_NAMESPACE == "tezos"' + when: on_success + stage: publish_release + script: + - apk --no-cache --virtual add bash jq curl + - scripts/release/upload-static-binaries-to-package-registry.sh "$ARCH_PREFIX" + +release-static-x86_64-binaries: + <<: *release_static_binaries_definition + variables: + ARCH_PREFIX: "x86_64-" + PACKAGE_REGISTRY_URL: "${CI_API_V4_URL}/projects/${CI_PROJECT_ID}/packages/generic/tezos/${CI_COMMIT_TAG}" + dependencies: + - build_static-x86_64-linux-binaries + +release-static-arm64-binaries: + <<: *release_static_binaries_definition + variables: + ARCH_PREFIX: "arm64-" + PACKAGE_REGISTRY_URL: "${CI_API_V4_URL}/projects/${CI_PROJECT_ID}/packages/generic/tezos/${CI_COMMIT_TAG}" + dependencies: + - build_static-arm64-linux-binaries + +release-on-gitlab: + image: registry.gitlab.com/gitlab-org/release-cli + rules: + - if: '$CI_COMMIT_TAG =~ /\A\d+\.\d+\.\d+\z/ && $CI_PROJECT_NAMESPACE == "tezos"' + when: on_success + variables: + PACKAGE_REGISTRY_URL: "${CI_API_V4_URL}/projects/${CI_PROJECT_ID}/packages/generic/tezos/${CI_COMMIT_TAG}" + stage: publish_release + script: + - apk --no-cache --virtual add bash jq + - scripts/release/create-release-with-static-binaries.sh + merge-manifest: image: docker:latest services: @@ -1551,7 +1740,7 @@ merge-manifest: command: ["--experimental"] variables: DOCKER_DRIVER: overlay2 - stage: publish_manifest + stage: publish_release only: - master@tezos/tezos - tags@tezos/tezos @@ -1589,7 +1778,7 @@ merge-manifest: interruptible: false publish:doc: - image: ${build_deps_image_name}:${build_deps_image_version} + image: ${build_deps_image_name}:runtime-build-test-dependencies--${build_deps_image_version} stage: doc only: - master@tezos/tezos @@ -1664,7 +1853,7 @@ pages: # (sequentially). test_coverage: - image: ${build_deps_image_name}:${build_deps_image_version} + image: ${build_deps_image_name}:runtime-build-test-dependencies--${build_deps_image_version} stage: test_coverage except: - tags@tezos/tezos diff --git a/CHANGES.md b/CHANGES.md index 1717922cb4cd383fcd26a991609b86cc547cae13..2707d7ba7fce835a7cc4502cf9d0d758e40d090d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,33 +1,86 @@ -# Development Version +# Version 8.2 -When you make a commit on master, you can add an item in one of the following -subsections (node, client, ...) to document your commit or the set of related commits. -This will ensure that this change is not forgotten in the final changelog. -By having your commits update this file you also make it easy -to find the commits which are related to your changes using `git blame`. +## Node + +- Override PtEdoTez activation by PtEdo2Zk in `mainnet` network. + +- Make size limits on p2p messages explicit in low-level encodings. + +- Add new RPCs for Edo: `helpers/scripts/normalize_{data,script,type}` + and a `XXX/normalized` variant to each protocol RPC `XXX` + outputting Michelson expressions. -Only describe changes which affect users (bug fixes and new features), -not refactorings or tests. Changes to the documentation do not need to be documented -here either. +## Baker / Endorser / Accuser + +- Replace PtEdoTez by PtEdo2Zk. + +## Miscellaneous + +- Update external opam dependencies. In particular, switch to `hacl-star.0.3.0-1` + which performs better. + +# Version 8.1 ## Node +- Mind the previously forgotten item about snapshots in the section + "Version 8.0rc2 > Node" + +- Fix a performance regression affecting serialization of tz3 + signatures by reverting the P256 implementation to `uecc`. + +- Fixup allowing nodes in `--history-mode full` to answer to all new + messages to the distributed database protocol. + ## Client -## Baker / Endorser / Accuser +- As a consequence of moving back to `uecc`, revert for now the + ability to sign with tz3 addresses. -## Protocol Compiler And Environment +## Miscellaneous -## Codec +- Allow building from sources with older version of git (used to + require 2.18) + +- Downgrade `mirage-crypto` dependency to avoid failure on startup + with `illegal instruction` on some hardware. + +# Version 8.0 + +## Node + +- Added two new bootstrap peers for Mainnet and one for Edonet. + +- Fixes a bug where any event would allocate more memory than needed + when it were not to be printed. + +- Improved how the node stores buffered messages from peers to consume less memory. + +- Enforce loading of non-embedded protocols before starting the node + allowing the prevalidator to start correctly. + +- Optimized the I/O and CPU usage by removing an unnecessary access to + the context during block validation. ## Docker Images +- Bump up base image to `alpine:12`. In particular, it changes rust and python + versions to 1.44.0 and 3.8.5 respectively. + ## Miscellaneous +- Recommend rust version 1.44.0 instead of 1.39.0. + # Version 8.0~rc2 ## Node +- Snapshots exported by a node using version 8 cannot be imported by a + node running version 7. This is because the new snapshots contain + additional information required by protocol Edo. On the other hand, + snapshots exported by a node using version 7 can be imported by a + node running version 8. + - Added a new version (version 1) of the protocol environment. The environment is the set of functions and types that the economic protocol can use. Protocols up to Delphi used environment version 0. @@ -44,8 +97,8 @@ here either. - The bootstrap pipeline no longer tries to concurrently download steps from other peers. The result is actually a more efficient - bootstrap, because those concurrent downloads resulted in the same - block headers being attempted to be downloaded several times. It + bootstrap, because those concurrent downloads resulted in multiple + attempts to download the same block headers. It also resulted in more memory usage than necessary. - Added six messages to the distributed database protocol and bumped @@ -69,6 +122,9 @@ here either. was explicitely specified while the synchronisation threshold itself was not specified. +- Added RPC `DELETE /network/greylist` to clear the greylist tables. + RPC `GET /network/greylist/clear` is now deprecated. + ## Client - Added client command `import keys from mnemonic`, which allows to @@ -85,7 +141,8 @@ here either. the `` field. - Fixed the `rpc` command that did not use the full path of the URL provided to `--endpoint`. - For instance, `--endpoint http://localhost:8732/node/rpc` actually meant + Before this, `--endpoint http://localhost:8732/node/rpc` would have been + equivalent to `--endpoint http://localhost:8732`. - Fixed an issue where the client would try to sign with a key for which diff --git a/active_protocol_versions b/active_protocol_versions index 83150c979049e866c164791538a7bf8fcd9504a9..92ff17e530874fc116bd15e33830c5817fb6492a 100644 --- a/active_protocol_versions +++ b/active_protocol_versions @@ -1,4 +1,4 @@ 006-PsCARTHA 007-PsDELPH1 -008-PtEdoTez +008-PtEdo2Zk alpha diff --git a/docs/developer/python_testing_framework.rst b/docs/developer/python_testing_framework.rst index 3beb909b2a92e5bd76a5eee8444a27d23c48837a..99bb7ec7662b0b428a012f2af3b0cc753d1e1b44 100644 --- a/docs/developer/python_testing_framework.rst +++ b/docs/developer/python_testing_framework.rst @@ -35,11 +35,11 @@ Prerequisites: - A working environment (see `documentation `_) with the binaries compiled, - A local copy of the tezos `repository `_ -- `python 3.8.2`. It is recommended to use `pyenv +- `python 3.8.5`. It is recommended to use `pyenv `_ to manage the python versions. If ``pyenv`` - is used, you can use ``pyenv install 3.8.2`` followed by ``pyenv global 3.8.2`` to - set the python version to ``3.8.2`` globally. If you want to use ``python 3.8.2`` only in the - current shell, you can use ``pyenv shell 3.8.2``. Be sure ``eval $(pyenv init -)`` + is used, you can use ``pyenv install 3.8.5`` followed by ``pyenv global 3.8.5`` to + set the python version to ``3.8.5`` globally. If you want to use ``python 3.8.5`` only in the + current shell, you can use ``pyenv shell 3.8.5``. Be sure ``eval $(pyenv init -)`` has been executed first during the shell session. - `poetry `_ to manage the python dependencies and run the tests in a sandboxed python environment. All poetry commands are to be diff --git a/docs/introduction/howtoget.rst b/docs/introduction/howtoget.rst index f47dc23dc3cbb7d32c332957fb6cf3c8074b1b4a..11c76c0fc232fb23118fed4adaef1c67c974c4c1 100644 --- a/docs/introduction/howtoget.rst +++ b/docs/introduction/howtoget.rst @@ -119,8 +119,10 @@ The following OSes are also reported to work: A Windows port is feasible and might be developed in the future. -Additionally, the ``master`` branch requires the Rust compiler, -version 1.39.0, and the Cargo package manager to be installed. You can use +.. _setup_rust: + +Additionally, starting from version 8.0, compiling Tezos requires the Rust compiler, +version 1.44.0, and the Cargo package manager to be installed. You can use `rustup `_ to install both. Note that ``rustup`` can update your ``.profile`` to update your ``PATH`` environment variable, but this does not take effect until you restart @@ -128,8 +130,8 @@ your desktop environment or window manager, so you may have to manually update it for your current session:: rustup set profile minimal - rustup toolchain install 1.39.0 - rustup override set 1.39.0 + rustup toolchain install 1.44.0 + rustup override set 1.44.0 source $HOME/.cargo/env diff --git a/dune b/dune index 86dea6a51a9359955fa4a88a2f6d4656bf96c823..995521bd50a1de71aef98c122e99591be50769ee 100644 --- a/dune +++ b/dune @@ -2,8 +2,4 @@ (release (ocamlopt_flags (:standard -O3)))) -(alias - (name runtest) - (deps (alias_rec runtest_lint))) - (vendored_dirs vendors) diff --git a/packaging/build/README.md b/packaging/build/README.md new file mode 100644 index 0000000000000000000000000000000000000000..8344bb299cbc8e2b6adf3afa8328f40d3243003d --- /dev/null +++ b/packaging/build/README.md @@ -0,0 +1,10 @@ +# Static binaries building + +This directory contains various files required for building static +Tezos binaries: + +* `build-libusb-and-hidapi.sh` script builds static version of libusb and hidapi + libraries. It's required because default docker alpine image doesn't have static + version for these libraries +* `static_libs.patch` patch file provides flags for dune files, these flags + enable static linking for binaries. diff --git a/packaging/build/build-libusb-and-hidapi.sh b/packaging/build/build-libusb-and-hidapi.sh new file mode 100755 index 0000000000000000000000000000000000000000..122a46ef5561a5422448204e1bb70a8cc03ee4d5 --- /dev/null +++ b/packaging/build/build-libusb-and-hidapi.sh @@ -0,0 +1,29 @@ +#! /bin/sh + +# SPDX-FileCopyrightText: 2020 TQ Tezos +# +# SPDX-License-Identifier: MPL-2.0 + +# This script builds and installs libusb and hidapi libraries. It's required since alpine +# doesn't provide static versions for these libraries, thus we have to compile it ourselves. +set -euo pipefail + +libusb_commit="e782eeb2514266f6738e242cdcb18e3ae1ed06fa" +hidapi_commit="7da5cc91fc0d2dbe4df4f08cd31f6ca1a262418f" +git clone --single-branch --branch v1.0.23 https://github.com/libusb/libusb.git --depth 1 +cd libusb +if [[ $(git rev-parse HEAD) != $libusb_commit ]]; then + echo "Unexpected libusb sources" + exit 1 +fi +autoreconf -fvi && ./configure && make && sudo make install + +git clone --single-branch --branch hidapi-0.9.0 https://github.com/libusb/hidapi.git --depth 1 +cd hidapi +if [[ $(git rev-parse HEAD) != $hidapi_commit]]; then + echo "Unexpected hidapi sources" + exit 1 +fi +autoreconf -fvi && ./bootstrap && ./configure && make && sudo make install + +rm -rf libusb hidapi diff --git a/packaging/build/static_libs.patch b/packaging/build/static_libs.patch new file mode 100644 index 0000000000000000000000000000000000000000..3930735ab93997df5eb12b59071c1bb8cbd1838e --- /dev/null +++ b/packaging/build/static_libs.patch @@ -0,0 +1,217 @@ +diff --git a/src/bin_client/dune b/src/bin_client/dune +index aa69b180be..382b2f7e09 100644 +--- a/src/bin_client/dune ++++ b/src/bin_client/dune +@@ -77,7 +77,9 @@ + -open Tezos_client_commands + -open Tezos_mockup_commands + -open Tezos_client_base_unix +- -linkall))) ++ -linkall ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (action +diff --git a/src/bin_codec/dune b/src/bin_codec/dune +index 552f7bd835..a6db9bc27d 100644 +--- a/src/bin_codec/dune ++++ b/src/bin_codec/dune +@@ -33,7 +33,9 @@ + -open Tezos_clic + -open Tezos_stdlib_unix + -open Tezos_event_logging +- -linkall))) ++ -linkall ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (action +diff --git a/src/bin_node/dune b/src/bin_node/dune +index 0c033582e2..905890bf42 100644 +--- a/src/bin_node/dune ++++ b/src/bin_node/dune +@@ -89,7 +89,8 @@ + -open Tezos_shell_context + -open Tezos_workers + -open Tezos_protocol_updater +- -linkall))) ++ -linkall ++ -ccopt -static))) + + (rule + (action +diff --git a/src/bin_signer/dune b/src/bin_signer/dune +index 2b8a8910fd..847acd7505 100644 +--- a/src/bin_signer/dune ++++ b/src/bin_signer/dune +@@ -21,7 +21,9 @@ + -open Tezos_rpc_http_server + -open Tezos_rpc_http_client_unix + -open Tezos_stdlib_unix +- -open Tezos_stdlib))) ++ -open Tezos_stdlib ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (alias runtest_lint) +diff --git a/src/lib_protocol_compiler/dune b/src/lib_protocol_compiler/dune +index 7f2ec8a631..51ffdcc8bd 100644 +--- a/src/lib_protocol_compiler/dune ++++ b/src/lib_protocol_compiler/dune +@@ -40,8 +40,7 @@ + tezos-protocol-compiler + compiler-libs.bytecomp) + (flags (:standard -open Tezos_base__TzPervasives +- -open Tezos_protocol_compiler)) +- (modules Byte)) ++ -open Tezos_protocol_compiler)) (modules Byte)) + + (library + (name tezos_protocol_compiler_native) +@@ -66,7 +65,7 @@ + (public_name tezos-protocol-compiler) + (modes native) + (libraries tezos_protocol_compiler_native) +- (flags (:standard -linkall)) ++ (flags (:standard -linkall -ccopt -static)) + (modules Main_native)) + + (executable +diff --git a/src/proto_007_PsDELPH1/bin_accuser/dune b/src/proto_007_PsDELPH1/bin_accuser/dune +index 8fe05cdc3e..dee6277ee2 100644 +--- a/src/proto_007_PsDELPH1/bin_accuser/dune ++++ b/src/proto_007_PsDELPH1/bin_accuser/dune +@@ -10,7 +10,9 @@ + -open Tezos_client_commands + -open Tezos_baking_007_PsDELPH1_commands + -open Tezos_stdlib_unix +- -open Tezos_client_base_unix))) ++ -open Tezos_client_base_unix ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (alias runtest_lint) +diff --git a/src/proto_007_PsDELPH1/bin_baker/dune b/src/proto_007_PsDELPH1/bin_baker/dune +index 8b39572e37..7dd5146ddc 100644 +--- a/src/proto_007_PsDELPH1/bin_baker/dune ++++ b/src/proto_007_PsDELPH1/bin_baker/dune +@@ -10,7 +10,9 @@ + -open Tezos_client_commands + -open Tezos_baking_007_PsDELPH1_commands + -open Tezos_stdlib_unix +- -open Tezos_client_base_unix))) ++ -open Tezos_client_base_unix ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (alias runtest_lint) +diff --git a/src/proto_007_PsDELPH1/bin_endorser/dune b/src/proto_007_PsDELPH1/bin_endorser/dune +index 049bd25a20..cfded75264 100644 +--- a/src/proto_007_PsDELPH1/bin_endorser/dune ++++ b/src/proto_007_PsDELPH1/bin_endorser/dune +@@ -10,7 +10,9 @@ + -open Tezos_client_commands + -open Tezos_baking_007_PsDELPH1_commands + -open Tezos_stdlib_unix +- -open Tezos_client_base_unix))) ++ -open Tezos_client_base_unix ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (alias runtest_lint) +diff --git a/src/proto_008_PtEdo2Zk/bin_accuser/dune b/src/proto_008_PtEdo2Zk/bin_accuser/dune +index 7474b94d82..4b0db67606 100644 +--- a/src/proto_008_PtEdo2Zk/bin_accuser/dune ++++ b/src/proto_008_PtEdo2Zk/bin_accuser/dune +@@ -10,7 +10,9 @@ + -open Tezos_client_commands + -open Tezos_baking_008_PtEdo2Zk_commands + -open Tezos_stdlib_unix +- -open Tezos_client_base_unix))) ++ -open Tezos_client_base_unix ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (alias runtest_lint) +diff --git a/src/proto_008_PtEdo2Zk/bin_baker/dune b/src/proto_008_PtEdo2Zk/bin_baker/dune +index 3131e95c81..9b71de1e22 100644 +--- a/src/proto_008_PtEdo2Zk/bin_baker/dune ++++ b/src/proto_008_PtEdo2Zk/bin_baker/dune +@@ -10,7 +10,9 @@ + -open Tezos_client_commands + -open Tezos_baking_008_PtEdo2Zk_commands + -open Tezos_stdlib_unix +- -open Tezos_client_base_unix))) ++ -open Tezos_client_base_unix ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (alias runtest_lint) +diff --git a/src/proto_008_PtEdo2Zk/bin_endorser/dune b/src/proto_008_PtEdo2Zk/bin_endorser/dune +index 81ebe60753..43e57a2d0c 100644 +--- a/src/proto_008_PtEdo2Zk/bin_endorser/dune ++++ b/src/proto_008_PtEdo2Zk/bin_endorser/dune +@@ -10,7 +10,9 @@ + -open Tezos_client_commands + -open Tezos_baking_008_PtEdo2Zk_commands + -open Tezos_stdlib_unix +- -open Tezos_client_base_unix))) ++ -open Tezos_client_base_unix ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (alias runtest_lint) +diff --git a/src/proto_alpha/bin_accuser/dune b/src/proto_alpha/bin_accuser/dune +index ee20d869a2..1d6b596e09 100644 +--- a/src/proto_alpha/bin_accuser/dune ++++ b/src/proto_alpha/bin_accuser/dune +@@ -10,7 +10,9 @@ + -open Tezos_client_commands + -open Tezos_baking_alpha_commands + -open Tezos_stdlib_unix +- -open Tezos_client_base_unix))) ++ -open Tezos_client_base_unix ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (alias runtest_lint) +diff --git a/src/proto_alpha/bin_baker/dune b/src/proto_alpha/bin_baker/dune +index 5931e5c990..3a6f285d6d 100644 +--- a/src/proto_alpha/bin_baker/dune ++++ b/src/proto_alpha/bin_baker/dune +@@ -10,7 +10,9 @@ + -open Tezos_client_commands + -open Tezos_baking_alpha_commands + -open Tezos_stdlib_unix +- -open Tezos_client_base_unix))) ++ -open Tezos_client_base_unix ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (alias runtest_lint) +diff --git a/src/proto_alpha/bin_endorser/dune b/src/proto_alpha/bin_endorser/dune +index e822ec9a1e..f92c34805f 100644 +--- a/src/proto_alpha/bin_endorser/dune ++++ b/src/proto_alpha/bin_endorser/dune +@@ -10,7 +10,9 @@ + -open Tezos_client_commands + -open Tezos_baking_alpha_commands + -open Tezos_stdlib_unix +- -open Tezos_client_base_unix))) ++ -open Tezos_client_base_unix ++ -ccopt -static ++ -cclib "-lusb-1.0 -lhidapi-libusb -ludev"))) + + (rule + (alias runtest_lint) diff --git a/scripts/ci/create_docker_image.build.sh b/scripts/ci/create_docker_image.build.sh index 0e6938eab993d10cdfd977176fc4dad0a4efbedc..7df8281b810f2353a6c181baf9ce44eb8355d583 100755 --- a/scripts/ci/create_docker_image.build.sh +++ b/scripts/ci/create_docker_image.build.sh @@ -11,9 +11,9 @@ cd "$src_dir" image_name="${1:-tezos_build}" image_version="${2:-latest}" -base_image="${3-${image_name}_deps}" -base_image_version="${4:-latest}" -commit_short_sha="${5:-unknown}" +base_image="${3:-registry.gitlab.com/tezos/opam-repository}" +base_image_version="${4:-runtime-build-dependencies--${opam_repository_tag}}" +commit_short_sha="${5:-$(git rev-parse --short HEAD)}" echo echo "### Building tezos..." diff --git a/scripts/ci/create_docker_image.minimal.sh b/scripts/ci/create_docker_image.minimal.sh index d4d89c39fb7308b62b98acd0fd4aed27cae77d60..3126579d8117a42804e21787a2c9bd7d394df1b8 100755 --- a/scripts/ci/create_docker_image.minimal.sh +++ b/scripts/ci/create_docker_image.minimal.sh @@ -18,10 +18,11 @@ cd "$src_dir" image_name="${1:-tezos}" image_version="${2:-latest}" -build_image="${3:-registry.gitlab.com/tezos/opam-repository}" -base_image="${4-registry.gitlab.com/tezos/opam-repository}" -base_version="${5-minimal--${opam_repository_tag}}" -commit_short_sha="${6:-$(git rev-parse --short HEAD)}" +build_image="${3:-tezos_build}" +base_image="${4:-registry.gitlab.com/tezos/opam-repository}" +base_version="${5:-runtime-dependencies--${opam_repository_tag}}" +base_build_version="${6:-runtime-build-dependencies--${opam_repository_tag}}" +commit_short_sha="${7:-$(git rev-parse --short HEAD)}" echo echo "### Building minimal docker images..." @@ -31,7 +32,7 @@ docker build \ -t "$image_name-debug:$image_version" \ --build-arg "BASE_IMAGE=$base_image" \ --build-arg "BASE_IMAGE_VERSION=$base_version" \ - --build-arg "BASE_IMAGE_VERSION_NON_MIN=$opam_repository_tag" \ + --build-arg "BASE_IMAGE_VERSION_NON_MIN=$base_build_version" \ --build-arg "BUILD_IMAGE=${build_image}" \ --build-arg "BUILD_IMAGE_VERSION=${image_version}" \ --build-arg "COMMIT_SHORT_SHA=${commit_short_sha}" \ @@ -48,7 +49,7 @@ docker build \ --build-arg "BASE_IMAGE_VERSION=$base_version" \ --build-arg "BUILD_IMAGE=${build_image}" \ --build-arg "BUILD_IMAGE_VERSION=${image_version}" \ - --build-arg "BASE_IMAGE_VERSION_NON_MIN=$opam_repository_tag" \ + --build-arg "BASE_IMAGE_VERSION_NON_MIN=$base_build_version" \ --build-arg "COMMIT_SHORT_SHA=${commit_short_sha}" \ --target=bare \ "$src_dir" @@ -64,7 +65,7 @@ docker build \ --build-arg "BASE_IMAGE_VERSION=$base_version" \ --build-arg "BUILD_IMAGE=${build_image}" \ --build-arg "BUILD_IMAGE_VERSION=${image_version}" \ - --build-arg "BASE_IMAGE_VERSION_NON_MIN=$opam_repository_tag" \ + --build-arg "BASE_IMAGE_VERSION_NON_MIN=$base_build_version" \ --build-arg "COMMIT_SHORT_SHA=${commit_short_sha}" \ "$src_dir" diff --git a/scripts/create_docker_image.sh b/scripts/create_docker_image.sh index 9847b62320011e3f1a015557410c67d9d9567044..8908d00e426a7420a3d8b037052094101ffe8ca6 100755 --- a/scripts/create_docker_image.sh +++ b/scripts/create_docker_image.sh @@ -18,9 +18,10 @@ build_image_name="${image_name}_build" "$script_dir"/ci/create_docker_image.build.sh \ "$build_image_name" "$image_version" \ - "$build_deps_image_name" "$build_deps_image_version" "$commit_short_sha" + "$build_deps_image_name" "runtime-build-dependencies--$build_deps_image_version" "$commit_short_sha" "$script_dir"/ci/create_docker_image.minimal.sh \ "$image_name" "$image_version" \ - "$build_image_name" \ - "$build_deps_image_name" "minimal--$build_deps_image_version" "$commit_short_sha" + "$build_image_name" "$build_deps_image_name" \ + "runtime-dependencies--$build_deps_image_version" "runtime-build-dependencies--$build_deps_image_version" \ + "$commit_short_sha" diff --git a/scripts/install_build_deps.rust.sh b/scripts/install_build_deps.rust.sh index 3445312571b2d799f014542d41742d601657d217..fc413a4b85b9c7f2beb97b8297a05b9baab2edec 100755 --- a/scripts/install_build_deps.rust.sh +++ b/scripts/install_build_deps.rust.sh @@ -32,15 +32,15 @@ fi if ! [[ "$(rustc --version | cut -d' ' -f2)" == *"$rust_version"* ]]; then echo "\ -Wrong Rust version, run the following command in your favorite shell: +Wrong Rust version, run the following commands in your favorite shell: $ rustup toolchain install $rust_version -$ rustup override set $rust_version" +$ rustup override set $rust_version +or force it by setting the variable RUST_VERSION to your installed version +if you know what you are doing" exit 1 fi -LIBRARY_DIR="${OPAM_SWITCH_PREFIX}/lib" -# Install the headers in `include` -HEADER_DIR="${OPAM_SWITCH_PREFIX}/include" +LIBRARY_DIR="${OPAM_SWITCH_PREFIX}/lib/tezos-rust-libs" ZCASH_PARAMS="${OPAM_SWITCH_PREFIX}/share/zcash-params" BUILD_DIR=_build_rust @@ -51,14 +51,12 @@ function cleanup () { } trap cleanup EXIT INT -mkdir -p "${HEADER_DIR}" mkdir -p "${LIBRARY_DIR}" mkdir -p "${BUILD_DIR}/opam-repository" cd "${BUILD_DIR}"/opam-repository if [ ! -d .git ] ; then git init - git config --local protocol.version 2 git remote add origin "$opam_repository_url" fi @@ -70,18 +68,14 @@ git reset --hard "$opam_repository_tag" RUSTFLAGS='-C target-feature=-crt-static' cargo build --release --manifest-path rust/Cargo.toml ## librustzcash (Sapling) -echo "Installing Rust libraries of Sapling in ${LIBRARY_DIR}/librustzcash and headers in ${HEADER_DIR}/librustzcash" -mkdir -p "${LIBRARY_DIR}"/librustzcash -mkdir -p "${HEADER_DIR}"/librustzcash -cp rust/target/release/librustzcash.a "${LIBRARY_DIR}/librustzcash" -cp rust/librustzcash/include/librustzcash.h "${HEADER_DIR}/librustzcash" +echo "Installing Rust libraries of Sapling and their header in ${LIBRARY_DIR}" +cp rust/target/release/librustzcash.a "${LIBRARY_DIR}" +cp rust/librustzcash/include/librustzcash.h "${LIBRARY_DIR}" ## BLS12-381 -echo "Installing Rust libraries of BLS12-381 in ${LIBRARY_DIR}/rustc-bls12-381 and headers in ${HEADER_DIR}/rustc-bls12-381" -mkdir -p "${LIBRARY_DIR}"/rustc-bls12-381 -mkdir -p "${HEADER_DIR}"/rustc-bls12-381 -cp rust/rustc-bls12-381/include/rustc_bls12_381.h "${HEADER_DIR}/rustc-bls12-381" -cp rust/target/release/librustc_bls12_381.a "${LIBRARY_DIR}/rustc-bls12-381" +echo "Installing Rust libraries of BLS12-381 and their header in ${LIBRARY_DIR}" +cp rust/rustc-bls12-381/include/rustc_bls12_381.h "${LIBRARY_DIR}" +cp rust/target/release/librustc_bls12_381.a "${LIBRARY_DIR}" ## Required for Sapling. echo "Installing Sapling parameters in ${ZCASH_PARAMS}" diff --git a/scripts/link_protocol.sh b/scripts/link_protocol.sh index 3577f84b47efba4d607df0b524513d07f742b418..d42556b2dc3552bd07d20582c65df3d74d802b89 100755 --- a/scripts/link_protocol.sh +++ b/scripts/link_protocol.sh @@ -133,9 +133,6 @@ duplicate_and_replace_only_1_occ -${pattern} -${replacement} \ src/bin_node/dune duplicate_and_replace -${pattern} -${replacement} \ src/bin_node/tezos-node.opam -duplicate_and_replace $(echo $pattern | sed 's/-/_/') \ - $(echo $replacement | sed 's/-/_/') \ - src/bin_node/node_config_command.ml duplicate_and_replace -${pattern} -${replacement} \ src/bin_validation/{dune,tezos-validator.opam} diff --git a/scripts/release/README.md b/scripts/release/README.md new file mode 100644 index 0000000000000000000000000000000000000000..ec380bf61ff19756a303dfd83ceb64a9511192dc --- /dev/null +++ b/scripts/release/README.md @@ -0,0 +1,14 @@ +# Static Tezos binaries automatic releasing + +This directory contains scripts required for releasing static Tezos +binaries: +* `binaries.sh` script creates a list of binaries that are going to be published + this list is later used in other scripts. +* `upload-static-binaries-to-package-registry.sh` script uploads all the binaries + to the gitlab package registry. Registry should be defined by the `PACKAGE_REGISTRY_URL` + environment variable. Access to the package registry is provided by the token defined in + the `CI_JOB_TOKEN` environment variable. +* `create-release-with-static-binaries.sh` script creates a release using the binaries that + were previously uploaded to the package registry as release assets. Source package registry + should be defined by the `PACKAGE_REGISTRY_URL` environment variable. Release name and tag + are defined by the `CI_COMMIT_TAG` environment variable. diff --git a/scripts/release/binaries.sh b/scripts/release/binaries.sh new file mode 100755 index 0000000000000000000000000000000000000000..bb43a622a765193f23946f87f4d397eeaf5a5a96 --- /dev/null +++ b/scripts/release/binaries.sh @@ -0,0 +1,7 @@ +#! /usr/bin/env bash + +binaries=("tezos-admin-client" "tezos-client" "tezos-node" "tezos-signer" "tezos-codec") + +for proto in $(cat active_protocol_versions); do + binaries+=("tezos-accuser-$proto" "tezos-baker-$proto" "tezos-endorser-$proto") +done diff --git a/scripts/release/create-release-with-static-binaries.sh b/scripts/release/create-release-with-static-binaries.sh new file mode 100755 index 0000000000000000000000000000000000000000..d410743f3f250505672e7e9bc677078ca8c79cba --- /dev/null +++ b/scripts/release/create-release-with-static-binaries.sh @@ -0,0 +1,28 @@ +#! /usr/bin/env bash + +set -euo pipefail + +. scripts/release/binaries.sh + +assets=() +for binary in "${binaries[@]}"; do + asset_json="$(jq -n --arg name "$binary (x86_64 Linux)" \ + --arg url "$PACKAGE_REGISTRY_URL/x86_64-$binary" \ + '{name: $name, url: $url}')" + assets+=("--assets-link=$asset_json") + asset_json="$(jq -n --arg name "$binary (arm64 Linux)" \ + --arg url "$PACKAGE_REGISTRY_URL/arm64-$binary" \ + '{name: $name, url: $url}')" + assets+=("--assets-link=$asset_json") +done + +archive_url="$(jq -n --arg name "x86_64-linux-tezos-binaries.tar.gz" \ + --arg url "$PACKAGE_REGISTRY_URL/x86_64-tezos-binaries.tar.gz" \ + '{name: $name, url: $url}')" +assets+=("--assets-link=$archive_url") +archive_url="$(jq -n --arg name "arm64-linux-tezos-binaries.tar.gz" \ + --arg url "$PACKAGE_REGISTRY_URL/arm64-tezos-binaries.tar.gz" \ + '{name: $name, url: $url}')" +assets+=("--assets-link=$archive_url") + +release-cli create --name "Release $CI_COMMIT_TAG" --tag-name "$CI_COMMIT_TAG" "${assets[@]}" diff --git a/scripts/release/upload-static-binaries-to-package-registry.sh b/scripts/release/upload-static-binaries-to-package-registry.sh new file mode 100755 index 0000000000000000000000000000000000000000..56e7ba1fc72f9f2f67d06fafb6a7a687618d0387 --- /dev/null +++ b/scripts/release/upload-static-binaries-to-package-registry.sh @@ -0,0 +1,21 @@ +#! /usr/bin/env bash + +set -euo pipefail + +ARCH_PREFIX=$1 + +. scripts/release/binaries.sh + +for binary in "${binaries[@]}"; do + curl --header "JOB-TOKEN: $CI_JOB_TOKEN" \ + --upload-file "install_root/bin/$binary" \ + "$PACKAGE_REGISTRY_URL/${ARCH_PREFIX}$binary" +done + +# Create .tag.gz archive with all binaries and upload it +cd install_root/bin +tar -czf ../../tezos-binaries.tar.gz . +cd ../.. +curl --header "JOB-TOKEN: $CI_JOB_TOKEN" \ + --upload-file tezos-binaries.tar.gz \ + "$PACKAGE_REGISTRY_URL/${ARCH_PREFIX}tezos-binaries.tar.gz" diff --git a/scripts/tezos-docker-manager.sh b/scripts/tezos-docker-manager.sh index d2f64706f3421796116cd19b96d41cb03bdaf97a..431189ad7d03850cca7a326c374546b735b2a7f3 100755 --- a/scripts/tezos-docker-manager.sh +++ b/scripts/tezos-docker-manager.sh @@ -704,21 +704,21 @@ if [ "$#" -eq 0 ] ; then usage ; exit 1; else shift ; fi case $(basename "$0") in delphinet.sh) docker_base_dir="$HOME/.tezos-delphinet" - docker_image=tezos/tezos:master + docker_image=tezos/tezos:v8.2 docker_compose_base_name=delphinet default_port=9732 network=delphinet ;; edonet.sh) docker_base_dir="$HOME/.tezos-edonet" - docker_image=tezos/tezos:master + docker_image=tezos/tezos:v8.2 docker_compose_base_name=edonet default_port=9732 network=edonet ;; *) docker_base_dir="$HOME/.tezos-mainnet" - docker_image=tezos/tezos:master + docker_image=tezos/tezos:v8.2 docker_compose_base_name="mainnet" default_port=9732 network=mainnet diff --git a/scripts/update_opam_repo.sh b/scripts/update_opam_repo.sh index f249357cc9a494257eca0d4029e23c67b263c217..53b1531af2247c53d134ebfb6150cd8ba3d23ca0 100755 --- a/scripts/update_opam_repo.sh +++ b/scripts/update_opam_repo.sh @@ -88,7 +88,7 @@ done ## Filtering unrequired packages cd $tmp_dir git reset --hard "$full_opam_repository_tag" -opam admin filter --yes --resolve \ +OPAMSOLVERTIMEOUT=600 opam admin filter --yes --resolve \ $packages,ocaml,ocaml-base-compiler,odoc,opam-depext,js_of_ocaml-ppx,reactiveData,opam-ed ## Adding useful compiler variants diff --git a/scripts/version.sh b/scripts/version.sh index 18c648189e2be78ecd4ab11c306e88abdd3235ed..f85d71512ac9209642dc5f66838453308fd0b2e5 100755 --- a/scripts/version.sh +++ b/scripts/version.sh @@ -5,15 +5,15 @@ ocaml_version=4.09.1 opam_version=2.0 -recommended_rust_version=1.39.0 +recommended_rust_version=1.44.0 ## Please update `.gitlab-ci.yml` accordingly ## full_opam_repository is a commit hash of the public OPAM repository, i.e. ## https://github.com/ocaml/opam-repository -full_opam_repository_tag=120600db4b411fb9e676166d275eb74e03b09cfc +full_opam_repository_tag=166a3a212b1c2e088dcedde0442c07514fd9efa6 ## opam_repository is an additional, tezos-specific opam repository. -opam_repository_tag=c916fd9f0698d7ae0d30114a328c78608b693d6a +opam_repository_tag=b7b6954bce4612682abc76139171caeb2abd1b80 opam_repository_url=https://gitlab.com/tezos/opam-repository.git opam_repository=$opam_repository_url\#$opam_repository_tag diff --git a/src/bin_client/dune b/src/bin_client/dune index 576b333257674efc03b64887377d418a69f91304..fd35be4bbf49a03c3424fc2b114853b21b14c6ff 100644 --- a/src/bin_client/dune +++ b/src/bin_client/dune @@ -45,9 +45,9 @@ (select void_for_linking-007-PsDELPH1 from (tezos-client-007-PsDELPH1-commands-registration -> void_for_linking-007-PsDELPH1.empty) (-> void_for_linking-007-PsDELPH1.empty)) - (select void_for_linking-008-PtEdoTez from - (tezos-client-008-PtEdoTez-commands-registration -> void_for_linking-008-PtEdoTez.empty) - (-> void_for_linking-008-PtEdoTez.empty)) + (select void_for_linking-008-PtEdo2Zk from + (tezos-client-008-PtEdo2Zk-commands-registration -> void_for_linking-008-PtEdo2Zk.empty) + (-> void_for_linking-008-PtEdo2Zk.empty)) (select void_for_linking-alpha from (tezos-client-alpha-commands-registration -> void_for_linking-alpha.empty) @@ -65,10 +65,9 @@ (select void_for_linking-baking-007-PsDELPH1 from (tezos-baking-007-PsDELPH1-commands.registration -> void_for_linking-baking-007-PsDELPH1.empty) (-> void_for_linking-baking-007-PsDELPH1.empty)) - (select void_for_linking-baking-008-PtEdoTez from - (tezos-baking-008-PtEdoTez-commands.registration -> void_for_linking-baking-008-PtEdoTez.empty) - (-> void_for_linking-baking-008-PtEdoTez.empty)) - + (select void_for_linking-baking-008-PtEdo2Zk from + (tezos-baking-008-PtEdo2Zk-commands.registration -> void_for_linking-baking-008-PtEdo2Zk.empty) + (-> void_for_linking-baking-008-PtEdo2Zk.empty)) tezos-stdlib-unix tezos-client-base-unix tezos-signer-backends.unix) @@ -96,13 +95,13 @@ (write-file void_for_linking-005-PsBabyM1.empty "") (write-file void_for_linking-006-PsCARTHA.empty "") (write-file void_for_linking-007-PsDELPH1.empty "") - (write-file void_for_linking-008-PtEdoTez.empty "") + (write-file void_for_linking-008-PtEdo2Zk.empty "") (write-file void_for_linking-alpha.empty "") (write-file void_for_linking-demo-counter.empty "") (write-file void_for_linking-baking-alpha.empty "") (write-file void_for_linking-baking-006-PsCARTHA.empty "") (write-file void_for_linking-baking-007-PsDELPH1.empty "") - (write-file void_for_linking-baking-008-PtEdoTez.empty "") + (write-file void_for_linking-baking-008-PtEdo2Zk.empty "") ))) (install diff --git a/src/bin_client/tezos-client.opam b/src/bin_client/tezos-client.opam index 31e3fccfe774da2d9a17e1b225b9c8fd8c1d4c6a..379e8c7c3e78064c26721e353cc1dd41f8319404 100644 --- a/src/bin_client/tezos-client.opam +++ b/src/bin_client/tezos-client.opam @@ -23,7 +23,7 @@ depends: [ "tezos-client-005-PsBabyM1" "tezos-client-006-PsCARTHA" "tezos-client-007-PsDELPH1" - "tezos-client-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" "tezos-client-demo-counter" "tezos-client-alpha-commands" @@ -34,12 +34,12 @@ depends: [ "tezos-client-005-PsBabyM1-commands" "tezos-client-006-PsCARTHA-commands" "tezos-client-007-PsDELPH1-commands-registration" - "tezos-client-008-PtEdoTez-commands-registration" + "tezos-client-008-PtEdo2Zk-commands-registration" "tezos-baking-alpha-commands" "tezos-baking-006-PsCARTHA-commands" "tezos-baking-007-PsDELPH1-commands" - "tezos-baking-008-PtEdoTez-commands" + "tezos-baking-008-PtEdo2Zk-commands" "tezos-client-base-unix" "tezos-mockup-commands" diff --git a/src/bin_codec/dune b/src/bin_codec/dune index 552f7bd835cbab93a0dee13db2d139d896f55f83..e7939569a7ed9d6170614880981ab99f61803221 100644 --- a/src/bin_codec/dune +++ b/src/bin_codec/dune @@ -22,9 +22,9 @@ (select void_for_linking-007-PsDELPH1 from (tezos-client-007-PsDELPH1 -> void_for_linking-007-PsDELPH1.empty) (-> void_for_linking-007-PsDELPH1.empty)) - (select void_for_linking-008-PtEdoTez from - (tezos-client-008-PtEdoTez -> void_for_linking-008-PtEdoTez.empty) - (-> void_for_linking-008-PtEdoTez.empty)) + (select void_for_linking-008-PtEdo2Zk from + (tezos-client-008-PtEdo2Zk -> void_for_linking-008-PtEdo2Zk.empty) + (-> void_for_linking-008-PtEdo2Zk.empty)) ) (flags (:standard -open Data_encoding -open Tezos_base__TzPervasives @@ -42,7 +42,7 @@ (write-file void_for_linking-005-PsBabyM1.empty "") (write-file void_for_linking-006-PsCARTHA.empty "") (write-file void_for_linking-007-PsDELPH1.empty "") - (write-file void_for_linking-008-PtEdoTez.empty "") + (write-file void_for_linking-008-PtEdo2Zk.empty "") ))) (rule diff --git a/src/bin_codec/tezos-codec.opam b/src/bin_codec/tezos-codec.opam index 12e447e9e312da256b3385f59002e0c602cc7cce..69cb2ee1b671b2625b52deaeb8e7623b874bfbbb 100644 --- a/src/bin_codec/tezos-codec.opam +++ b/src/bin_codec/tezos-codec.opam @@ -22,7 +22,7 @@ depopts: [ "tezos-client-005-PsBabyM1" "tezos-client-006-PsCARTHA" "tezos-client-007-PsDELPH1" - "tezos-client-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/bin_node/dune b/src/bin_node/dune index b284c57925080d141217e4997971d4f68337ba75..36fd28a5ebe3515a358ab5cf04152530b34d63b5 100644 --- a/src/bin_node/dune +++ b/src/bin_node/dune @@ -68,17 +68,17 @@ (select void_for_linking-008-PtEdoTez from (tezos-embedded-protocol-008-PtEdoTez -> void_for_linking-008-PtEdoTez.empty) (-> void_for_linking-008-PtEdoTez.empty)) - (select void_for_linking-006-PsCARTHA-mempool from - (tezos-mempool-006-PsCARTHA -> void_for_linking-006-PsCARTHA-mempool.empty) - (-> void_for_linking-006-PsCARTHA-mempool.empty)) - (select void_for_linking-007-PsDELPH1-mempool from - (tezos-mempool-007-PsDELPH1 -> void_for_linking-007-PsDELPH1-mempool.empty) - (-> void_for_linking-007-PsDELPH1-mempool.empty)) - (select void_for_linking-008-PtEdoTez-mempool from - (tezos-mempool-008-PtEdoTez -> void_for_linking-008-PtEdoTez-mempool.empty) - (-> void_for_linking-008-PtEdoTez-mempool.empty)) - cmdliner - tls) + (select void_for_linking-008-PtEdo2Zk from + (tezos-embedded-protocol-008-PtEdo2Zk -> void_for_linking-008-PtEdo2Zk.empty) + (-> void_for_linking-008-PtEdo2Zk.empty)) + (select void_for_linking-007-PsDELPH1-protocol-plugin-registerer from + (tezos-protocol-plugin-007-PsDELPH1-registerer -> void_for_linking-007-PsDELPH1-protocol-plugin-registerer.empty) + (-> void_for_linking-007-PsDELPH1-protocol-plugin-registerer.empty)) + (select void_for_linking-008-PtEdo2Zk-protocol-plugin-registerer from + (tezos-protocol-plugin-008-PtEdo2Zk-registerer -> void_for_linking-008-PtEdo2Zk-protocol-plugin-registerer.empty) + (-> void_for_linking-008-PtEdo2Zk-protocol-plugin-registerer.empty)) + cmdliner + tls) (flags (:standard -open Tezos_base__TzPervasives -open Tezos_base -open Tezos_stdlib_unix @@ -112,9 +112,9 @@ (write-file void_for_linking-006-PsCARTHA.empty "") (write-file void_for_linking-007-PsDELPH1.empty "") (write-file void_for_linking-008-PtEdoTez.empty "") - (write-file void_for_linking-006-PsCARTHA-mempool.empty "") - (write-file void_for_linking-007-PsDELPH1-mempool.empty "") - (write-file void_for_linking-008-PtEdoTez-mempool.empty "") + (write-file void_for_linking-008-PtEdo2Zk.empty "") + (write-file void_for_linking-007-PsDELPH1-protocol-plugin-registerer.empty "") + (write-file void_for_linking-008-PtEdo2Zk-protocol-plugin-registerer.empty "") ))) (install diff --git a/src/bin_node/main.ml b/src/bin_node/main.ml index ab095337d750976f44df9ad49932dbfce36390f5..18e50fe2b752ae3d6516c74e58b83ca59e8c5794 100644 --- a/src/bin_node/main.ml +++ b/src/bin_node/main.ml @@ -96,6 +96,21 @@ let commands = Node_snapshot_command.cmd; Node_reconstruct_command.cmd ] +(* This call is not strictly necessary as the parameters are initialized + lazily the first time a Sapling operation (validation or forging) is + done. This is what the client does. + For a long running binary however it is important to make sure that the + parameters files are there at the start and avoid failing much later while + validating an operation. Plus paying this cost upfront means that the first + validation will not be more expensive. *) +let () = + try Tezos_sapling.Core.Validator.init_params () + with exn -> + Printf.eprintf + "Failed to initialize Zcash parameters: %s" + (Printexc.to_string exn) ; + exit 1 + let () = Random.self_init () ; match Cmdliner.Term.eval_choice (term, info) commands with diff --git a/src/bin_node/node_config_command.ml b/src/bin_node/node_config_command.ml index 22625137c0282cacd61d9e690c3a79fa3df318c1..cafdca6ea8af2fe535450bea62b7a7c19014b8c4 100644 --- a/src/bin_node/node_config_command.ml +++ b/src/bin_node/node_config_command.ml @@ -23,12 +23,6 @@ (* *) (*****************************************************************************) -let () = - Prevalidator_filters.register (module Tezos_mempool_006_PsCARTHA.Filter) ; - Prevalidator_filters.register (module Tezos_mempool_007_PsDELPH1.Filter) ; - Prevalidator_filters.register (module Tezos_mempool_008_PtEdoTez.Filter) ; - () - (** Commands *) let show (args : Node_shared_arg.t) = diff --git a/src/bin_node/node_config_file.ml b/src/bin_node/node_config_file.ml index 77a2e92f2863099f6bda7891d1fa11030171c4e2..a19aeb584ed3c3bfb0adb7339ce7267db80184ff 100644 --- a/src/bin_node/node_config_file.ml +++ b/src/bin_node/node_config_file.ml @@ -79,6 +79,8 @@ let make_blockchain_network ~alias ~chain_name ?old_chain_name } let blockchain_network_mainnet = + let giganode_1 = "116.202.172.21" in + let giganode_2 = "95.216.45.62" in make_blockchain_network ~alias:"mainnet" { @@ -99,8 +101,10 @@ let blockchain_network_mainnet = (204761l, "PsddFKi32cMJ2qPjf43Qv5GDWLDPZb3T3bF6fLKiF5HtvHNU7aP") ] ~user_activated_protocol_overrides: [ ( "PsBABY5HQTSkA4297zNHfsZNKtxULfL18y95qb3m53QJiXGmrbU", - "PsBabyM1eUXZseaJdmXFApDSBqj8YBfwELoxZHHW77EMcAbbwAS" ) ] - ~default_bootstrap_peers:["boot.tzbeta.net"] + "PsBabyM1eUXZseaJdmXFApDSBqj8YBfwELoxZHHW77EMcAbbwAS" ); + ( "PtEdoTezd3RHSC31mpxxo1npxFjoWWcFgQtxapi51Z8TLu6v6Uq", + "PtEdo2ZkT9oKpimTah6x2embF25oss54njMuPzkJTEi5RqfdZFA" ) ] + ~default_bootstrap_peers:["boot.tzbeta.net"; giganode_1; giganode_2] let blockchain_network_delphinet = make_blockchain_network @@ -161,7 +165,8 @@ let blockchain_network_edonet = "edonet.smartpy.io"; "188.40.128.216:29732"; "51.79.165.131"; - "edonet.boot.tezostaquito.io" ] + "edonet.boot.tezostaquito.io"; + "95.216.228.228:9733" ] let blockchain_network_sandbox = make_blockchain_network diff --git a/src/bin_node/node_data_version.ml b/src/bin_node/node_data_version.ml index 54b867838caf73ca7f49bf0c95bb91eac87d4aa1..0eb1e741347c2d93b3b73235a18321f309112af6 100644 --- a/src/bin_node/node_data_version.ml +++ b/src/bin_node/node_data_version.ml @@ -23,8 +23,6 @@ (* *) (*****************************************************************************) -let lwt_emit = Node_data_version_state.lwt_emit - open Filename.Infix type t = string @@ -155,6 +153,63 @@ let () = None) (fun (expected, actual) -> Data_dir_needs_upgrade {expected; actual}) +module Events = struct + open Internal_event.Simple + + let section = ["node_data_version"] + + let dir_is_up_to_date = + declare_0 + ~section + ~level:Notice + ~name:"dir_is_up_to_date" + ~msg:"node data dir is up-to-date" + () + + let upgrading_node = + declare_2 + ~section + ~level:Notice + ~name:"upgrading_node" + ~msg:"upgrading data directory from {old_version} to {new_version}" + ~pp1:Format.pp_print_string + ("old_version", Data_encoding.string) + ~pp2:Format.pp_print_string + ("new_version", Data_encoding.string) + + let update_success = + declare_0 + ~section + ~level:Notice + ~name:"update_success" + ~msg:"the node data dir is now up-to-date" + () + + let aborting_upgrade = + declare_1 + ~section + ~level:Notice + ~name:"aborting_upgrade" + ~msg:"failed to upgrade storage: {error}" + ~pp1:Error_monad.pp_print_error + ("error", Error_monad.trace_encoding) + + let upgrade_status = + declare_2 + ~section + ~level:Notice + ~name:"upgrade_status" + ~msg: + "current version: {current_version}, available version: \ + {available_version}" + ~pp1:Format.pp_print_string + ("current_version", Data_encoding.string) + ~pp2:Format.pp_print_string + ("available_version", Data_encoding.string) + + let emit = Internal_event.Simple.emit +end + let version_file data_dir = Filename.concat data_dir version_file_name let clean_directory files = @@ -244,22 +299,18 @@ let upgrade_data_dir data_dir = ensure_data_dir false data_dir >>=? function | None -> - lwt_emit Dir_is_up_to_date >>= fun () -> return_unit + Events.(emit dir_is_up_to_date ()) >>= fun () -> return_unit | Some (version, upgrade) -> ( - lwt_emit (Upgrading_node (version, data_version)) + Events.(emit upgrading_node (version, data_version)) >>= fun () -> upgrade ~data_dir >>= function | Ok () -> write_version_file data_dir - >>=? fun () -> lwt_emit Update_success >>= fun () -> return_unit + >>=? fun () -> + Events.(emit update_success ()) >>= fun () -> return_unit | Error e -> - Format.kasprintf - (fun errs -> lwt_emit (Aborting_upgrade errs)) - "%a" - Error_monad.pp_print_error - e - >>= fun () -> return_unit ) + Events.(emit aborting_upgrade e) >>= fun () -> return_unit ) let ensure_data_dir ?(bare = false) data_dir = ensure_data_dir bare data_dir @@ -272,16 +323,5 @@ let ensure_data_dir ?(bare = false) data_dir = let upgrade_status data_dir = read_version_file (version_file data_dir) >>=? fun data_dir_version -> - let upgradable_status = - match List.assoc_opt data_dir_version upgradable_data_version with - | Some _upgr -> - true - | None -> - false - in - let available_version = - if upgradable_status then Some data_version else None - in - lwt_emit - (Upgrade_status (upgradable_status, data_dir_version, available_version)) + Events.(emit upgrade_status (data_dir_version, data_version)) >>= fun () -> return_unit diff --git a/src/bin_node/node_data_version_state.ml b/src/bin_node/node_data_version_state.ml deleted file mode 100644 index 51b7de1cea9c55668a0165b48dbe1e85bc1bd429..0000000000000000000000000000000000000000 --- a/src/bin_node/node_data_version_state.ml +++ /dev/null @@ -1,133 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2019 Dynamic Ledger Solutions, Inc. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -type status = - | Dir_is_up_to_date - | Upgrading_node of string * string - | Update_success - | Aborting_upgrade of string - | Upgrade_status of bool * string * string option - -let status_pp ppf = function - | Dir_is_up_to_date -> - Format.fprintf ppf "Node data dir is up-to-date." - | Upgrading_node (version, data_version) -> - Format.fprintf - ppf - "Upgrading node data dir from %s to %s...@.Please, do not interrupt \ - the process." - version - data_version - | Update_success -> - Format.fprintf ppf "The node data dir is now up-to-date!" - | Aborting_upgrade errs -> - Format.fprintf - ppf - "%s@.Aborting upgrade. The storage was not upgraded." - errs - | Upgrade_status (upgradable_status, data_dir_version, available_version) -> - Format.fprintf - ppf - "Upgrade available: %a@.Current version: %a%a" - Format.pp_print_bool - upgradable_status - Format.pp_print_string - data_dir_version - (Option.pp ~default:"" (fun ppf -> - Format.fprintf ppf "@.Available version: %s")) - available_version - -type s = status Time.System.stamped - -module Definition = struct - let name = "node_data_version" - - type nonrec t = s - - let encoding = - let open Data_encoding in - Time.System.stamped_encoding - @@ union - [ case - (Tag 0) - ~title:"Dir_is_up_to_date" - empty - (function Dir_is_up_to_date -> Some () | _ -> None) - (fun () -> Dir_is_up_to_date); - case - (Tag 1) - ~title:"Upgrading_node" - (tup2 string string) - (function Upgrading_node (v, dd) -> Some (v, dd) | _ -> None) - (fun (v, dd) -> Upgrading_node (v, dd)); - case - (Tag 2) - ~title:"Update_success" - empty - (function Update_success -> Some () | _ -> None) - (fun () -> Update_success); - case - (Tag 3) - ~title:"Aborting_upgrade" - string - (function Aborting_upgrade errs -> Some errs | _ -> None) - (fun errs -> Aborting_upgrade errs); - case - (Tag 4) - ~title:"Upgrade_status" - (tup3 bool string (option string)) - (function - | Upgrade_status (s, cv, av) -> Some (s, cv, av) | _ -> None) - (fun (s, cv, av) -> Upgrade_status (s, cv, av)) ] - - let pp ~short:_ ppf (status : t) = - Format.fprintf ppf "%a" status_pp status.data - - let doc = "Node data version status." - - let level (status : t) = - match status.data with - | Dir_is_up_to_date | Upgrading_node _ | Update_success -> - Internal_event.Notice - | Upgrade_status _ | Aborting_upgrade _ -> - Internal_event.Error -end - -module Event_node_data_version = Internal_event.Make (Definition) - -let lwt_emit (status : status) = - let time = Systime_os.now () in - Event_node_data_version.emit - ~section:(Internal_event.Section.make_sanitized [Definition.name]) - (fun () -> Time.System.stamp ~time status) - >>= function - | Ok () -> - Lwt.return_unit - | Error el -> - Format.kasprintf - Lwt.fail_with - "Node_data_version_event.emit: %a" - pp_print_error - el diff --git a/src/bin_node/tezos-node.opam b/src/bin_node/tezos-node.opam index a989875320c542b47e66e2c4908aa029c0144cfd..42c4c1fa8e68296145e2061c53203babf7d88b1c 100644 --- a/src/bin_node/tezos-node.opam +++ b/src/bin_node/tezos-node.opam @@ -31,12 +31,11 @@ depends: [ "tezos-embedded-protocol-005-PsBabyM1" "tezos-embedded-protocol-006-PsCARTHA" "tezos-embedded-protocol-007-PsDELPH1" - "tezos-embedded-protocol-008-PtEdoTez" - "tezos-mempool-006-PsCARTHA" - "tezos-mempool-007-PsDELPH1" - "tezos-mempool-008-PtEdoTez" + "tezos-embedded-protocol-008-PtEdo2Zk" + "tezos-protocol-plugin-007-PsDELPH1-registerer" + "tezos-protocol-plugin-008-PtEdo2Zk-registerer" "cmdliner" - "tls" { >= "0.11" < "0.12" } # remove the upper bond when the compatibility with hacl-star is restored + "tls" { >= "0.10" < "0.11" } # remove the upper bond when the compatibility with hacl-star is restored "cstruct" ] build: [ diff --git a/src/bin_snoop/latex/test/dune b/src/bin_snoop/latex/test/dune index d7f149c9945918ce6b683168360df1fbe29b9cad..654945acb959ab89ae25d569829a29c21c527082 100644 --- a/src/bin_snoop/latex/test/dune +++ b/src/bin_snoop/latex/test/dune @@ -1,4 +1,5 @@ (test (name test) + (package latex) (libraries latex) ) diff --git a/src/bin_validation/validator.ml b/src/bin_validation/validator.ml index f3ca53a332213c04cc2cf73b06730ee5a99bcd85..284310099d0cf0221f6567266b04dcaa190397a9 100644 --- a/src/bin_validation/validator.ml +++ b/src/bin_validation/validator.ml @@ -24,137 +24,81 @@ (* *) (*****************************************************************************) -type status = - | Initialized - | Dynload_protocol of Protocol_hash.t - | Validation_request of Block_header.t - | Commit_genesis_request of Block_hash.t - | Initialization_request - | Fork_test_chain_request of Block_header.t - | Termination_request - | Terminated +module Events = struct + open Internal_event.Simple -let status_pp ppf = function - | Initialized -> - Format.fprintf ppf "Validator initialized and listening" - | Dynload_protocol h -> - Format.fprintf ppf "Dynamic loading of protocol %a" Protocol_hash.pp h - | Validation_request bh -> - Format.fprintf - ppf - "Validating block %a" - Block_hash.pp - (Block_header.hash bh) - | Commit_genesis_request h -> - Format.fprintf ppf "Committing genesis block %a" Block_hash.pp h - | Initialization_request -> - Format.fprintf ppf "Initializing validator's environment" - | Fork_test_chain_request bh -> - Format.fprintf - ppf - "Forking test chain at block %a" - Block_hash.pp - (Block_header.hash bh) - | Termination_request -> - Format.fprintf ppf "Terminating external validator" - | Terminated -> - Format.fprintf ppf "Validator terminated" + let section = ["external_validator"] -type s = status Time.System.stamped + let initialized = + declare_0 + ~section + ~level:Info + ~name:"initialized" + ~msg:"validator initialized and listening" + () -module Validator_event_definition = struct - let name = "external_validator" + let terminated = + declare_0 + ~section + ~level:Info + ~name:"terminated_request" + ~msg:"validator terminated" + () - type t = s + let dynload_protocol = + declare_1 + ~section + ~level:Debug + ~name:"dynload_protocol" + ~msg:"dynamic loading of protocol {protocol}" + ~pp1:Protocol_hash.pp + ("protocol", Protocol_hash.encoding) - let encoding = - let open Data_encoding in - Time.System.stamped_encoding - @@ union - [ case - (Tag 0) - ~title:"Initialized" - empty - (function Initialized -> Some () | _ -> None) - (fun () -> Initialized); - case - (Tag 1) - ~title:"Dynload protocol" - Protocol_hash.encoding - (function Dynload_protocol h -> Some h | _ -> None) - (fun h -> Dynload_protocol h); - case - (Tag 2) - ~title:"Validation request" - Block_header.encoding - (function Validation_request h -> Some h | _ -> None) - (fun h -> Validation_request h); - case - (Tag 3) - ~title:"Commit genesis request" - Block_hash.encoding - (function Commit_genesis_request h -> Some h | _ -> None) - (fun h -> Commit_genesis_request h); - case - (Tag 4) - ~title:"Initialization request" - empty - (function Initialization_request -> Some () | _ -> None) - (fun () -> Initialization_request); - case - (Tag 5) - ~title:"Fork test chain request" - Block_header.encoding - (function Fork_test_chain_request h -> Some h | _ -> None) - (fun h -> Fork_test_chain_request h); - case - (Tag 6) - ~title:"Termination request" - empty - (function Termination_request -> Some () | _ -> None) - (fun () -> Termination_request); - case - (Tag 7) - ~title:"Terminated" - empty - (function Terminated -> Some () | _ -> None) - (fun () -> Terminated) ] + let validation_request = + declare_1 + ~section + ~level:Debug + ~name:"validation_request" + ~msg:"validating block {block}" + ~pp1:(fun fmt header -> Block_hash.pp fmt (Block_header.hash header)) + ("block", Block_header.encoding) - let pp ~short:_ ppf (status : t) = - Format.fprintf ppf "%a" status_pp status.data + let commit_genesis_request = + declare_1 + ~section + ~level:Debug + ~name:"commit_genesis_request" + ~msg:"committing genesis block {genesis}" + ~pp1:Block_hash.pp + ("genesis", Block_hash.encoding) - let doc = "External validator status." + let initialization_request = + declare_0 + ~section + ~level:Debug + ~name:"initialization_request" + ~msg:"initializing validator's environment" + () - let level (status : t) = - match status.data with - | Initialized | Terminated -> - Internal_event.Info - | Dynload_protocol _ - | Validation_request _ - | Commit_genesis_request _ - | Initialization_request - | Fork_test_chain_request _ - | Termination_request -> - Internal_event.Debug -end + let fork_test_chain_request = + declare_1 + ~section + ~level:Debug + ~name:"fork_testchain_request" + ~msg:"forking test chain at block {block}" + ~pp1:Block_header.pp + ("block", Block_header.encoding) -module Validator_event = Internal_event.Make (Validator_event_definition) + let termination_request = + declare_0 + ~section + ~level:Debug + ~name:"termination_request" + ~msg:"validator terminated" + () -let lwt_emit (status : status) = - let time = Systime_os.now () in - Validator_event.emit - ~section: - (Internal_event.Section.make_sanitized [Validator_event_definition.name]) - (fun () -> Time.System.stamp ~time status) - >>= function - | Ok () -> - Lwt.return_unit - | Error el -> - Format.kasprintf - Lwt.fail_with - "External_validator_event.emit: %a" - pp_print_error - el + let emit = Internal_event.Simple.emit +end open Filename.Infix @@ -166,7 +110,7 @@ let load_protocol proto protocol_root = // Protocol_hash.to_short_b58check proto // Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp proto in - lwt_emit (Dynload_protocol proto) + Events.(emit dynload_protocol proto) >|= fun () -> try Dynlink.loadfile_private cmxs_file ; @@ -198,7 +142,7 @@ let handshake input output = (inconsistent_handshake "bad magic") let init input = - lwt_emit Initialization_request + Events.(emit initialization_request ()) >>= fun () -> External_validation.recv input External_validation.parameters_encoding >>= fun { context_root; @@ -243,7 +187,7 @@ let run input output = init >>= loop | External_validation.Commit_genesis {chain_id} -> let commit_genesis : unit Lwt.t = - lwt_emit (Commit_genesis_request genesis.block) + Events.(emit commit_genesis_request genesis.block) >>= fun () -> Error_monad.protect (fun () -> Context.commit_genesis @@ -276,7 +220,7 @@ let run input output = operations; max_operations_ttl } -> let validate : unit Lwt.t = - lwt_emit (Validation_request block_header) + Events.(emit validation_request block_header) >>= fun () -> Error_monad.protect (fun () -> let pred_context_hash = predecessor_block_header.shell.context in @@ -328,7 +272,7 @@ let run input output = validate >>= loop | External_validation.Fork_test_chain {context_hash; forked_header} -> let fork_test_chain : unit Lwt.t = - lwt_emit (Fork_test_chain_request forked_header) + Events.(emit fork_test_chain_request forked_header) >>= fun () -> Context.checkout context_index context_hash >>= function @@ -358,7 +302,7 @@ let run input output = in fork_test_chain >>= loop | External_validation.Terminate -> - Lwt_io.flush_all () >>= fun () -> lwt_emit Termination_request + Lwt_io.flush_all () >>= fun () -> Events.(emit termination_request ()) in loop () >>= fun () -> return_unit @@ -378,7 +322,7 @@ let main ?socket_dir () = | None -> Lwt.return (Lwt_io.stdin, Lwt_io.stdout) ) >>= fun (in_channel, out_channel) -> - lwt_emit Initialized + Events.(emit initialized ()) >>= fun () -> Lwt.catch (fun () -> @@ -387,7 +331,7 @@ let main ?socket_dir () = (fun e -> Lwt.return (error_exn e)) >>= function | Ok () -> - lwt_emit Terminated >>= fun () -> return_unit + Events.(emit terminated ()) >>= fun () -> return_unit | Error _ as errs -> External_validation.send out_channel diff --git a/src/lib_base/block_locator.ml b/src/lib_base/block_locator.ml index 19bc70ed9edb179ceb3c075f759b2ceb779ba16a..cb09046a4602e89b94b349773cbbdb3a13eda397 100644 --- a/src/lib_base/block_locator.ml +++ b/src/lib_base/block_locator.ml @@ -70,14 +70,14 @@ let encoding = (req "current_head" (dynamic_size Block_header.encoding)) (req "history" (Variable.list Block_hash.encoding)) -let bounded_encoding ?max_header_size ?max_length () = +let bounded_encoding ~max_header_size ~max_length () = let open Data_encoding in obj2 (req "current_head" (dynamic_size - (Block_header.bounded_encoding ?max_size:max_header_size ()))) - (req "history" (Variable.list ?max_length Block_hash.encoding)) + (Block_header.bounded_encoding ~max_size:max_header_size ()))) + (req "history" (Variable.list ~max_length Block_hash.encoding)) type seed = {sender_id : P2p_peer.Id.t; receiver_id : P2p_peer.Id.t} diff --git a/src/lib_base/block_locator.mli b/src/lib_base/block_locator.mli index bb6be81b3612c36dcdb1a54c3fb77fa9ac0b1040..19cfbf406f34be3432bf72ea742f61f1a3414487 100644 --- a/src/lib_base/block_locator.mli +++ b/src/lib_base/block_locator.mli @@ -57,7 +57,7 @@ val pp_short : Format.formatter -> t -> unit val encoding : t Data_encoding.t val bounded_encoding : - ?max_header_size:int -> ?max_length:int -> unit -> t Data_encoding.t + max_header_size:int -> max_length:int -> unit -> t Data_encoding.t (** Argument to the seed used to randomize the locator. *) type seed = {sender_id : P2p_peer.Id.t; receiver_id : P2p_peer.Id.t} diff --git a/src/lib_base/operation.ml b/src/lib_base/operation.ml index 80ac3b04718250d3ff041ad373b9e21010328711..9833114fc53cf73f68546fd9a01a2d3bce604ce2 100644 --- a/src/lib_base/operation.ml +++ b/src/lib_base/operation.ml @@ -40,7 +40,7 @@ include Compare.Make (struct let compare o1 o2 = let ( >> ) x y = if x = 0 then y () else x in - Block_hash.compare o1.shell.branch o1.shell.branch + Block_hash.compare o1.shell.branch o2.shell.branch >> fun () -> Bytes.compare o1.proto o2.proto end) diff --git a/src/lib_base/p2p_point.ml b/src/lib_base/p2p_point.ml index e4ae04175a4b97b24eb3a7101eaead9fb7be1156..a96ce63602be5bc5b3febdf97fff5938091555e5 100644 --- a/src/lib_base/p2p_point.ml +++ b/src/lib_base/p2p_point.ml @@ -124,7 +124,12 @@ module Id = struct let encoding = let open Data_encoding in - def "p2p_point.id" ~description:"Identifier for a peer point" + check_size + ( 4 (* Uint30 that gives the size of the encoded string *) + + (8 (*number of IPv6 chunks *) * (*size of IPv6 chunks*) 4) + + (*IPv6 chunk separators*) 7 + (*optional enclosing bracket*) 2 + + (*port separator*) 1 + (*size of port number*) 5 ) + @@ def "p2p_point.id" ~description:"Identifier for a peer point" @@ conv to_string of_string_exn string let rpc_arg = diff --git a/src/lib_client_base/client_keys.ml b/src/lib_client_base/client_keys.ml index 4baa21380b10f148c532770e9a72574ec96d3df0..98a54d9f3d479402608e9d786dbcf7b4810ca2d9 100644 --- a/src/lib_client_base/client_keys.ml +++ b/src/lib_client_base/client_keys.ml @@ -190,11 +190,11 @@ type sapling_key = { (* zip32 derivation path *) path : int32 list; (* index of the next address to generate *) - address_index : Sapling.Core.Client.Viewing_key.index; + address_index : Tezos_sapling.Core.Client.Viewing_key.index; } module Sapling_key = Client_aliases.Alias (struct - module S = Sapling.Core.Client + module S = Tezos_sapling.Core.Client let name = "sapling_key" diff --git a/src/lib_client_base/client_keys.mli b/src/lib_client_base/client_keys.mli index bb899bf597f43efd550d828fe5dd1950e2756d84..eef64bf6056d4303a833efc7a8d7499a4f3cee39 100644 --- a/src/lib_client_base/client_keys.mli +++ b/src/lib_client_base/client_keys.mli @@ -66,7 +66,7 @@ type sapling_key = { (* zip32 derivation path *) path : int32 list; (* index of the last issued address *) - address_index : Sapling.Core.Client.Viewing_key.index; + address_index : Tezos_sapling.Core.Client.Viewing_key.index; } module Sapling_key : Client_aliases.Alias with type t = sapling_key diff --git a/src/lib_client_base/dune b/src/lib_client_base/dune index 088fb551892caf8739f3c159d80a20cb80bc9d5f..8ef10b301ff0454f08c0b33c544e41745ad3f0a4 100644 --- a/src/lib_client_base/dune +++ b/src/lib_client_base/dune @@ -3,7 +3,7 @@ (public_name tezos-client-base) (libraries tezos-base tezos-shell-services - sapling + tezos-sapling tezos-rpc) (modules (:standard bip39_english)) (library_flags (:standard -linkall)) diff --git a/src/lib_client_base/tezos-client-base.opam b/src/lib_client_base/tezos-client-base.opam index e3670434f10e0412d18cc1e69c5a2f0e2e09de1e..156a293babed8e396fb603e2b8849b18cc9327ed 100644 --- a/src/lib_client_base/tezos-client-base.opam +++ b/src/lib_client_base/tezos-client-base.opam @@ -14,9 +14,9 @@ depends: [ "tezos-storage" "tezos-rpc-http" "cmdliner" - "sapling" + "tezos-sapling" "alcotest" { with-test } - "sapling" + "tezos-sapling" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/lib_crypto/p256.ml b/src/lib_crypto/p256.ml index fd24f5834b6febcc4a9d628f2ef21db935690074..f897f1692c9255b52298919873f5910f7857fe04 100644 --- a/src/lib_crypto/p256.ml +++ b/src/lib_crypto/p256.ml @@ -44,16 +44,16 @@ end let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz3" 36 -open Hacl.P256 +open Uecc module Public_key = struct - type t = Hacl.public key + type t = public key let name = "P256.Public_key" let title = "A P256 public key" - let to_bytes = to_bytes + let to_bytes = to_bytes ~compress:true let to_string s = Bytes.to_string (to_bytes s) @@ -61,7 +61,7 @@ module Public_key = struct let of_string_opt s = of_bytes_opt (Bytes.of_string s) - let size _ = pk_size + let size _ = compressed_size type Base58.data += Data of t @@ -129,7 +129,7 @@ module Public_key = struct end module Secret_key = struct - type t = Hacl.secret key + type t = secret key let name = "P256.Secret_key" @@ -137,11 +137,11 @@ module Secret_key = struct let size = sk_size - let to_bytes = to_bytes + let to_bytes = to_bytes ~compress:true let to_string s = Bytes.to_string (to_bytes s) - let of_bytes_opt = sk_of_bytes + let of_bytes_opt buf = Option.map fst (sk_of_bytes buf) let of_string_opt s = of_bytes_opt (Bytes.of_string s) @@ -218,7 +218,7 @@ let name = "P256" let title = "A P256 signature" -let size = size +let size = pk_size let to_bytes s = Bytes.copy s @@ -284,42 +284,41 @@ end) let pp ppf t = Format.fprintf ppf "%s" (to_b58check t) -let zero = Bytes.make size '\000' +let zero = of_bytes_exn (Bytes.make size '\000') let sign ?watermark sk msg = let msg = Blake2B.to_bytes @@ Blake2B.hash_bytes @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg] in - sign ~sk ~msg + match sign sk msg with + | None -> + (* Will never happen in practice. This can only happen in case + of RNG error. *) + invalid_arg "P256.sign: internal error" + | Some signature -> + signature let check ?watermark pk signature msg = let msg = Blake2B.to_bytes @@ Blake2B.hash_bytes @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg] in - verify ~pk ~msg ~signature - -let generate_key ?seed () = - match seed with + verify pk ~msg ~signature + +let generate_key ?(seed = Hacl.Rand.gen 32) () = + let seedlen = Bytes.length seed in + if seedlen < 32 then + invalid_arg + (Printf.sprintf + "P256.generate_key: seed must be at least 32 bytes long (was %d)" + seedlen) ; + match sk_of_bytes seed with | None -> - let (pk, sk) = keypair () in - (Public_key.hash pk, pk, sk) - | Some seed -> ( - let seedlen = Bytes.length seed in - if seedlen < Secret_key.size then - invalid_arg - (Printf.sprintf - "P256.generate_key: seed must be at least %d bytes long (got %d)" - Secret_key.size - seedlen) - else - match sk_of_bytes (Bytes.sub seed 0 Secret_key.size) with - | None -> - invalid_arg "P256.generate_key: invalid seed" - | Some sk -> - let pk = neuterize sk in - (Public_key.hash pk, pk, sk) ) + invalid_arg "P256.generate_key: invalid seed (very rare!)" + | Some (sk, pk) -> + let pkh = Public_key.hash pk in + (pkh, pk, sk) let deterministic_nonce sk msg = let key = Secret_key.to_bytes sk in diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index 54f0323c6e6e5aa7bee20324398cbb33d7a5a996..66333bbedce727e7899e420f421c90e7833f4565 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -49,6 +49,9 @@ let check_name_exn : string -> (string -> char -> exn) -> unit = name ; () +(* Levels are declared from the lowest to the highest so that + polymorphic comparison can be used to check whether a message + should be printed. *) type level = Lwt_log_core.level = | Debug | Info @@ -57,6 +60,10 @@ type level = Lwt_log_core.level = | Error | Fatal +let should_log ~level ~sink_level = + (* Same criteria as [Lwt_log_core.log] *) + level >= sink_level + module Level = struct type t = level @@ -79,7 +86,7 @@ module Level = struct end module Section : sig - type t = private string list + type t val empty : t @@ -93,9 +100,9 @@ module Section : sig val to_string_list : t -> string list end = struct - type t = string list + type t = {path : string list; lwt_log_section : Lwt_log_core.section} - let empty = [] + let empty = {path = []; lwt_log_section = Lwt_log_core.Section.make ""} let make sl = List.iter @@ -107,18 +114,21 @@ end = struct name char)) sl ; - sl + { + path = sl; + lwt_log_section = Lwt_log_core.Section.make (String.concat "." sl); + } let make_sanitized sl = List.map (String.map (fun c -> if valid_char c then c else '_')) sl |> make - let to_lwt_log s = Lwt_log_core.Section.make (String.concat "." s) + let to_string_list s = s.path - let to_string_list t = t + let to_lwt_log s = s.lwt_log_section let encoding = let open Data_encoding in - list string + conv (fun {path; _} -> path) (fun l -> make l) (list string) end let registered_sections = ref TzString.Set.empty @@ -1189,23 +1199,33 @@ module Legacy_logging = struct module Event = Make (Definition) let emit_async level fmt ?tags = - Format.kasprintf - (fun message -> - Lwt.ignore_result - (Event.emit ~section (fun () -> - Definition.make ?tags level message))) - fmt + (* Prevent massive calls to kasprintf *) + let log_section = Section.to_lwt_log section in + if should_log ~level ~sink_level:(Lwt_log_core.Section.level log_section) + then + Format.kasprintf + (fun message -> + Lwt.ignore_result + (Event.emit ~section (fun () -> + Definition.make ?tags level message))) + fmt + else Format.ifprintf Format.std_formatter fmt let emit_lwt level fmt ?tags = - Format.kasprintf - (fun message -> - Event.emit ~section (fun () -> Definition.make ?tags level message) - >>= function - | Ok () -> - Lwt.return_unit - | Error el -> - Format.kasprintf Lwt.fail_with "%a" pp_print_error el) - fmt + (* Prevent massive calls to kasprintf *) + let log_section = Section.to_lwt_log section in + if should_log ~level ~sink_level:(Lwt_log_core.Section.level log_section) + then + Format.kasprintf + (fun message -> + Event.emit ~section (fun () -> Definition.make ?tags level message) + >>= function + | Ok () -> + Lwt.return_unit + | Error el -> + Format.kasprintf Lwt.fail_with "%a" pp_print_error el) + fmt + else Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter fmt end module Make (P : sig @@ -1475,16 +1495,20 @@ module Lwt_log_sink = struct let module M = (val m : EVENT_DEFINITION with type t = a) in protect (fun () -> let ev = v () in + let level = M.level ev in let section = Option.fold ~some:Section.to_lwt_log section ~none:default_section in - let level = M.level ev in - Format.kasprintf - (Lwt_log_core.log ~section ~level) - "%a" - (M.pp ~short:false) - ev - >>= fun () -> return_unit) + (* Only call printf if the event is to be printed. *) + if should_log ~level ~sink_level:(Lwt_log_core.Section.level section) + then + Format.kasprintf + (Lwt_log_core.log ~section ~level) + "%a" + (M.pp ~short:false) + ev + >>= fun () -> return_unit + else return_unit) let close _ = Lwt_log_core.close !Lwt_log_core.default >>= fun () -> return_unit diff --git a/src/lib_event_logging/internal_event.mli b/src/lib_event_logging/internal_event.mli index 3738adffbe3249e8a02bd1cf838930e87711372a..1a38c0b50d58e62864412ce59575f52f8428172d 100644 --- a/src/lib_event_logging/internal_event.mli +++ b/src/lib_event_logging/internal_event.mli @@ -72,7 +72,7 @@ end (** Sections are a simple way of classifying events at the time of their emission. *) module Section : sig - type t = private string list + type t val empty : t diff --git a/src/lib_p2p/p2p_connect_handler.ml b/src/lib_p2p/p2p_connect_handler.ml index 40b7a5433eb36aa871744dc95fcce4204eb2dcda..dbf2925437bf904c2b4a1f628ad302689d1e8009 100644 --- a/src/lib_p2p/p2p_connect_handler.ml +++ b/src/lib_p2p/p2p_connect_handler.ml @@ -310,7 +310,8 @@ let raw_authenticate t ?point_info canceler fd point = t.log (Rejecting_request (point, info.id_point, info.peer_id)) ; Events.(emit authenticate_status ("nack", point, info.peer_id)) >>= fun () -> - P2p_pool.list_known_points ~ignore_private:true t.pool + P2p_pool.list_known_points ~ignore_private:true ~size:50 t.pool + (* Never send more than 100 points, you would be greylisted *) >>= fun point_list -> P2p_socket.nack auth_fd motive point_list >>= fun () -> diff --git a/src/lib_p2p/p2p_io_scheduler.ml b/src/lib_p2p/p2p_io_scheduler.ml index c6800c958683f99885da5cf5a6d185284a49a1c0..2028074de71df62d6aaf9b68edaae9aae4e99641 100644 --- a/src/lib_p2p/p2p_io_scheduler.ml +++ b/src/lib_p2p/p2p_io_scheduler.ml @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -23,8 +24,6 @@ (* *) (*****************************************************************************) -(* TODO decide whether we need to preallocate buffers or not. *) - module Events = P2p_events.P2p_io_scheduler let alpha = 0.2 @@ -34,11 +33,15 @@ module type IO = sig type in_param - val pop : in_param -> Bytes.t tzresult Lwt.t + type data + + val length : data -> int + + val pop : in_param -> data tzresult Lwt.t type out_param - val push : out_param -> Bytes.t -> unit tzresult Lwt.t + val push : out_param -> data -> unit tzresult Lwt.t val close : out_param -> error list -> unit Lwt.t end @@ -57,8 +60,8 @@ module Scheduler (IO : IO) = struct mutable quota : int; quota_updated : unit Lwt_condition.t; readys : unit Lwt_condition.t; - readys_high : (connection * Bytes.t tzresult) Queue.t; - readys_low : (connection * Bytes.t tzresult) Queue.t; + readys_high : (connection * IO.data tzresult) Queue.t; + readys_low : (connection * IO.data tzresult) Queue.t; } and connection = { @@ -67,7 +70,7 @@ module Scheduler (IO : IO) = struct canceler : Lwt_canceler.t; in_param : IO.in_param; out_param : IO.out_param; - mutable current_pop : Bytes.t tzresult Lwt.t; + mutable current_pop : IO.data tzresult Lwt.t; mutable current_push : unit tzresult Lwt.t; counter : Moving_average.t; mutable quota : int; @@ -93,6 +96,8 @@ module Scheduler (IO : IO) = struct (fun exc -> Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) (fun () -> + (* To ensure that there is no concurrent calls to IO.pop, we + wait for the promise to be fulfilled. *) conn.current_pop >>= fun res -> conn.current_push @@ -158,7 +163,7 @@ module Scheduler (IO : IO) = struct Events.(emit unexpected_error) ("push", conn.id, IO.name, err) >>= fun () -> cancel conn err >>= fun () -> Lwt.return_error err ) ; - let len = Bytes.length msg in + let len = IO.length msg in Events.(emit handle_connection) (len, conn.id, IO.name) >>= fun () -> Moving_average.add st.counter len ; @@ -230,26 +235,38 @@ module Scheduler (IO : IO) = struct >>= fun () -> st.worker >>= fun () -> Events.(emit shutdown) IO.name end -module ReadScheduler = Scheduler (struct +module ReadIO = struct let name = "io_scheduler(read)" - type in_param = P2p_fd.t * int + type in_param = { + fd : P2p_fd.t; + (* File descriptor from which data are read *) + maxlen : int; + (* Length of data we want to read from the file descriptor *) + read_buffer : Circular_buffer.t; (* Cache where data will be stored *) + } - let pop (fd, maxlen) = + type data = Circular_buffer.data + + let length = Circular_buffer.length + + (* Invariant: Given a connection, there is not concurrent call to + pop *) + let pop {fd; maxlen; read_buffer} = Lwt.catch (fun () -> - let buf = Bytes.create maxlen in - P2p_fd.read fd buf 0 maxlen - >>= fun len -> - if len = 0 then fail P2p_errors.Connection_closed - else return (Bytes.sub buf 0 len)) + Circular_buffer.write ~maxlen ~fill_using:(P2p_fd.read fd) read_buffer + >>= fun data -> + if Circular_buffer.length data = 0 then + fail P2p_errors.Connection_closed + else return data) (function | Unix.Unix_error (Unix.ECONNRESET, _, _) -> fail P2p_errors.Connection_closed | exn -> Lwt.return (error_exn exn)) - type out_param = Bytes.t tzresult Lwt_pipe.t + type out_param = Circular_buffer.data tzresult Lwt_pipe.t let push p msg = Lwt.catch @@ -260,13 +277,19 @@ module ReadScheduler = Scheduler (struct Lwt.catch (fun () -> Lwt_pipe.push p (Error err)) (fun _ -> Lwt.return_unit) -end) +end -module WriteScheduler = Scheduler (struct +module ReadScheduler = Scheduler (ReadIO) + +module WriteIO = struct let name = "io_scheduler(write)" type in_param = Bytes.t Lwt_pipe.t + type data = Bytes.t + + let length = Bytes.length + let pop p = Lwt.catch (fun () -> Lwt_pipe.pop p >>= return) @@ -288,16 +311,19 @@ module WriteScheduler = Scheduler (struct Lwt.return (error_exn exn)) let close _p _err = Lwt.return_unit -end) +end + +module WriteScheduler = Scheduler (WriteIO) type connection = { fd : P2p_fd.t; canceler : Lwt_canceler.t; read_conn : ReadScheduler.connection; - read_queue : Bytes.t tzresult Lwt_pipe.t; + read_buffer : Circular_buffer.t; + read_queue : Circular_buffer.data tzresult Lwt_pipe.t; write_conn : WriteScheduler.connection; write_queue : Bytes.t Lwt_pipe.t; - mutable partial_read : Bytes.t option; + mutable partial_read : Circular_buffer.data option; remove_from_connection_table : unit -> unit; } @@ -362,8 +388,10 @@ let ma_state {ma_state; _} = ma_state exception Closed let read_size = function - | Ok buf -> - (Sys.word_size / 8 * 8) + Bytes.length buf + Lwt_pipe.push_overhead + | Ok data -> + (Sys.word_size / 8 * 8) + + Circular_buffer.length data + + Lwt_pipe.push_overhead | Error _ -> 0 @@ -391,10 +419,15 @@ let register st fd = in let read_queue = Lwt_pipe.create ?size:read_size () in let write_queue = Lwt_pipe.create ?size:write_size () in + (* This buffer is allocated once and is reused everytime we read a + message from the corresponding file descriptor. *) + let read_buffer = + Circular_buffer.create ~maxlength:(st.read_buffer_size * 2) () + in let read_conn = ReadScheduler.create_connection st.read_scheduler - (fd, st.read_buffer_size) + {fd; maxlen = st.read_buffer_size; read_buffer} read_queue canceler id @@ -424,6 +457,7 @@ let register st fd = fd; canceler; read_queue; + read_buffer; read_conn; write_queue; write_conn; @@ -443,19 +477,23 @@ let write ?canceler {write_queue; _} msg = let write_now {write_queue; _} msg = Lwt_pipe.push_now write_queue msg -let read_from conn ?pos ?len buf msg = +let read_from conn ?pos ?len buf data = let maxlen = Bytes.length buf in let pos = Option.value ~default:0 pos in assert (0 <= pos && pos < maxlen) ; let len = Option.value ~default:(maxlen - pos) len in assert (len <= maxlen - pos) ; - match msg with - | Ok msg -> - let msg_len = Bytes.length msg in - let read_len = min len msg_len in - Bytes.blit msg 0 buf pos read_len ; - if read_len < msg_len then - conn.partial_read <- Some (Bytes.sub msg read_len (msg_len - read_len)) ; + match data with + | Ok data -> + let read_len = min len (Circular_buffer.length data) in + Option.iter + (fun data -> conn.partial_read <- Some data) + (Circular_buffer.read + data + conn.read_buffer + ~len:read_len + ~into:buf + ~offset:pos) ; Ok read_len | Error _ -> error P2p_errors.Connection_closed diff --git a/src/lib_p2p/p2p_message.ml b/src/lib_p2p/p2p_message.ml index 26074858eddf123aaea6d97575fe4a1fc57e4203..dff439eebbdb67f0ac1e3ba854d586cc1249def4 100644 --- a/src/lib_p2p/p2p_message.ml +++ b/src/lib_p2p/p2p_message.ml @@ -34,7 +34,9 @@ type 'msg t = let encoding msg_encoding = let open Data_encoding in - dynamic_size + check_size (100 * 1024 * 1024) + (*Very high, arbitrary upper bound for message encodings *) + @@ dynamic_size (* MAX SIZE: 4(size of size info) + MAX SIZE of encoding *) @@ -65,7 +67,7 @@ let encoding msg_encoding = + 7(IPv6 chunk separators) + 1(port separator) + 5(size of port number)) - = 2102 + = 4502 *) case (Tag 0x03) diff --git a/src/lib_p2p/p2p_socket.ml b/src/lib_p2p/p2p_socket.ml index 27cdc45719e634eea4c1507fc43262ef4b498852..80935948d06e7080300e0d35b08d8053d346d1c9 100644 --- a/src/lib_p2p/p2p_socket.ml +++ b/src/lib_p2p/p2p_socket.ml @@ -247,7 +247,9 @@ module Ack = struct let nack_encoding = obj2 (req "nack_motive" P2p_rejection.encoding) - (req "nack_list" (Data_encoding.list P2p_point.Id.encoding)) + (req + "nack_list" + (Data_encoding.list ~max_length:100 P2p_point.Id.encoding)) in let ack_case tag = case diff --git a/src/lib_p2p/p2p_socket.mli b/src/lib_p2p/p2p_socket.mli index 6f04f8bd45189dd8fd9873bd8f22b7ba1718967e..121873021b32b593b65c59a40bea2b1747c0296b 100644 --- a/src/lib_p2p/p2p_socket.mli +++ b/src/lib_p2p/p2p_socket.mli @@ -120,7 +120,9 @@ val authenticate : (** [nack ac motive alts] sends a [Nack] message with the rejection [motive] and a list of proposed alternative points to the remote peer, notifying it - that its connection is rejected. It then closes the connection. *) + that its connection is rejected. It then closes the connection. + + [alts] must contain less than 100 points or you will be greylisted *) val nack : 'meta authenticated_connection -> P2p_rejection.t -> diff --git a/src/lib_protocol_compiler/compiler.ml b/src/lib_protocol_compiler/compiler.ml index 58815b0b66ab5d20537f3346bd65e5548fb79ef2..91bc83a9c10f85a7e856b42881ce11a91b17e7aa 100644 --- a/src/lib_protocol_compiler/compiler.ml +++ b/src/lib_protocol_compiler/compiler.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -let warnings = "+a-4-6-7-9-29-40..42-44-45-48" +let warnings = "+a-4-6-7-9-29-40..42-44-45-48-60-67" let warn_error = "-a+8" diff --git a/src/lib_protocol_compiler/dune_protocol.template b/src/lib_protocol_compiler/dune_protocol.template index 0098ad5880198b5e18b3e75937dcea1a9e5329cf..ee8c5a26ba26225f1b73734c913cfa521c3907cb 100644 --- a/src/lib_protocol_compiler/dune_protocol.template +++ b/src/lib_protocol_compiler/dune_protocol.template @@ -52,7 +52,7 @@ include Tezos_raw_protocol_%%LIB_VERSION%%.Main (libraries tezos_protocol_environment_%%LIB_VERSION%%) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_%%LIB_VERSION%%__Environment -open Pervasives @@ -72,19 +72,19 @@ include Tezos_raw_protocol_%%LIB_VERSION%%.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_%%LIB_VERSION%%) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_%%LIB_VERSION%%_functor) - (public_name tezos-protocol-%%VERSION%%.functor) + (public_name tezos-protocol-functor-%%VERSION%%) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_%%LIB_VERSION%%) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-%%VERSION%%.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -96,7 +96,7 @@ include Tezos_raw_protocol_%%LIB_VERSION%%.Main (libraries tezos-protocol-%%VERSION%% tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/lib_protocol_compiler/final_protocol_versions b/src/lib_protocol_compiler/final_protocol_versions index ac0ef43e0804da83b2a017c25e30fd24d9b09ada..b7c5b6b9157cd13d8187e74d8514e16cc9f084a3 100644 --- a/src/lib_protocol_compiler/final_protocol_versions +++ b/src/lib_protocol_compiler/final_protocol_versions @@ -6,4 +6,6 @@ Pt24m4xiPbLDhVgVfABUjirbmda3yohdN82Sp9FeuAXJ4eV9otd PsBABY5HQTSkA4297zNHfsZNKtxULfL18y95qb3m53QJiXGmrbU PsBabyM1eUXZseaJdmXFApDSBqj8YBfwELoxZHHW77EMcAbbwAS PsCARTHAGazKbHtnKfLzQg3kms52kSRpgnDY982a9oYsSXRLQEb -PsDELPH1Kxsxt8f9eWbxQeRxkjfbxoqM52jvs5Y5fBxWWh4ifpo \ No newline at end of file +PsDELPH1Kxsxt8f9eWbxQeRxkjfbxoqM52jvs5Y5fBxWWh4ifpo +PtEdoTezd3RHSC31mpxxo1npxFjoWWcFgQtxapi51Z8TLu6v6Uq +PtEdo2ZkT9oKpimTah6x2embF25oss54njMuPzkJTEi5RqfdZFA \ No newline at end of file diff --git a/src/lib_protocol_compiler/tezos-protocol-compiler.opam b/src/lib_protocol_compiler/tezos-protocol-compiler.opam index 8813ebea1249feca318f1b1f87633571cd01ddda..94457d0530f77c64da3ca8145d6ec28ef2b2a2c5 100644 --- a/src/lib_protocol_compiler/tezos-protocol-compiler.opam +++ b/src/lib_protocol_compiler/tezos-protocol-compiler.opam @@ -8,7 +8,7 @@ license: "MIT" depends: [ "tezos-tooling" { with-test } ## ocaml should be in sync with `script/version.sh` - "ocaml" { = "4.09.1" } + "ocaml" { >= "4.09.1" & < "4.11" } "dune" { >= "2.0" } "base-unix" "tezos-base" diff --git a/src/lib_protocol_environment/dune b/src/lib_protocol_environment/dune index e9a4c9aaa42833cccb25031c29a79a1be9ad1a61..d4a40903dd57ae08a3d644b331935e226488fbc5 100644 --- a/src/lib_protocol_environment/dune +++ b/src/lib_protocol_environment/dune @@ -2,7 +2,7 @@ (name tezos_protocol_environment) (public_name tezos-protocol-environment) (libraries tezos-base - sapling + tezos-sapling tezos-protocol-environment-sigs tezos-protocol-environment-structs tezos-micheline) diff --git a/src/lib_protocol_environment/environment_V1.ml b/src/lib_protocol_environment/environment_V1.ml index 0b1c62d296b42bf885e50459bf401e73ee96d98c..25b849985c8748e00a9618f65ebf7b8fc49b9942 100644 --- a/src/lib_protocol_environment/environment_V1.ml +++ b/src/lib_protocol_environment/environment_V1.ml @@ -78,7 +78,7 @@ module type V1 = sig and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_error = Error_monad.error - and module Sapling = Sapling.Core.Validator + and module Sapling = Tezos_sapling.Core.Validator type error += Ecoproto_error of Error_monad.error @@ -991,7 +991,7 @@ struct Lwt.return_ok (Some v) end - module Sapling = Sapling.Core.Validator + module Sapling = Tezos_sapling.Core.Validator module Micheline = struct include Micheline diff --git a/src/lib_protocol_environment/environment_V1.mli b/src/lib_protocol_environment/environment_V1.mli index 38688c19af10755ac7e57bdec0cdfceaa79854c1..a91c3412988977fc0ee165a584cfef8e22add921 100644 --- a/src/lib_protocol_environment/environment_V1.mli +++ b/src/lib_protocol_environment/environment_V1.mli @@ -77,7 +77,7 @@ module type V1 = sig and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_error = Error_monad.error - and module Sapling = Sapling.Core.Validator + and module Sapling = Tezos_sapling.Core.Validator type error += Ecoproto_error of Error_monad.error diff --git a/src/lib_protocol_environment/tezos-protocol-environment.opam b/src/lib_protocol_environment/tezos-protocol-environment.opam index ae3fc5b699b8222182afcc2b498dbfa28a1b72f2..521cb8f8cb7540a4fb24530a60027be3d357beab 100644 --- a/src/lib_protocol_environment/tezos-protocol-environment.opam +++ b/src/lib_protocol_environment/tezos-protocol-environment.opam @@ -8,12 +8,12 @@ license: "MIT" depends: [ "tezos-tooling" { with-test } "dune" { >= "2.0" } - "sapling" + "tezos-sapling" "tezos-base" "tezos-protocol-environment-sigs" "tezos-protocol-environment-structs" "alcotest-lwt" { with-test & >= "1.1.0" } - "sapling" + "tezos-sapling" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/lib_sapling/core.ml b/src/lib_sapling/core.ml index 7f9218af6d3bfbd9cdfeda34bc609a9ae8bdb7bc..406fbc096638d5c17d79fe26d3105810279fc25e 100644 --- a/src/lib_sapling/core.ml +++ b/src/lib_sapling/core.ml @@ -20,15 +20,6 @@ * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. *) -(* OCaml guarantees that this init is called once. The librustzcash assumes that - it is not called several times with different values. - Potential problems: - - some code linked with this library and running on JSOO, even if it doesn't - really use the library, would still crash with missing primitives or - wrong setup. - - multiple inits because of Dynlink *) -let () = Rustzcash.init_params () - (** This module implements all the core functionalities. It contains also the low level Rustzcash type equalities and should be used in its Raw form only for testing. @@ -36,6 +27,8 @@ let () = Rustzcash.init_params () module Raw = struct module R = Rustzcash + let init_params = R.init_params + module Spending_key = struct (** Authorisation spending key: secret key used to sign once randomized. *) type ask = R.ask diff --git a/src/lib_sapling/core_sig.ml b/src/lib_sapling/core_sig.ml index 2451c043411d01afc30c9525d7896e871e3bc8e7..734da48233234055ea4815e22515c51584955462 100644 --- a/src/lib_sapling/core_sig.ml +++ b/src/lib_sapling/core_sig.ml @@ -275,6 +275,22 @@ end (** Regroups what needs to be exposed to a Validator **) module type Validator = sig + (** Loads the ZCash parameters for Groth16, searching them in: + - [/usr/share/zcash-params] + - [${OPAM_SWITCH_PREFIX}/share/zcash-params] + - [${HOME}/.zcash-params] + Only Sapling's parameters are loaded, not Sprout's. + + This function must be called before any of the proving and verification + functions requiring a context. + Usually you should not need to call this function directly as it is done + by the fist call to `with_{proving,verification}_ctx`. + However you can call this function in order to: + - pay its cost upfront and have more predictable latency later + - make sure that the parameters are present in the system and avoid a + failure later. *) + val init_params : unit -> unit + module Ciphertext : sig include T_encoding diff --git a/src/lib_sapling/dune b/src/lib_sapling/dune index 771d610b8453c62f1f8affb0a27e19371db10def..b51f0f97d20e288a516cb69a9d0a45c028bddfaf 100644 --- a/src/lib_sapling/dune +++ b/src/lib_sapling/dune @@ -4,14 +4,14 @@ (copy_files bindings/{rustzcash_ctypes_c_stubs.c,rustzcash_ctypes_stubs.ml,rustzcash_ctypes_bindings.ml}) (library - (name sapling) - (public_name sapling) + (name tezos_sapling) + (public_name tezos-sapling) (libraries ctypes ctypes.foreign ctypes.stubs hex data-encoding tezos-crypto tezos-stdlib tezos-error-monad) (foreign_stubs (language c) - (flags (-I%{env:OPAM_SWITCH_PREFIX=}/include/librustzcash)) + (flags (-I%{env:OPAM_SWITCH_PREFIX=}/lib/tezos-rust-libs)) (names rustzcash_ctypes_c_stubs)) - (c_library_flags (-L%{env:OPAM_SWITCH_PREFIX=}/lib/librustzcash -lrustzcash -lpthread)) + (c_library_flags (-L%{env:OPAM_SWITCH_PREFIX=}/lib/tezos-rust-libs -lrustzcash -lpthread)) (flags (:standard -open Tezos_stdlib -open Tezos_crypto -open Tezos_error_monad))) diff --git a/src/lib_sapling/dune-project b/src/lib_sapling/dune-project index a297a9ae9ec959359e7af91db75e18c55a9b54f4..f34163f0eba0a4f4c2563fc17eb8c71da25d2a15 100644 --- a/src/lib_sapling/dune-project +++ b/src/lib_sapling/dune-project @@ -1,2 +1,2 @@ (lang dune 2.0) -(name sapling) +(name tezos-sapling) diff --git a/src/lib_sapling/rustzcash.ml b/src/lib_sapling/rustzcash.ml index b372c15609758c270c5962b9a88059a36fd1e678..6c75ea6c0fd5937b0fb72c171bed8973461f14ac 100644 --- a/src/lib_sapling/rustzcash.ml +++ b/src/lib_sapling/rustzcash.ml @@ -505,20 +505,12 @@ let proving_ctx_init () = RS.proving_ctx_init () let proving_ctx_free ctx = RS.proving_ctx_free ctx -let with_proving_ctx f = - let ctx = proving_ctx_init () in - Fun.protect ~finally:(fun () -> proving_ctx_free ctx) (fun () -> f ctx) - type verification_ctx = unit Ctypes_static.ptr let verification_ctx_init () = RS.verification_ctx_init () let verification_ctx_free ctx = RS.verification_ctx_free ctx -let with_verification_ctx f = - let ctx = verification_ctx_init () in - Fun.protect ~finally:(fun () -> verification_ctx_free ctx) (fun () -> f ctx) - let tree_uncommitted = to_hash (Hex.to_bytes @@ -679,6 +671,22 @@ let zip32_xfvk_derive parent index = in if res then Some (to_zip32_full_viewing_key derived) else None +exception Params_not_found of string list + +let () = + Printexc.register_printer + @@ function + | Params_not_found locations -> + Some + (Format.asprintf + "@[cannot find Zcash params in any of:@,\ + %a@ You may download them using \ + https://raw.githubusercontent.com/zcash/zcash/master/zcutil/fetch-params.sh@]@." + (Format.pp_print_list (fun fmt -> Format.fprintf fmt "- %s")) + locations) + | _ -> + None + let init_params () = let home = Option.value (Sys.getenv_opt "HOME") ~default:"/" in let opam_switch = @@ -737,15 +745,7 @@ let init_params () = | Some p -> p | None -> - Format.eprintf - "@[Cannot find zcash params in any of @[%a@].@ You may download \ - them using \ - https://raw.githubusercontent.com/zcash/zcash/master/zcutil/fetch-params.sh@]@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - Format.pp_print_string) - candidates ; - raise Not_found + raise (Params_not_found candidates) in let spend_path = prefix ^ "/sapling-spend.params" in let spend_hash = @@ -756,3 +756,15 @@ let init_params () = "657e3d38dbb5cb5e7dd2970e8b03d69b4787dd907285b5a7f0790dcc8072f60bf593b32cc2d1c030e00ff5ae64bf84c5c3beb84ddc841d48264b4a171744d028\000" in init_zksnark_params ~spend_path ~spend_hash ~output_path ~output_hash + +let init_params_lazy = Lazy.from_fun init_params + +let with_proving_ctx f = + let () = Lazy.force init_params_lazy in + let ctx = proving_ctx_init () in + Fun.protect ~finally:(fun () -> proving_ctx_free ctx) (fun () -> f ctx) + +let with_verification_ctx f = + let () = Lazy.force init_params_lazy in + let ctx = verification_ctx_init () in + Fun.protect ~finally:(fun () -> verification_ctx_free ctx) (fun () -> f ctx) diff --git a/src/lib_sapling/rustzcash.mli b/src/lib_sapling/rustzcash.mli index 8bceca3e7374884803d71966cddd4bd526268cbc..c998674088bccd07750e6e5f0822af2f3a732587 100644 --- a/src/lib_sapling/rustzcash.mli +++ b/src/lib_sapling/rustzcash.mli @@ -34,12 +34,21 @@ val valid_amount : int64 -> bool val valid_balance : int64 -> bool +(** Raised by {!init_params} if it failed to find parameters. + + The string list is the list of locations where they were looked up. *) +exception Params_not_found of string list + (** Loads the parameters for our instance of Groth16. - The parameters are search in: + + The parameters are searched in: - [/usr/share/zcash-params] - [${OPAM_SWITCH_PREFIX}/share/zcash-params] - [${HOME}/.zcash-params] - Only sapling parameters are loaded. *) + + @raise Params_not_found if parameters could not be found at any of those locations. + + Only sapling parameters are loaded. *) val init_params : unit -> unit (** Derives the nullifier pk corresponding to a nullifier sk *) diff --git a/src/lib_sapling/test/dune b/src/lib_sapling/test/dune index 60beb491ec48094f785870f57331aeb4650abca9..e697f9085a74070f84807d060e7d6f85ca296b3f 100644 --- a/src/lib_sapling/test/dune +++ b/src/lib_sapling/test/dune @@ -1,14 +1,15 @@ (tests + (package tezos-sapling) (names test_rustzcash test_keys test_merkle test_sapling) (deps vectors.csv vectors-zip32.csv) - (libraries sapling + (libraries tezos-sapling str tezos-stdlib-unix alcotest-lwt) - (flags (:standard -open Sapling + (flags (:standard -open Tezos_sapling -open Tezos_crypto -open Tezos_stdlib -open Data_encoding))) diff --git a/src/lib_sapling/test/test_sapling.ml b/src/lib_sapling/test/test_sapling.ml index 978830e9613cd218da93a47e9ab6f1792021bcbe..2600b6fb2c2a834e63df84ab384da921992e2589 100644 --- a/src/lib_sapling/test/test_sapling.ml +++ b/src/lib_sapling/test/test_sapling.ml @@ -51,6 +51,7 @@ let test_proof_raw () = let signature = TzOption.unopt_assert ~loc:__POS__ (R.spend_sig xsk.expsk.ask ar sighash) in + R.init_params () ; let ctx_prove = R.proving_ctx_init () in let ctx_verif = R.verification_ctx_init () in let (cv_spend, rk, zkproof_spend) = @@ -148,6 +149,7 @@ let test_full_transaction () = Nullifier.compute addr1 xfvk1 ~amount:10L rcm_1 ~position:0L |> TzOption.unopt_assert ~loc:__POS__ in + R.init_params () ; (* Creation of a context to kep track of some info *) let ctx_prove_1 = R.proving_ctx_init () in (* Commitment value, randomised signature key, ZK proof that cm_1 is in the diff --git a/src/lib_sapling/sapling.opam b/src/lib_sapling/tezos-sapling.opam similarity index 97% rename from src/lib_sapling/sapling.opam rename to src/lib_sapling/tezos-sapling.opam index 36e4f9a224a5cb3363172b057a02ee552d988dfd..949a540fd25d16280417ac21aa99561be5a00bbe 100644 --- a/src/lib_sapling/sapling.opam +++ b/src/lib_sapling/tezos-sapling.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -name: "ocaml-sapling" +name: "tezos-sapling" authors: [ "Nomadic Labs " ] maintainer: "Nomadic Labs " synopsis: "OCaml library for the Sapling protocol, using librustzcash" diff --git a/src/lib_shell/block_directory.ml b/src/lib_shell/block_directory.ml index 0a877e536f8d4c0fc102d418b53a2ff7598ac091..c755760f80e955e2fc6950b691f9d82240bbe6f8 100644 --- a/src/lib_shell/block_directory.ml +++ b/src/lib_shell/block_directory.ml @@ -397,6 +397,13 @@ let build_raw_rpc_directory ~user_activated_upgrades let header = State.Block.header block in Lwt.return (chain_state, hash, header)) (build_raw_header_rpc_directory (module Proto))) ; + let proto_services = + match Prevalidator_filters.find Next_proto.hash with + | Some (module Filters) -> + Filters.RPC.rpc_services + | None -> + Next_proto.rpc_services + in merge (RPC_directory.map (fun block -> @@ -408,7 +415,7 @@ let build_raw_rpc_directory ~user_activated_upgrades block_header = State.Block.shell_header block; context; }) - Next_proto.rpc_services) ; + proto_services) ; !dir let get_protocol hash = @@ -474,7 +481,6 @@ let get_block chain_state = function State.Block.read_predecessor chain_state ~pred:n - ~below_save_point:true (State.Block.hash head) | (`Alias (_, n) | `Hash (_, n)) as b -> ( match b with @@ -508,25 +514,14 @@ let get_block chain_state = function State.Block.read_predecessor chain_state ~pred:target - ~below_save_point:true (State.Block.hash head) else if n = 0 then Chain.genesis chain_state >>= fun genesis -> let genesis_hash = State.Block.hash genesis in if Block_hash.equal hash genesis_hash then Lwt.return_some genesis - else - State.Block.read_predecessor - chain_state - ~pred:0 - ~below_save_point:true - hash - else - State.Block.read_predecessor - chain_state - ~pred:n - ~below_save_point:true - hash + else State.Block.read_predecessor chain_state ~pred:0 hash + else State.Block.read_predecessor chain_state ~pred:n hash | `Level i -> Chain.head chain_state >>= fun head -> @@ -536,7 +531,6 @@ let get_block chain_state = function State.Block.read_predecessor chain_state ~pred:target - ~below_save_point:true (State.Block.hash head) let build_rpc_directory ~user_activated_upgrades diff --git a/src/lib_shell/block_validator.ml b/src/lib_shell/block_validator.ml index 46a4fb905c33e1dcdfd921b730855e3ca347d8b2..a848d6b52ef526e07159fe3f4bd49984de897ac0 100644 --- a/src/lib_shell/block_validator.ml +++ b/src/lib_shell/block_validator.ml @@ -33,6 +33,12 @@ type limits = { worker_limits : Worker_types.limits; } +type result = + | Already_commited + | Outdated_block + | Validated + | Validation_error of error trace + module Name = struct type t = unit @@ -74,7 +80,7 @@ module Request = struct header : Block_header.t; operations : Operation.t list list; } - -> State.Block.t option tzresult t + -> result t let view : type a. a t -> view = fun (Request_validation {chain_db; peer; hash; _}) -> @@ -92,8 +98,6 @@ module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger) type t = Worker.infinite Worker.queue Worker.t -let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg)) - let check_chain_liveness chain_db hash (header : Block_header.t) = let chain_state = Distributed_db.chain_state chain_db in match State.Chain.expiration chain_state with @@ -108,18 +112,7 @@ let check_chain_liveness chain_db hash (header : Block_header.t) = | None | Some _ -> return_unit -let should_validate_block w chain_state hash = - State.Block.read_opt chain_state hash - >>= function - | None -> - Lwt.return_none - | Some block -> - State.Block.context_exists block - >>= fun context_exists -> - if not context_exists then - debug w "could not find context for block %a" Block_hash.pp_short hash ; - let should_validate = not context_exists in - Lwt.return_some (block, should_validate) +let is_already_validated chain_state hash = State.Block.known chain_state hash let on_request : type r. t -> r Request.t -> r tzresult Lwt.t = fun w @@ -127,59 +120,53 @@ let on_request : type r. t -> r Request.t -> r tzresult Lwt.t = {chain_db; notify_new_block; canceler; peer; hash; header; operations}) -> let bv = Worker.state w in let chain_state = Distributed_db.chain_state chain_db in - should_validate_block w chain_state hash - >>= function - | Some (block, false) -> - debug - w - "previously validated block %a (after pipe)" - Block_hash.pp_short - hash ; - Protocol_validator.prefetch_and_compile_protocols - bv.protocol_validator - ?peer - ~timeout:bv.limits.protocol_timeout - block ; - return (Ok None) - | Some (_, true) | None -> ( - State.Block.read_invalid chain_state hash - >>= function - | Some {errors; _} -> - return (Error errors) - | None -> ( - State.Chain.save_point chain_state - >>= fun (save_point_lvl, _) -> - (* Safety and late workers in partial mode. *) - if Compare.Int32.(header.shell.level < save_point_lvl) then - return (Ok None) - else - ( debug w "validating block %a" Block_hash.pp_short hash ; - State.Block.read chain_state header.shell.predecessor - >>=? fun pred -> - Worker.protect w (fun () -> - protect ?canceler (fun () -> - Block_validator_process.apply_block - bv.validation_process - ~predecessor:pred - header - operations - >>= function - | Ok x -> - return x - | Error (Missing_test_protocol protocol :: _) -> - Protocol_validator.fetch_and_compile_protocol - bv.protocol_validator - ?peer - ~timeout:bv.limits.protocol_timeout - protocol - >>=? fun _ -> + is_already_validated chain_state hash + >>= (function + | true -> + return Already_commited + | false -> ( + State.Block.read_invalid chain_state hash + >>= function + | Some {errors; _} -> + return (Validation_error errors) + | None -> ( + State.Chain.checkpoint chain_state + >>= fun checkpoint -> + (* Safety and late workers in partial mode. *) + if Compare.Int32.(header.shell.level < checkpoint.shell.level) + then return Outdated_block + else + Worker.log_event w (Validating_block hash) + >>= fun () -> + State.Block.read chain_state header.shell.predecessor + >>=? fun pred -> + Worker.protect w (fun () -> + protect ?canceler (fun () -> Block_validator_process.apply_block bv.validation_process ~predecessor:pred header operations - | Error _ as x -> - Lwt.return x) + >>= function + | Ok x -> + return x + (* [Unavailable_protocol] is expected to be the + first error in the trace *) + | Error (Unavailable_protocol {protocol; _} :: _) -> + Protocol_validator.fetch_and_compile_protocol + bv.protocol_validator + ?peer + ~timeout:bv.limits.protocol_timeout + protocol + >>=? fun _ -> + (* Retry validating after fetching the protocol *) + Block_validator_process.apply_block + bv.validation_process + ~predecessor:pred + header + operations + | Error _ as x -> + Lwt.return x)) >>=? fun { validation_store; block_metadata; ops_metadata; @@ -209,48 +196,21 @@ let on_request : type r. t -> r Request.t -> r tzresult Lwt.t = validation_store ~forking_testchain >>=? function - | None -> - (* This case can be reached if the block was - previously validated but its associated - context has not been written on disk and - therefore it means that it already exists in - the store. *) - State.Block.read chain_state hash | Some block -> - return block) ) - >>= function - | Ok block -> - Protocol_validator.prefetch_and_compile_protocols - bv.protocol_validator - ?peer - ~timeout:bv.limits.protocol_timeout - block ; - notify_new_block block ; - return (Ok (Some block)) - | Error err as error -> - if - List.exists - (function Invalid_block _ -> true | _ -> false) - err - then ( - Worker.protect w (fun () -> - Distributed_db.commit_invalid_block - chain_db - hash - header - err) - >>=? fun committed -> - assert committed ; - return error ) - else ( - debug - w - "Error during %a block validation: %a" - Block_hash.pp_short - hash - Error_monad.pp_print_error - err ; - return error ) ) ) + notify_new_block block ; return Validated + | None -> + return Already_commited ) )) + >>= function + | Ok r -> + return r + | Error err -> + if List.exists (function Invalid_block _ -> true | _ -> false) err then ( + Worker.protect w (fun () -> + Distributed_db.commit_invalid_block chain_db hash header err) + >>=? fun committed -> + assert committed ; + return (Validation_error err) ) + else return (Validation_error err) let on_launch _ _ (limits, start_testchain, db, validation_process) = let protocol_validator = Protocol_validator.create db in @@ -258,24 +218,23 @@ let on_launch _ _ (limits, start_testchain, db, validation_process) = {Types.protocol_validator; validation_process; limits; start_testchain} let on_error w r st errs = - Worker.record_event w (Validation_failure (r, st, errs)) ; - Lwt.return_error errs + Worker.log_event w (Validation_failure (r, st, errs)) + >>= fun () -> + (* Keep the worker alive. *) + return_unit let on_completion : type a. t -> a Request.t -> a -> Worker_types.request_status -> unit Lwt.t = - fun w (Request.Request_validation _ as r) v st -> + fun w (Request.Request_validation {hash; _} as r) v st -> match v with - | Ok (Some _) -> - Worker.record_event w (Event.Validation_success (Request.view r, st)) ; - Lwt.return_unit - | Ok None -> - Lwt.return_unit - | Error errs -> - Worker.record_event - w - (Event.Validation_failure (Request.view r, st, errs)) ; - Lwt.return_unit + | Already_commited | Outdated_block -> + Worker.log_event w (Previously_validated hash) + >>= fun () -> Lwt.return_unit + | Validated -> + Worker.log_event w (Validation_success (Request.view r, st)) + | Validation_error errs -> + Worker.log_event w (Event.Validation_failure (Request.view r, st, errs)) let on_close w = let bv = Worker.state w in @@ -310,23 +269,12 @@ let shutdown = Worker.shutdown let validate w ?canceler ?peer ?(notify_new_block = fun _ -> ()) chain_db hash (header : Block_header.t) operations = - let bv = Worker.state w in let chain_state = Distributed_db.chain_state chain_db in - should_validate_block w chain_state hash + is_already_validated chain_state hash >>= function - | Some (block, false) -> - debug - w - "previously validated block %a (before pipe)" - Block_hash.pp_short - hash ; - Protocol_validator.prefetch_and_compile_protocols - bv.protocol_validator - ?peer - ~timeout:bv.limits.protocol_timeout - block ; - return_none - | Some (_, true) | None -> + | true -> + Worker.log_event w (Previously_validated hash) >>= fun () -> return_unit + | false -> ( let hashes = List.map (List.map Operation.hash) operations in let computed_hash = Operation_list_list_hash.compute @@ -358,7 +306,11 @@ let validate w ?canceler ?peer ?(notify_new_block = fun _ -> ()) chain_db hash header; operations; }) - >>=? fun result -> Lwt.return result + >>= function + | Ok (Validated | Already_commited | Outdated_block) -> + return_unit + | Ok (Validation_error errs) | Error errs -> + Lwt.return_error errs ) let fetch_and_compile_protocol w = let bv = Worker.state w in diff --git a/src/lib_shell/block_validator.mli b/src/lib_shell/block_validator.mli index 27a6ee9e5adc785c0e34f5da1765a57e9b5fb344..ee0859282f5d76e1725deba38f34d1a0ece0ff44 100644 --- a/src/lib_shell/block_validator.mli +++ b/src/lib_shell/block_validator.mli @@ -98,7 +98,7 @@ val validate : Block_hash.t -> Block_header.t -> Operation.t list list -> - State.Block.t option tzresult Lwt.t + unit tzresult Lwt.t val fetch_and_compile_protocol : t -> diff --git a/src/lib_shell/block_validator_process.ml b/src/lib_shell/block_validator_process.ml index 35c810c422685d7703a2e4b33b949355e7fc5c74..423e91417b32a57deeb05ed6383e1d4ed049fe3d 100644 --- a/src/lib_shell/block_validator_process.ml +++ b/src/lib_shell/block_validator_process.ml @@ -72,7 +72,51 @@ type t = (** The standard block validation method *) module Internal_validator_process = struct - include Block_validator_process_state.Seq_validator_events + module Events = struct + open Internal_event.Simple + + let section = ["sequential_block_validator"] + + let init = + declare_0 + ~section + ~level:Notice + ~name:"seq_initialized" + ~msg:"initialized" + () + + let close = + declare_0 + ~section + ~level:Notice + ~name:"seq_close" + ~msg:"shutting down" + () + + let validation_request = + declare_2 + ~section + ~level:Debug + ~name:"seq_validation_request" + ~msg:"requesting validation of {block} for chain {chain}" + ~pp1:Block_hash.pp + ("block", Block_hash.encoding) + ~pp2:Chain_id.pp + ("chain", Chain_id.encoding) + + let validation_success = + declare_2 + ~section + ~level:Debug + ~name:"seq_validation_success" + ~msg:"block {block} successfully validated in {timespan}" + ~pp1:Block_hash.pp + ("block", Block_hash.encoding) + ~pp2:Time.System.Span.pp_hum + ("timespan", Time.System.Span.encoding) + + let emit = Internal_event.Simple.emit + end type t = { context_index : Context.index; @@ -84,7 +128,7 @@ module Internal_validator_process = struct let init ({genesis; user_activated_upgrades; user_activated_protocol_overrides} : validator_environment) context_index = - lwt_emit Init + Events.(emit init ()) >>= fun () -> return { @@ -94,7 +138,7 @@ module Internal_validator_process = struct user_activated_protocol_overrides; } - let close _ = lwt_emit Close + let close _ = Events.(emit close ()) let make_apply_environment { user_activated_upgrades; @@ -133,12 +177,17 @@ module Internal_validator_process = struct operations = make_apply_environment validator predecessor max_operations_ttl >>=? fun env -> - lwt_timed_emit - (Validation_request (Block_header.hash block_header, env.chain_id)) - >>= fun event_start -> + let now = Systime_os.now () in + let block_hash = Block_header.hash block_header in + Events.(emit validation_request (block_hash, env.chain_id)) + >>= fun () -> Block_validation.apply env block_header operations >>=? fun result -> - lwt_emit (Validation_success (Block_header.hash block_header, event_start)) + let timespan = + let then_ = Systime_os.now () in + Ptime.diff then_ now + in + Events.(emit validation_success (block_hash, timespan)) >>= fun () -> return result let commit_genesis validator ~chain_id = @@ -159,7 +208,114 @@ end (** Block validation using an external process *) module External_validator_process = struct - include Block_validator_process_state.External_validator_events + module Events = struct + open Internal_event.Simple + + let section = ["external_block_validator"] + + let init = + declare_0 + ~section + ~level:Notice + ~name:"proc_initialized" + ~msg:"initialized" + () + + let close = + declare_0 + ~section + ~level:Notice + ~name:"proc_close" + ~msg:"shutting down" + () + + let process_exited_abnormally = + let open Unix in + let process_status_encoding = + let open Data_encoding in + union + [ case + (Tag 0) + ~title:"wexited" + int31 + (function WEXITED i -> Some i | _ -> None) + (fun i -> WEXITED i); + case + (Tag 1) + ~title:"wsignaled" + int31 + (function WSIGNALED i -> Some i | _ -> None) + (fun i -> WSIGNALED i); + case + (Tag 2) + ~title:"wstopped" + int31 + (function WSTOPPED i -> Some i | _ -> None) + (fun i -> WSTOPPED i) ] + in + declare_1 + ~section + ~level:Error + ~name:"proc_status" + ~msg:"{status_msg}" + ~pp1:(fun fmt status -> + match status with + | WEXITED i -> + Format.fprintf + fmt + "process terminated abnormally with exit code %i" + i + | WSIGNALED i -> + Format.fprintf + fmt + "process was killed by signal %s" + (Lwt_exit.signal_name i) + | WSTOPPED i -> + Format.fprintf + fmt + "process was stopped by signal %s" + (Lwt_exit.signal_name i)) + ("status_msg", process_status_encoding) + + let process_exited_normally = + declare_0 + ~section + ~level:Notice + ~name:"proc_exited_normally" + ~msg:"process terminated normally" + () + + let validator_started = + declare_1 + ~section + ~level:Notice + ~name:"proc_validator_started" + ~msg:"block validator process started with pid {pid}" + ~pp1:Format.pp_print_int + ("pid", Data_encoding.int31) + + let request_for = + declare_1 + ~section + ~level:Debug + ~name:"proc_request" + ~msg:"request for {request}" + ~pp1:External_validation.request_pp + ("request", External_validation.request_encoding) + + let request_result = + declare_2 + ~section + ~level:Debug + ~name:"proc_request_result" + ~msg:"completion of {request_result} in {timespan}" + ~pp1:External_validation.request_pp + ("request_result", External_validation.request_encoding) + ~pp2:Time.System.Span.pp_hum + ("timespan", Time.System.Span.encoding) + + let emit = Internal_event.Simple.emit + end type validator_process = { process : Lwt_process.process_none; @@ -243,7 +399,7 @@ module External_validator_process = struct >>= fun (process, process_socket) -> let process_stdin = Lwt_io.of_fd ~mode:Output process_socket in let process_stdout = Lwt_io.of_fd ~mode:Input process_socket in - lwt_emit (Validator_started process#pid) + Events.(emit validator_started process#pid) >>= fun () -> let parameters = { @@ -287,7 +443,8 @@ module External_validator_process = struct Lwt_canceler.cancel canceler >>= fun () -> vp.validator_process <- None ; - lwt_emit (Process_status status) >>= fun () -> start_process vp ) + Events.(emit process_exited_abnormally status) + >>= fun () -> start_process vp ) | None -> start_process vp ) >>=? fun (process, process_stdin, process_stdout) -> @@ -296,8 +453,9 @@ module External_validator_process = struct (* Make sure that the promise is not canceled between a send and recv *) Lwt.protected (Lwt_mutex.with_lock vp.lock (fun () -> - lwt_timed_emit (Request request) - >>= fun event_start -> + let now = Systime_os.now () in + Events.(emit request_for request) + >>= fun () -> External_validation.send process_stdin External_validation.request_encoding @@ -305,7 +463,11 @@ module External_validator_process = struct >>= fun () -> External_validation.recv_result process_stdout result_encoding >>= fun res -> - lwt_emit (Request_result (request, event_start)) + let timespan = + let then_ = Systime_os.now () in + Ptime.diff then_ now + in + Events.(emit request_result (request, timespan)) >>= fun () -> Lwt.return res)) >>=? fun res -> match process#state with @@ -313,14 +475,15 @@ module External_validator_process = struct return res | Exited status -> vp.validator_process <- None ; - lwt_emit (Process_status status) >>= fun () -> return res) + Events.(emit process_exited_abnormally status) + >>= fun () -> return res) (function | errors -> ( match process#state with | Running -> Lwt.return_unit | Exited status -> - lwt_emit (Process_status status) + Events.(emit process_exited_abnormally status) >>= fun () -> vp.validator_process <- None ; Lwt.return_unit ) @@ -330,7 +493,7 @@ module External_validator_process = struct ({genesis; user_activated_upgrades; user_activated_protocol_overrides} : validator_environment) data_dir context_root protocol_root process_path sandbox_parameters = - lwt_emit Init + Events.(emit init ()) >>= fun () -> let validator = { @@ -389,12 +552,12 @@ module External_validator_process = struct send_request validator request Data_encoding.(option int31) let close vp = - lwt_emit Close + Events.(emit close ()) >>= fun () -> match vp.validator_process with | Some {process; stdin = process_stdin; canceler; _} -> let request = External_validation.Terminate in - lwt_emit (Request request) + Events.(emit request_for request) >>= fun () -> External_validation.send process_stdin @@ -404,9 +567,11 @@ module External_validator_process = struct process#status >>= (function | Unix.WEXITED 0 -> - Lwt.return_unit - | _ -> - process#terminate ; Lwt.return_unit) + Events.(emit process_exited_normally ()) + >>= fun () -> Lwt.return_unit + | status -> + Events.(emit process_exited_abnormally status) + >>= fun () -> process#terminate ; Lwt.return_unit) >>= fun () -> Lwt_canceler.cancel canceler >>= fun () -> diff --git a/src/lib_shell/block_validator_process_state.ml b/src/lib_shell/block_validator_process_state.ml deleted file mode 100644 index 5a4e775b1e07e6a37093c7dd4d4604b1c4af6fc1..0000000000000000000000000000000000000000 --- a/src/lib_shell/block_validator_process_state.ml +++ /dev/null @@ -1,285 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2018 Nomadic Labs. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Event definition and registration for the standard block - validation method *) -module Seq_validator_events = struct - type status = - | Init - | Close - | Validation_request of Block_hash.t * Chain_id.t - | Validation_success of Block_hash.t * Ptime.t - - let status_pp ppf = function - | Init -> - Format.fprintf ppf "Initialized" - | Close -> - Format.fprintf ppf "Shutting down" - | Validation_request (block_hash, chain_id) -> - Format.fprintf - ppf - "Requesting validation of block %a for chain %a" - Block_hash.pp_short - block_hash - Chain_id.pp_short - chain_id - | Validation_success (block_hash, start_time) -> - Format.fprintf - ppf - "Block %a successfully validated in %a" - Block_hash.pp_short - block_hash - Ptime.Span.pp - (Ptime.diff (Systime_os.now ()) start_time) - - type s = status Time.System.stamped - - module Definition = struct - let name = "block_validator_process_sequential" - - type nonrec t = s - - let encoding = - let open Data_encoding in - Time.System.stamped_encoding - @@ union - [ case - (Tag 0) - ~title:"Init" - empty - (function Init -> Some () | _ -> None) - (fun () -> Init); - case - (Tag 1) - ~title:"Close" - empty - (function Close -> Some () | _ -> None) - (fun () -> Close); - case - (Tag 2) - ~title:"Validation_request" - (tup2 Block_hash.encoding Chain_id.encoding) - (function - | Validation_request (h, c) -> Some (h, c) | _ -> None) - (fun (h, c) -> Validation_request (h, c)); - case - (Tag 3) - ~title:"Validation_success" - (tup2 Block_hash.encoding Time.System.encoding) - (function - | Validation_success (bh, st) -> Some (bh, st) | _ -> None) - (fun (bh, st) -> Validation_success (bh, st)) ] - - let pp ~short:_ ppf (status : t) = - Format.fprintf ppf "%a" status_pp status.data - - let doc = "Sequential block validator status." - - let level (status : t) = - match status.data with - | Init | Close -> - Internal_event.Notice - | Validation_request _ | Validation_success _ -> - Internal_event.Debug - end - - module Event_block_validator_process = Internal_event.Make (Definition) - - let lwt_emit status = - let time = Systime_os.now () in - Event_block_validator_process.emit - ~section:(Internal_event.Section.make_sanitized [Definition.name]) - (fun () -> Time.System.stamp ~time status) - >>= function - | Ok () -> - Lwt.return_unit - | Error el -> - Format.kasprintf - Lwt.fail_with - "Block_validator_process_sequential_event.emit: %a" - pp_print_error - el - - let lwt_timed_emit status = - let now = Systime_os.now () in - lwt_emit status >>= fun () -> Lwt.return now -end - -(** Event definition and registration for block validation using an - external process *) -module External_validator_events = struct - type status = - | Init - | Close - | Process_status of Unix.process_status - | Validator_started of int - | Request of External_validation.request - | Request_result of External_validation.request * Ptime.t - - let status_pp ppf = function - | Init -> - Format.fprintf ppf "Initialized" - | Close -> - Format.fprintf ppf "Shutting down" - | Process_status s -> ( - match s with - | WEXITED 0 -> - Format.fprintf ppf "The process terminated normally" - | WEXITED i -> - Format.fprintf - ppf - "The process terminated abnormally with value %i" - i - | WSIGNALED i -> - Format.fprintf - ppf - "The process was killed by signal %s" - (Lwt_exit.signal_name i) - | WSTOPPED i -> - Format.fprintf - ppf - "The process was stopped by signal %s" - (Lwt_exit.signal_name i) ) - | Validator_started pid -> - Format.fprintf ppf "Block validator started with pid %i" pid - | Request r -> - Format.fprintf ppf "Request for %a" External_validation.request_pp r - | Request_result (req, start_time) -> - Format.fprintf - ppf - "Completion of %a in %a" - External_validation.request_pp - req - Ptime.Span.pp - (Ptime.diff (Systime_os.now ()) start_time) - - type s = status Time.System.stamped - - module Definition = struct - let name = "block_validator_process_external" - - type nonrec t = s - - let process_status_encoding = - let open Data_encoding in - union - Unix. - [ case - (Tag 0) - ~title:"wexited" - int31 - (function WEXITED i -> Some i | _ -> None) - (fun i -> WEXITED i); - case - (Tag 1) - ~title:"wsignaled" - int31 - (function WSIGNALED i -> Some i | _ -> None) - (fun i -> WSIGNALED i); - case - (Tag 2) - ~title:"wstopped" - int31 - (function WSTOPPED i -> Some i | _ -> None) - (fun i -> WSTOPPED i) ] - - let encoding = - let open Data_encoding in - Time.System.stamped_encoding - @@ union - [ case - (Tag 0) - ~title:"Init" - empty - (function Init -> Some () | _ -> None) - (fun () -> Init); - case - (Tag 1) - ~title:"Close" - empty - (function Close -> Some () | _ -> None) - (fun () -> Close); - case - (Tag 2) - ~title:"Process_status" - process_status_encoding - (function Process_status s -> Some s | _ -> None) - (fun s -> Process_status s); - case - (Tag 3) - ~title:"Validation_started" - int31 - (function Validator_started pid -> Some pid | _ -> None) - (fun pid -> Validator_started pid); - case - (Tag 4) - ~title:"Request_sent" - External_validation.request_encoding - (function Request r -> Some r | _ -> None) - (fun r -> Request r); - case - (Tag 5) - ~title:"Request_result" - (tup2 External_validation.request_encoding Time.System.encoding) - (function Request_result (r, st) -> Some (r, st) | _ -> None) - (fun (r, st) -> Request_result (r, st)) ] - - let pp ~short:_ ppf (status : t) = - Format.fprintf ppf "%a" status_pp status.data - - let doc = "External block validator status." - - let level (status : t) = - match status.data with - | Init | Close | Process_status (WEXITED 0) | Validator_started _ -> - Internal_event.Notice - | Process_status _ -> - Internal_event.Fatal - | Request _ | Request_result _ -> - Internal_event.Debug - end - - module Event_block_validator_process = Internal_event.Make (Definition) - - let lwt_emit status = - let time = Systime_os.now () in - Event_block_validator_process.emit - ~section:(Internal_event.Section.make_sanitized [Definition.name]) - (fun () -> Time.System.stamp ~time status) - >>= function - | Ok () -> - Lwt.return_unit - | Error el -> - Format.kasprintf - Lwt.fail_with - "Block_validator_process_external_event.emit: %a" - pp_print_error - el - - let lwt_timed_emit status = - let now = Systime_os.now () in - lwt_emit status >>= fun () -> Lwt.return now -end diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index 7f9d6e833871012422306db20592b3a7b9345a08..c080b27a490ea71ae4e0eb1306b40d08648abc41 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -252,6 +252,21 @@ let may_update_checkpoint chain_state new_head = chain_state new_checkpoint ) ) +let may_update_protocol_levels chain_state ~prev ~block = + let prev_proto_level = State.Block.protocol_level prev in + let new_proto_level = State.Block.protocol_level block in + if Compare.Int.(prev_proto_level < new_proto_level) then + State.Block.protocol_hash block + >>=? fun new_protocol -> + State.Chain.update_level_indexed_protocol_store + chain_state + (State.Chain.id chain_state) + new_proto_level + new_protocol + (State.Block.header block) + >>= fun () -> return_unit + else return_unit + let may_switch_test_chain w active_chains spawn_child block = let nv = Worker.state w in let create_child block protocol expiration forking_block = @@ -392,6 +407,34 @@ let safe_get_prevalidator_filter hash = let module Filter = Prevalidator_filters.No_filter (Proto) in return (module Filter : Prevalidator_filters.FILTER) ) +let may_instanciate_new_prevalidator nv ~prev ~block = + match nv.prevalidator with + | Some old_prevalidator -> + let prev_proto_level = State.Block.protocol_level prev in + let new_proto_level = State.Block.protocol_level block in + if Compare.Int.(prev_proto_level < new_proto_level) then ( + State.Block.protocol_hash block + >>=? fun new_protocol -> + safe_get_prevalidator_filter new_protocol + >>=? fun (module Filter) -> + let (limits, chain_db) = Prevalidator.parameters old_prevalidator in + (* TODO inject in the new prevalidator the operation + from the previous one. *) + Prevalidator.create limits (module Filter) chain_db + >>= function + | Error errs -> + Chain_validator_event.(emit prevalidator_reinstantiation_failure) + errs + >>= fun () -> + nv.prevalidator <- None ; + Prevalidator.shutdown old_prevalidator >>= fun () -> return_unit + | Ok prevalidator -> + nv.prevalidator <- Some prevalidator ; + Prevalidator.shutdown old_prevalidator >>= fun () -> return_unit ) + else Prevalidator.flush old_prevalidator (State.Block.hash block) + | None -> + return_unit + let on_request (type a) w start_testchain active_chains spawn_child (req : a Request.t) : a tzresult Lwt.t = let (Request.Validated block) = req in @@ -400,8 +443,7 @@ let on_request (type a) w start_testchain active_chains spawn_child >>= fun head -> let head_header = State.Block.header head and head_hash = State.Block.hash head - and block_header = State.Block.header block - and block_hash = State.Block.hash block in + and block_header = State.Block.header block in ( match nv.prevalidator with | None -> Lwt.return head_header.shell.fitness @@ -421,34 +463,11 @@ let on_request (type a) w start_testchain active_chains spawn_child >>=? fun previous -> may_update_checkpoint nv.parameters.chain_state block >>=? fun () -> + may_update_protocol_levels nv.parameters.chain_state ~prev:previous ~block + >>=? fun () -> broadcast_head w ~previous block >>= fun () -> - ( match nv.prevalidator with - | Some old_prevalidator -> - State.Block.protocol_hash block - >>=? fun new_protocol -> - let old_protocol = Prevalidator.protocol_hash old_prevalidator in - if not (Protocol_hash.equal old_protocol new_protocol) then ( - safe_get_prevalidator_filter new_protocol - >>=? fun (module Filter) -> - let (limits, chain_db) = Prevalidator.parameters old_prevalidator in - (* TODO inject in the new prevalidator the operation - from the previous one. *) - Prevalidator.create limits (module Filter) chain_db - >>= function - | Error errs -> - Chain_validator_event.(emit prevalidator_reinstantiation_failure) - errs - >>= fun () -> - nv.prevalidator <- None ; - Prevalidator.shutdown old_prevalidator >>= fun () -> return_unit - | Ok prevalidator -> - nv.prevalidator <- Some prevalidator ; - Prevalidator.shutdown old_prevalidator >>= fun () -> return_unit - ) - else Prevalidator.flush old_prevalidator block_hash - | None -> - return_unit ) + may_instanciate_new_prevalidator nv ~prev:previous ~block >>=? fun () -> ( if start_testchain then may_switch_test_chain w active_chains spawn_child block @@ -490,30 +509,71 @@ let on_close w = :: Lwt_utils.may ~f:(fun (_, shutdown) -> shutdown ()) nv.child :: pvs ) +(* Copied from lwtreslib, which is not available in the v8 release branche. *) +let rec list_iter_es f = function + | [] -> + return_unit + | h :: t -> + f h >>=? fun () -> (list_iter_es [@ocaml.tailcall]) f t + +(* Copied from lwtreslib, which is not available in the v8 release branche. *) +let list_iter_es f = function + | [] -> + return_unit + | h :: t -> + Lwt.apply f h >>=? fun () -> (list_iter_es [@ocaml.tailcall]) f t + +let may_load_protocols parameters = + let chain_state = Distributed_db.chain_state parameters.chain_db in + let state = Distributed_db.state parameters.db in + State.Chain.all_indexed_protocols chain_state + >>= fun indexed_protocols -> + list_iter_es + (fun (_proto_level, (proto_hash, _activation_block)) -> + if Registered_protocol.mem proto_hash then return_unit + else + State.Protocol.known state proto_hash + >>= function + | false -> + return_unit + | true -> + (* Only compile protocols that are on-disk *) + Chain_validator_event.(emit loading_protocol proto_hash) + >>= fun () -> + trace + (Validation_errors.Cannot_load_protocol proto_hash) + ( Block_validator.fetch_and_compile_protocol + parameters.block_validator + proto_hash + >>=? fun _ -> return_unit )) + indexed_protocols + let on_launch start_prevalidator w _ parameters = + may_load_protocols parameters + >>=? fun () -> ( if start_prevalidator then State.read_chain_data parameters.chain_state (fun _ {State.current_head; _} -> Lwt.return current_head) >>= fun head -> State.Block.protocol_hash head - >>=? fun head_hash -> - safe_get_prevalidator_filter head_hash + >>=? fun head_protocol_hash -> + safe_get_prevalidator_filter head_protocol_hash >>= function - | Ok (module Proto) -> ( + | Ok (module Proto_filters) -> ( Prevalidator.create parameters.prevalidator_limits - (module Proto) + (module Proto_filters) parameters.chain_db >>= function | Error errs -> - Chain_validator_event.(emit prevalidator_reinstantiation_failure) + Chain_validator_event.(emit prevalidator_instantiation_failure) errs >>= fun () -> return_none | Ok prevalidator -> return_some prevalidator ) | Error errs -> - Chain_validator_event.(emit prevalidator_reinstantiation_failure) errs + Chain_validator_event.(emit prevalidator_instantiation_failure) errs >>= fun () -> return_none else return_none ) >>=? fun prevalidator -> diff --git a/src/lib_shell/chain_validator.mli b/src/lib_shell/chain_validator.mli index be867db4ad541de0ab784b2c1f2b61953301171b..c364742ae2f3249b2fa10c2b5fd9ee93d2ada26c 100644 --- a/src/lib_shell/chain_validator.mli +++ b/src/lib_shell/chain_validator.mli @@ -88,7 +88,7 @@ val validate_block : Block_hash.t -> Block_header.t -> Operation.t list list -> - State.Block.t option tzresult Lwt.t + unit tzresult Lwt.t val shutdown : t -> unit Lwt.t diff --git a/src/lib_shell/chain_validator_event.ml b/src/lib_shell/chain_validator_event.ml index 285155c84b9a6bd29f1abf0b1cb5e38ad500e9bd..46e1b3c56618f559366fc1d374ac035904236e9c 100644 --- a/src/lib_shell/chain_validator_event.ml +++ b/src/lib_shell/chain_validator_event.ml @@ -52,3 +52,21 @@ let prevalidator_reinstantiation_failure = ~level:Error ~pp1:pp_print_error_first ("trace", trace_encoding) + +let prevalidator_instantiation_failure = + declare_1 + ~section + ~name:"prevalidator_instantiation_failure" + ~msg:"failed to instantiate the prevalidator: {trace}" + ~level:Error + ~pp1:pp_print_error_first + ("trace", trace_encoding) + +let loading_protocol = + declare_1 + ~section + ~name:"loading_protocol" + ~level:Notice + ~msg:"loading non-embedded protocol {protocol} from disk" + ~pp1:Protocol_hash.pp + ("protocol", Protocol_hash.encoding) diff --git a/src/lib_shell/distributed_db_message.ml b/src/lib_shell/distributed_db_message.ml index 1ebeb231e54170af1fd157166db30a16d8390dfc..e29986b30f7ea9124bb2794efeed0cc205896614 100644 --- a/src/lib_shell/distributed_db_message.ml +++ b/src/lib_shell/distributed_db_message.ml @@ -27,29 +27,39 @@ module Bounded_encoding = struct open Data_encoding - let block_header_max_size = ref (Some (8 * 1024 * 1024)) + let block_header_max_size = ref (8 * 1024 * 1024) + + let block_locator_max_length = ref 1000 (* FIXME: arbitrary *) let block_header_cache = - ref (Block_header.bounded_encoding ?max_size:!block_header_max_size ()) + ref (Block_header.bounded_encoding ~max_size:!block_header_max_size ()) let block_locator_cache = ref (Block_locator.bounded_encoding - ?max_header_size:!block_header_max_size + ~max_header_size:!block_header_max_size + ~max_length:!block_locator_max_length ()) let update_block_header_encoding () = block_header_cache := - Block_header.bounded_encoding ?max_size:!block_header_max_size () ; + Block_header.bounded_encoding ~max_size:!block_header_max_size () ; block_locator_cache := - Block_locator.bounded_encoding ?max_header_size:!block_header_max_size () + Block_locator.bounded_encoding + ~max_header_size:!block_header_max_size + ~max_length:!block_locator_max_length + () let set_block_header_max_size max = block_header_max_size := max ; update_block_header_encoding () + let set_block_locator_max_length max = + block_locator_max_length := max ; + update_block_header_encoding () + let block_header = delayed (fun () -> !block_header_cache) let block_locator = delayed (fun () -> !block_locator_cache) @@ -128,7 +138,8 @@ module Bounded_encoding = struct let protocol = delayed (fun () -> !protocol_cache) - let mempool_max_operations = ref None + (* Twice the current max size of a mempoool *) + let mempool_max_operations = ref (Some 4000) let mempool_cache = ref (Mempool.bounded_encoding ?max_operations:!mempool_max_operations ()) diff --git a/src/lib_shell/distributed_db_message.mli b/src/lib_shell/distributed_db_message.mli index a06f6d660d80cb7223e9038c35c8056b4e4b8138..f679bce6ad384a1b212c20a688914633b1dc526b 100644 --- a/src/lib_shell/distributed_db_message.mli +++ b/src/lib_shell/distributed_db_message.mli @@ -59,7 +59,9 @@ val cfg : Distributed_db_version.Name.t -> t P2p_params.message_config val pp_json : Format.formatter -> t -> unit module Bounded_encoding : sig - val set_block_header_max_size : int option -> unit + val set_block_header_max_size : int -> unit + + val set_block_locator_max_length : int -> unit val set_operation_max_size : int option -> unit diff --git a/src/lib_shell/peer_validator.ml b/src/lib_shell/peer_validator.ml index 70523288d00fcdacfb65d1f3d57c61e5b98b8ef2..3a179b81f5ffa6555dacde0f7e4596a6dc44f5cb 100644 --- a/src/lib_shell/peer_validator.ml +++ b/src/lib_shell/peer_validator.ml @@ -120,21 +120,17 @@ open Types type t = Worker.dropbox Worker.t -let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg)) - -let bootstrap_new_branch w _head unknown_prefix = +let bootstrap_new_branch w head unknown_prefix = let pv = Worker.state w in let sender_id = Distributed_db.my_peer_id pv.parameters.chain_db in (* sender and receiver are inverted here because they are from the point of view of the node sending the locator *) let seed = {Block_locator.sender_id = pv.peer_id; receiver_id = sender_id} in let len = Block_locator.estimated_length seed unknown_prefix in - debug + Worker.log_event w - "validating new branch from peer %a (approx. %d blocks)" - P2p_peer.Id.pp_short - pv.peer_id - len ; + (Validating_new_branch {peer = pv.peer_id; nb_blocks = len}) + >>= fun () -> let pipeline = Bootstrap_pipeline.create ~notify_new_block:pv.parameters.notify_new_block @@ -155,22 +151,16 @@ let bootstrap_new_branch w _head unknown_prefix = (fun () -> Bootstrap_pipeline.wait pipeline) >>=? fun () -> pv.pipeline <- None ; - debug + Worker.log_event w - "done validating new branch from peer %a." - P2p_peer.Id.pp_short - pv.peer_id ; - return_unit + (New_branch_validated {peer = pv.peer_id; hash = Block_header.hash head}) + >>= fun () -> return_unit let validate_new_head w hash (header : Block_header.t) = let pv = Worker.state w in - debug - w - "fetching operations for new head %a from peer %a" - Block_hash.pp_short - hash - P2p_peer.Id.pp_short - pv.peer_id ; + let block_received = {Event.peer = pv.peer_id; hash} in + Worker.log_event w (Fetching_operations_for_head block_received) + >>= fun () -> map_p (fun i -> Worker.protect w (fun () -> @@ -182,13 +172,8 @@ let validate_new_head w hash (header : Block_header.t) = header.shell.operations_hash)) (0 -- (header.shell.validation_passes - 1)) >>=? fun operations -> - debug - w - "requesting validation for new head %a from peer %a" - Block_hash.pp_short - hash - P2p_peer.Id.pp_short - pv.peer_id ; + Worker.log_event w (Requesting_new_head_validation block_received) + >>= fun () -> Block_validator.validate ~notify_new_block:pv.parameters.notify_new_block pv.parameters.block_validator @@ -197,13 +182,8 @@ let validate_new_head w hash (header : Block_header.t) = header operations >>=? fun _block -> - debug - w - "end of validation for new head %a from peer %a" - Block_hash.pp_short - hash - P2p_peer.Id.pp_short - pv.peer_id ; + Worker.log_event w (New_head_validation_end block_received) + >>= fun () -> let meta = Distributed_db.get_peer_metadata pv.parameters.chain_db pv.peer_id in @@ -228,13 +208,8 @@ let only_if_fitness_increases w distant_header cont = (State.Block.fitness local_header) <= 0 then ( - debug - w - "ignoring head %a with non increasing fitness from peer: %a." - Block_hash.pp_short - (Block_header.hash distant_header) - P2p_peer.Id.pp_short - pv.peer_id ; + Worker.log_event w (Ignoring_head {peer = pv.peer_id; hash}) + >>= fun () -> (* Don't download a branch that cannot beat the current head. *) let meta = Distributed_db.get_peer_metadata pv.parameters.chain_db pv.peer_id @@ -263,47 +238,25 @@ let may_validate_new_head w hash (header : Block_header.t) = >>= fun valid_predecessor -> State.Block.known_invalid chain_state header.shell.predecessor >>= fun invalid_predecessor -> - if valid_block then ( - debug - w - "ignoring previously validated block %a from peer %a" - Block_hash.pp_short - hash - P2p_peer.Id.pp_short - pv.peer_id ; - pv.last_validated_head <- header ; - return_unit ) - else if invalid_block then ( - debug - w - "ignoring known invalid block %a from peer %a" - Block_hash.pp_short - hash - P2p_peer.Id.pp_short - pv.peer_id ; - fail Validation_errors.Known_invalid ) - else if invalid_predecessor then ( - debug - w - "ignoring known invalid block %a from peer %a" - Block_hash.pp_short - hash - P2p_peer.Id.pp_short - pv.peer_id ; + let block_received = {Event.peer = pv.peer_id; hash} in + if valid_block then + Worker.log_event w (Ignoring_previously_validated_block block_received) + >>= fun () -> return_unit + else if invalid_block then + Worker.log_event w (Ignoring_invalid_block block_received) + >>= fun () -> fail Validation_errors.Known_invalid + else if invalid_predecessor then + Worker.log_event w (Ignoring_invalid_block block_received) + >>= fun () -> Distributed_db.commit_invalid_block pv.parameters.chain_db hash header [Validation_errors.Known_invalid] - >>=? fun _ -> fail Validation_errors.Known_invalid ) + >>=? fun _ -> fail Validation_errors.Known_invalid else if not valid_predecessor then ( - debug - w - "missing predecessor for new head %a from peer %a" - Block_hash.pp_short - hash - P2p_peer.Id.pp_short - pv.peer_id ; + Worker.log_event w (Missing_new_head_predecessor block_received) + >>= fun () -> Distributed_db.Request.current_branch pv.parameters.chain_db ~peer:pv.peer_id @@ -327,38 +280,29 @@ let may_validate_new_branch w distant_hash locator = let chain_state = Distributed_db.chain_state pv.parameters.chain_db in State.Block.known_ancestor chain_state locator >>= fun (validity, prefix) -> + let block_received = {Event.peer = pv.peer_id; hash = distant_hash} in match validity with | Known_valid -> let (_, history) = (prefix : Block_locator.t :> _ * Block_hash.t list) in if history <> [] then bootstrap_new_branch w distant_header prefix else return_unit | Known_invalid -> - debug - w - "ignoring branch %a with invalid locator from peer: %a." - Block_hash.pp_short - distant_hash - P2p_peer.Id.pp_short - pv.peer_id ; + Worker.log_event w (Ignoring_branch_with_invalid_locator block_received) + >>= fun () -> fail (Validation_errors.Invalid_locator (pv.peer_id, locator)) | Unknown -> - debug + Worker.log_event w - "ignoring branch %a without common ancestor from peer: %a." - Block_hash.pp_short - distant_hash - P2p_peer.Id.pp_short - pv.peer_id ; - fail Validation_errors.Unknown_ancestor + (Ignoring_branch_without_common_ancestor block_received) + >>= fun () -> fail Validation_errors.Unknown_ancestor let on_no_request w = let pv = Worker.state w in - debug - w - "no new head from peer %a for %g seconds." - P2p_peer.Id.pp_short - pv.peer_id - (Ptime.Span.to_float_s pv.parameters.limits.new_head_request_timeout) ; + let timespan = + Ptime.Span.to_float_s pv.parameters.limits.new_head_request_timeout + in + Worker.log_event w (No_new_head_from_peer {peer = pv.peer_id; timespan}) + >>= fun () -> Distributed_db.Request.current_head pv.parameters.chain_db ~peer:pv.peer_id @@ -369,49 +313,36 @@ let on_request (type a) w (req : a Request.t) : a tzresult Lwt.t = let pv = Worker.state w in match req with | Request.New_head (hash, header) -> - debug - w - "processing new head %a from peer %a." - Block_hash.pp_short - hash - P2p_peer.Id.pp_short - pv.peer_id ; - may_validate_new_head w hash header + Worker.log_event w (Processing_new_head {peer = pv.peer_id; hash}) + >>= fun () -> may_validate_new_head w hash header | Request.New_branch (hash, locator, _seed) -> (* TODO penalize empty locator... ?? *) - debug - w - "processing new branch %a from peer %a." - Block_hash.pp_short - hash - P2p_peer.Id.pp_short - pv.peer_id ; - may_validate_new_branch w hash locator + Worker.log_event w (Processing_new_branch {peer = pv.peer_id; hash}) + >>= fun () -> may_validate_new_branch w hash locator let on_completion w r _ st = - Worker.record_event w (Event.Request (Request.view r, st, None)) ; - Lwt.return_unit + Worker.log_event w (Event.Request (Request.view r, st, None)) + >>= fun () -> Lwt.return_unit let on_error w r st err = let pv = Worker.state w in match err with | ( Validation_errors.Invalid_locator _ | Block_validator_errors.Invalid_block _ ) - :: _ as errors -> + :: _ -> Distributed_db.greylist pv.parameters.chain_db pv.peer_id >>= fun () -> - debug + Worker.log_event w - "Terminating the validation worker for peer %a (kickban)." - P2p_peer.Id.pp_short - pv.peer_id ; - debug w "%a" Error_monad.pp_print_error errors ; + (Terminating_worker + {peer = pv.peer_id; reason = "invalid data received: kickban"}) + >>= fun () -> Worker.trigger_shutdown w ; - Worker.record_event w (Event.Request (r, st, Some err)) ; - Lwt.return_error err + Worker.log_event w (Event.Request (r, st, Some err)) + >>= fun () -> Lwt.return_error err | Block_validator_errors.System_error _ :: _ -> - Worker.record_event w (Event.Request (r, st, Some err)) ; - return_unit + Worker.log_event w (Event.Request (r, st, Some err)) + >>= fun () -> return_unit | Block_validator_errors.Unavailable_protocol {protocol; _} :: _ -> ( Block_validator.fetch_and_compile_protocol pv.parameters.block_validator @@ -427,29 +358,37 @@ let on_error w r st err = return_unit | Error _ -> (* TODO: punish *) - debug + Worker.log_event w - "Terminating the validation worker for peer %a (missing protocol \ - %a)." - P2p_peer.Id.pp_short - pv.peer_id - Protocol_hash.pp_short - protocol ; - Worker.record_event w (Event.Request (r, st, Some err)) ; - Lwt.return_error err ) + (Terminating_worker + { + peer = pv.peer_id; + reason = + Format.asprintf + "missing protocol: %a" + Protocol_hash.pp + protocol; + }) + >>= fun () -> + Worker.log_event w (Event.Request (r, st, Some err)) + >>= fun () -> Lwt.return_error err ) | (Validation_errors.Unknown_ancestor | Validation_errors.Too_short_locator _) :: _ -> - debug + Worker.log_event w - "Terminating the validation worker for peer %a (kick)." - P2p_peer.Id.pp_short - pv.peer_id ; + (Terminating_worker + { + peer = pv.peer_id; + reason = + Format.asprintf "unknown ancestor or too short locator: kick"; + }) + >>= fun () -> Worker.trigger_shutdown w ; - Worker.record_event w (Event.Request (r, st, Some err)) ; - return_unit + Worker.log_event w (Event.Request (r, st, Some err)) + >>= fun () -> return_unit | _ -> - Worker.record_event w (Event.Request (r, st, Some err)) ; - Lwt.return_error err + Worker.log_event w (Event.Request (r, st, Some err)) + >>= fun () -> Lwt.return_error err let on_close w = let pv = Worker.state w in diff --git a/src/lib_shell/prevalidator.ml b/src/lib_shell/prevalidator.ml index 3615578ab4cb144d8bd3de78bcd933e7682a344a..32353bdc7a0445a6d369d85d95966599725acf90 100644 --- a/src/lib_shell/prevalidator.ml +++ b/src/lib_shell/prevalidator.ml @@ -256,8 +256,6 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct type worker = Worker.infinite Worker.queue Worker.t - let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg)) - let list_pendings chain_db ~from_block ~to_block ~live_blocks old_mempool = let rec pop_blocks ancestor block mempool = let hash = State.Block.hash block in @@ -362,26 +360,35 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct try match Protocol_hash.Map.find Proto.hash pv.filter_config with | Some config -> - Data_encoding.Json.destruct Filter.config_encoding config + Lwt.return + (Data_encoding.Json.destruct Filter.Mempool.config_encoding config) | None -> - Filter.default_config + Lwt.return Filter.Mempool.default_config with _ -> - debug w "invalid mempool filter configuration" ; - Filter.default_config + Worker.log_event w Invalid_mempool_filter_configuration + >>= fun () -> Lwt.return Filter.Mempool.default_config - let pre_filter w pv op = + let pre_filter w pv oph op = match decode_operation_data op.Operation.proto with | None -> - debug w "unparsable operation %a" Operation_hash.pp (Operation.hash op) ; - false + Worker.log_event w (Unparsable_operation oph) + >>= fun () -> Lwt.return false | Some protocol_data -> let op = {Filter.Proto.shell = op.shell; protocol_data} in - let config = filter_config w pv in - Filter.pre_filter config op.Filter.Proto.protocol_data - - let post_filter w pv op receipt = - let config = filter_config w pv in - Filter.post_filter config (op, receipt) + filter_config w pv + >>= fun config -> + Lwt.return + (Filter.Mempool.pre_filter config op.Filter.Proto.protocol_data) + + let post_filter w pv ~validation_state_before ~validation_state_after op + receipt = + filter_config w pv + >>= fun config -> + Filter.Mempool.post_filter + config + ~validation_state_before + ~validation_state_after + (op, receipt) let handle_branch_refused pv op oph errors = notify_operation pv `Branch_refused op ; @@ -416,7 +423,8 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct | 0 -> Lwt.return_unit | n -> - debug w "processing %d operations" n ; + Worker.log_event w (Processing_n_operations n) + >>= fun () -> let operations = List.map snd (Operation_hash.Map.bindings pv.pending) in @@ -567,7 +575,8 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct >>= fun () -> Lwt_main.yield () let fetch_operation w pv ?peer oph = - debug w "fetching operation %a" Operation_hash.pp_short oph ; + Worker.log_event w (Fetching_operation oph) + >>= fun () -> Distributed_db.Operation.fetch ~timeout:pv.limits.operation_timeout pv.chain_db @@ -579,12 +588,8 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct Worker.Queue.push_request_now w (Arrived (oph, op)) ; Lwt.return_unit | Error (Distributed_db.Operation.Canceled _ :: _) -> - debug - w - "operation %a included before being prevalidated" - Operation_hash.pp_short - oph ; - Lwt.return_unit + Worker.log_event w (Operation_included oph) + >>= fun () -> Lwt.return_unit | Error _ -> (* should not happen *) Lwt.return_unit @@ -593,10 +598,6 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct lazy (let dir : state RPC_directory.t ref = ref RPC_directory.empty in let module Proto_services = Block_services.Make (Proto) (Proto) in - (* TODO - refused => Operation_hash.Set.t ; - kick le peer - *) dir := RPC_directory.register !dir @@ -612,8 +613,8 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct | Some (module Filter) -> let default = Data_encoding.Json.construct - Filter.config_encoding - Filter.default_config + Filter.Mempool.config_encoding + Filter.Mempool.default_config in return default )) ; dir := @@ -793,11 +794,15 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct return_unit ) else if not (already_handled pv oph) (* prevent double inclusion on flush *) - then ( - if pre_filter w pv op then - (* TODO: should this have an influence on the peer's score ? *) - pv.pending <- Operation_hash.Map.add oph op pv.pending ; - return_unit ) + then + pre_filter w pv oph op + >>= function + | true -> + (* TODO: should this have an influence on the peer's score ? *) + pv.pending <- Operation_hash.Map.add oph op pv.pending ; + return_unit + | false -> + return_unit else return_unit let on_inject _w pv op = @@ -858,10 +863,10 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct let timestamp = Time.System.to_protocol timestamp_system in Prevalidation.create ~predecessor ~timestamp () >>= fun validation_state -> - debug + Worker.log_event w - "%d operations were not washed by the flush" - (Operation_hash.Map.cardinal pending) ; + (Operations_not_flushed (Operation_hash.Map.cardinal pending)) + >>= fun () -> pv.predecessor <- predecessor ; pv.live_blocks <- new_live_blocks ; pv.live_operations <- new_live_operations ; diff --git a/src/lib_shell/prevalidator_filters.ml b/src/lib_shell/prevalidator_filters.ml index 2005dd076adf03380c5e8e652889ff83facbf8c8..2cc1c25cc93d06cfd5f999d9f77da217d3ed2ca3 100644 --- a/src/lib_shell/prevalidator_filters.ml +++ b/src/lib_shell/prevalidator_filters.ml @@ -24,37 +24,49 @@ (*****************************************************************************) module type FILTER = sig - type config + module Proto : Registered_protocol.T - val config_encoding : config Data_encoding.t + module Mempool : sig + type config - val default_config : config + val config_encoding : config Data_encoding.t - module Proto : Registered_protocol.T + val default_config : config + + val pre_filter : config -> Proto.operation_data -> bool - val pre_filter : config -> Proto.operation_data -> bool + val post_filter : + config -> + validation_state_before:Proto.validation_state -> + validation_state_after:Proto.validation_state -> + Proto.operation_data * Proto.operation_receipt -> + bool Lwt.t + end - val post_filter : - config -> - validation_state_before:Proto.validation_state -> - validation_state_after:Proto.validation_state -> - Proto.operation_data * Proto.operation_receipt -> - bool Lwt.t + module RPC : sig + val rpc_services : Environment_context.rpc_context RPC_directory.directory + end end module No_filter (Proto : Registered_protocol.T) = struct - type config = unit + module Proto = Proto - let config_encoding = Data_encoding.empty + module Mempool = struct + type config = unit - let default_config = () + let config_encoding = Data_encoding.empty - module Proto = Proto + let default_config = () + + let pre_filter _ _ = true - let pre_filter _ _ = true + let post_filter _ ~validation_state_before:_ ~validation_state_after:_ _ = + Lwt.return_true + end - let post_filter _ ~validation_state_before:_ ~validation_state_after:_ _ = - Lwt.return_true + module RPC = struct + let rpc_services = Proto.rpc_services + end end let table : (module FILTER) Protocol_hash.Table.t = diff --git a/src/lib_shell/prevalidator_filters.mli b/src/lib_shell/prevalidator_filters.mli index 00e7727d6763d6ec0449e3e3f2f63e0e78868572..87d2a18ca6e83d3df209adf073b840b4e0525306 100644 --- a/src/lib_shell/prevalidator_filters.mli +++ b/src/lib_shell/prevalidator_filters.mli @@ -25,29 +25,28 @@ (** Type of a protocol-specific mempool filter plug-in. *) module type FILTER = sig - (** Type of protocol-specific mempool configuration, as specifiable - in the node's configuration file, and updatable via RPCs. *) - type config + module Proto : Registered_protocol.T - (** Formatting of {!config} for the configuration file and RPCs. *) - val config_encoding : config Data_encoding.t + module Mempool : sig + type config - (** Default configuration value, used when none is specified. *) - val default_config : config + val config_encoding : config Data_encoding.t - (** The protocol this plug-in understands. *) - module Proto : Registered_protocol.T + val default_config : config + + val pre_filter : config -> Proto.operation_data -> bool - (** Tells if an operation should be kept and propagated before even running it. *) - val pre_filter : config -> Proto.operation_data -> bool + val post_filter : + config -> + validation_state_before:Proto.validation_state -> + validation_state_after:Proto.validation_state -> + Proto.operation_data * Proto.operation_receipt -> + bool Lwt.t + end - (** Tells if an operation should be kept and propagated considering its result. *) - val post_filter : - config -> - validation_state_before:Proto.validation_state -> - validation_state_after:Proto.validation_state -> - Proto.operation_data * Proto.operation_receipt -> - bool Lwt.t + module RPC : sig + val rpc_services : Environment_context.rpc_context RPC_directory.directory + end end (** Dummy filter that does nothing *) diff --git a/src/lib_shell/protocol_validator.ml b/src/lib_shell/protocol_validator.ml index fe5d34895fc2fd5b7e65ddc8af81aea6635a2220..3367f7411e398efbac9a9b86f4738087a8d56506 100644 --- a/src/lib_shell/protocol_validator.ml +++ b/src/lib_shell/protocol_validator.ml @@ -24,10 +24,7 @@ (*****************************************************************************) open Validation_errors - -include Internal_event.Legacy_logging.Make_semantic (struct - let name = "node.validator.block" -end) +module Event = Protocol_validator_event type t = { db : Distributed_db.t; @@ -73,9 +70,9 @@ let rec worker_loop bv = | Ok () -> worker_loop bv | Error (Canceled :: _) | Error (Exn Lwt_pipe.Closed :: _) -> - Protocol_validator_event.(emit validator_terminated) () + Event.(emit validator_terminated) () | Error err -> - Protocol_validator_event.(emit unexpected_worker_error) err + Event.(emit unexpected_worker_error) err >>= fun () -> Lwt_canceler.cancel bv.canceler let create db = @@ -126,7 +123,7 @@ let fetch_and_compile_protocol pv ?peer ?timeout hash = | Some protocol -> return protocol | None -> - Protocol_validator_event.(emit fetching_protocol) (hash, peer) + Event.(emit fetching_protocol) (hash, peer) >>= fun () -> Distributed_db.Protocol.fetch pv.db ?peer ?timeout hash ()) >>=? fun protocol -> @@ -172,7 +169,3 @@ let fetch_and_compile_protocols pv ?peer ?timeout (block : State.Block.t) = >>= fun () -> return_unit in protocol >>=? fun () -> test_protocol - -let prefetch_and_compile_protocols pv ?peer ?timeout block = - try ignore (fetch_and_compile_protocols pv ?peer ?timeout block) - with _ -> () diff --git a/src/lib_shell/protocol_validator.mli b/src/lib_shell/protocol_validator.mli index 73fb0699aeef06c24b6fa10b121a76295d075e9e..5c3b1582148f38824ae0ed82053a4d1be213456a 100644 --- a/src/lib_shell/protocol_validator.mli +++ b/src/lib_shell/protocol_validator.mli @@ -45,6 +45,3 @@ val fetch_and_compile_protocols : ?timeout:Ptime.Span.t -> State.Block.t -> unit tzresult Lwt.t - -val prefetch_and_compile_protocols : - t -> ?peer:P2p_peer.Id.t -> ?timeout:Ptime.Span.t -> State.Block.t -> unit diff --git a/src/lib_shell/state.ml b/src/lib_shell/state.ml index fe22cc06ccecd03688060afd33b5612eb100dd8c..b7c889303535b8260388a00a0b7739336b1a5ce0 100644 --- a/src/lib_shell/state.ml +++ b/src/lib_shell/state.ml @@ -272,7 +272,7 @@ let predecessor_n_raw store block_hash distance = in loop block_hash distance -let predecessor_n ?(below_save_point = false) block_store block_hash distance = +let predecessor_n block_store block_hash distance = Lwt.catch (fun () -> predecessor_n_raw block_store block_hash distance @@ -280,8 +280,7 @@ let predecessor_n ?(below_save_point = false) block_store block_hash distance = | None -> Lwt.return_none | Some predecessor -> ( - ( if below_save_point then Header.known (block_store, predecessor) - else Store.Block.Contents.known (block_store, predecessor) ) + Header.known (block_store, predecessor) >>= function | false -> Lwt.return_none | true -> Lwt.return_some predecessor )) (fun _exn -> Lwt.return_none) @@ -472,6 +471,14 @@ module Chain = struct read_chain_data chain_state (fun _ chain_data -> Lwt.return chain_data.test_chain) + let all_indexed_protocols chain_state = + let chain_id = chain_state.chain_id in + let global_state = chain_state.global_state in + Shared.use global_state.global_data (fun global_data -> + let global_store = global_data.global_store in + let chain_store = Store.Chain.get global_store chain_id in + Store.Chain.Protocol_info.bindings chain_store) + let get_level_indexed_protocol chain_state header = let chain_id = chain_state.chain_id in let protocol_level = header.Block_header.shell.proto_level in @@ -1037,9 +1044,9 @@ module Block = struct block.header checkpoint) - let read_predecessor chain_state ~pred ?(below_save_point = false) hash = + let read_predecessor chain_state ~pred hash = Shared.use chain_state.block_store (fun store -> - predecessor_n ~below_save_point store hash pred + predecessor_n store hash pred >>= fun hash_opt -> let new_hash_opt = match hash_opt with @@ -1803,11 +1810,7 @@ let compute_locator_from_hash chain_state ?(max_size = max_locator_size) | Some level -> ( let head_level = head_header.Block_header.shell.level in let distance = Int32.sub head_level level in - predecessor_n - ~below_save_point:true - block_store - head_hash - (Int32.to_int distance) + predecessor_n block_store head_hash (Int32.to_int distance) >>= function | None -> Lwt.return chain_data.caboose @@ -1817,14 +1820,10 @@ let compute_locator_from_hash chain_state ?(max_size = max_locator_size) let get_predecessor = match min_level with | None -> - predecessor_n ~below_save_point:true block_store + predecessor_n block_store | Some min_level -> ( fun block_hash distance -> - predecessor_n - ~below_save_point:true - block_store - block_hash - distance + predecessor_n block_store block_hash distance >>= function | None -> Lwt.return_none @@ -1887,7 +1886,6 @@ let compute_protocol_locator chain_state ?max_size ~proto_level seed = in Shared.use chain_state.block_store (fun block_store -> predecessor_n - ~below_save_point:true block_store (Block.hash chain_data.current_head) (Int32.to_int delta)) diff --git a/src/lib_shell/state.mli b/src/lib_shell/state.mli index 02826fde36d2fa10d70e565ca77ce68cf84ff66c..a0b912110b78598634136969d8b3de13a8dcf6b4 100644 --- a/src/lib_shell/state.mli +++ b/src/lib_shell/state.mli @@ -119,6 +119,12 @@ module Chain : sig This function assumes that the predecessor is known valid. *) val acceptable_block : chain_state -> Block_header.t -> bool Lwt.t + (** List all the indexed protocols in the chain. The resulting list + contains elements of the form [, (, + )]. *) + val all_indexed_protocols : + chain_state -> (int * (Protocol_hash.t * int32)) list Lwt.t + (** Get the level indexed chain protocol store for the given header. *) val get_level_indexed_protocol : chain_state -> Block_header.t -> Protocol_hash.t Lwt.t @@ -178,17 +184,11 @@ module Block : sig val read_opt : Chain.t -> Block_hash.t -> t option Lwt.t (** Will return the full block if the block has never been cleaned - (all blocks for nodes whose history-mode is set to archive), only - the header for nodes below the save point (nodes in full or - rolling history-mode) or even `Pruned` for blocks below the rock - bottom, only for nodes in rolling history-mode. Will fail with - `Not_found` if the given hash is unknown. *) - val read_predecessor : - Chain.t -> - pred:int -> - ?below_save_point:bool -> - Block_hash.t -> - t option Lwt.t + (all blocks for nodes whose history-mode is set to archive), only + the header for nodes below the save point (nodes in full or + rolling history-mode). Will fail with `Not_found` if the given + hash is unknown. *) + val read_predecessor : Chain.t -> pred:int -> Block_hash.t -> t option Lwt.t val store : Chain.t -> diff --git a/src/lib_shell/validator.mli b/src/lib_shell/validator.mli index 35cbf4d268a3f8a4c18ced9e0e8b05401dd5b793..f0ce0736350c1f7a9f0d8d296bfa41766b9c53ab 100644 --- a/src/lib_shell/validator.mli +++ b/src/lib_shell/validator.mli @@ -60,7 +60,7 @@ val validate_block : ?chain_id:Chain_id.t -> Bytes.t -> Operation.t list list -> - (Block_hash.t * State.Block.t option tzresult Lwt.t) tzresult Lwt.t + (Block_hash.t * unit tzresult Lwt.t) tzresult Lwt.t (** Monitor all the valid block (for all activate chains). *) val watcher : t -> State.Block.t Lwt_stream.t * Lwt_watcher.stopper diff --git a/src/lib_shell_services/block_services.mli b/src/lib_shell_services/block_services.mli index a2e69b028edee2128e81d564944eada85319bfef..4842d5fd247adff3c625c40915147452a8f9d676 100644 --- a/src/lib_shell_services/block_services.mli +++ b/src/lib_shell_services/block_services.mli @@ -144,6 +144,8 @@ module Make (Proto : PROTO) (Next_proto : PROTO) : sig operations : operation list list; } + val block_info_encoding : block_info Data_encoding.t + open RPC_context val info : diff --git a/src/lib_shell_services/block_validator_worker_state.ml b/src/lib_shell_services/block_validator_worker_state.ml index ba0ff2498cae34a14efd5035859c9024dbde3c8f..921c0101f7227c3bb97a08fc72cd7c479f4253fc 100644 --- a/src/lib_shell_services/block_validator_worker_state.ml +++ b/src/lib_shell_services/block_validator_worker_state.ml @@ -60,7 +60,9 @@ module Event = struct | Validation_success of Request.view * Worker_types.request_status | Validation_failure of Request.view * Worker_types.request_status * error list - | Debug of string + | Could_not_find_context of Block_hash.t + | Previously_validated of Block_hash.t + | Validating_block of Block_hash.t type view = t @@ -68,46 +70,56 @@ module Event = struct let level req = match req with - | Debug _ -> - Internal_event.Debug | Validation_success _ | Validation_failure _ -> Internal_event.Notice + | Could_not_find_context _ | Previously_validated _ | Validating_block _ -> + Internal_event.Debug let encoding = let open Data_encoding in union [ case (Tag 0) - ~title:"Debug" - (obj1 (req "message" string)) - (function Debug msg -> Some msg | _ -> None) - (fun msg -> Debug msg); - case - (Tag 1) - ~title:"Validation_success" + ~title:"validation_success" (obj2 (req "successful_validation" Request.encoding) (req "status" Worker_types.request_status_encoding)) (function Validation_success (r, s) -> Some (r, s) | _ -> None) (fun (r, s) -> Validation_success (r, s)); case - (Tag 2) - ~title:"Validation_failure" + (Tag 1) + ~title:"validation_failure" (obj3 (req "failed_validation" Request.encoding) (req "status" Worker_types.request_status_encoding) (dft "errors" RPC_error.encoding [])) (function | Validation_failure (r, s, err) -> Some (r, s, err) | _ -> None) - (fun (r, s, err) -> Validation_failure (r, s, err)) ] + (fun (r, s, err) -> Validation_failure (r, s, err)); + case + (Tag 2) + ~title:"could_not_find_context" + (obj1 (req "block" Block_hash.encoding)) + (function Could_not_find_context block -> Some block | _ -> None) + (fun block -> Could_not_find_context block); + case + (Tag 3) + ~title:"previously_validated" + (obj1 (req "block" Block_hash.encoding)) + (function Previously_validated block -> Some block | _ -> None) + (fun block -> Previously_validated block); + case + (Tag 4) + ~title:"validating_block" + (obj1 (req "block" Block_hash.encoding)) + (function Validating_block block -> Some block | _ -> None) + (fun block -> Validating_block block) ] let pp ppf = function - | Debug msg -> - Format.fprintf ppf "%s" msg | Validation_success (req, {pushed; treated; completed}) -> Format.fprintf ppf - "@[Block %a successfully validated@,%a@]" + "@[block %a successfully validated@,%a@]" Block_hash.pp req.block Worker_types.pp_status @@ -115,13 +127,27 @@ module Event = struct | Validation_failure (req, {pushed; treated; completed}, errs) -> Format.fprintf ppf - "@[Validation of block %a failed@,%a, %a@]" + "@[validation of block %a failed@,%a, %a@]" Block_hash.pp req.block Worker_types.pp_status {pushed; treated; completed} (Format.pp_print_list Error_monad.pp) errs + | Could_not_find_context block -> + Format.fprintf + ppf + "could not find context for block %a" + Block_hash.pp + block + | Previously_validated block -> + Format.fprintf + ppf + "previously validated block %a (after pipe)" + Block_hash.pp + block + | Validating_block block -> + Format.fprintf ppf "validating block %a" Block_hash.pp block end module Worker_state = struct diff --git a/src/lib_shell_services/block_validator_worker_state.mli b/src/lib_shell_services/block_validator_worker_state.mli index e534a8dc3fbddc962141d61be01465677672c6aa..b7b6c7fe4264eecc7d99b4570867a30eddd3d43b 100644 --- a/src/lib_shell_services/block_validator_worker_state.mli +++ b/src/lib_shell_services/block_validator_worker_state.mli @@ -40,7 +40,9 @@ module Event : sig | Validation_success of Request.view * Worker_types.request_status | Validation_failure of Request.view * Worker_types.request_status * error list - | Debug of string + | Could_not_find_context of Block_hash.t + | Previously_validated of Block_hash.t + | Validating_block of Block_hash.t type view = t diff --git a/src/lib_shell_services/peer_validator_worker_state.ml b/src/lib_shell_services/peer_validator_worker_state.ml index e477f1df593207c116b48487d05a3509760f96b5..78d2a0e8b16140f954599658aa71149d0a5ad7a7 100644 --- a/src/lib_shell_services/peer_validator_worker_state.ml +++ b/src/lib_shell_services/peer_validator_worker_state.ml @@ -60,10 +60,26 @@ module Request = struct end module Event = struct + type block_received = {peer : P2p_peer.Id.t; hash : Block_hash.t} + type t = | Request of (Request.view * Worker_types.request_status * error list option) - | Debug of string + | Validating_new_branch of {peer : P2p_peer.Id.t; nb_blocks : int} + | New_branch_validated of block_received + | Fetching_operations_for_head of block_received + | Requesting_new_head_validation of block_received + | New_head_validation_end of block_received + | Ignoring_head of block_received + | Ignoring_previously_validated_block of block_received + | Ignoring_invalid_block of block_received + | Missing_new_head_predecessor of block_received + | Ignoring_branch_with_invalid_locator of block_received + | Ignoring_branch_without_common_ancestor of block_received + | No_new_head_from_peer of {peer : P2p_peer.Id.t; timespan : float} + | Processing_new_head of block_received + | Processing_new_branch of block_received + | Terminating_worker of {peer : P2p_peer.Id.t; reason : string} type view = t @@ -71,7 +87,21 @@ module Event = struct let level req = match req with - | Debug _ -> + | Validating_new_branch _ + | New_branch_validated _ + | Fetching_operations_for_head _ + | Requesting_new_head_validation _ + | New_head_validation_end _ + | Ignoring_head _ + | Ignoring_previously_validated_block _ + | Ignoring_invalid_block _ + | Missing_new_head_predecessor _ + | Ignoring_branch_with_invalid_locator _ + | Ignoring_branch_without_common_ancestor _ + | No_new_head_from_peer _ + | Processing_new_head _ + | Processing_new_branch _ + | Terminating_worker _ -> Internal_event.Debug | Request (_, _, Some _) -> Internal_event.Notice @@ -80,17 +110,16 @@ module Event = struct | Request (Request.New_branch (_, _), _, None) -> Internal_event.Info + let block_received_encoding = + let open Data_encoding in + obj2 (req "peer" P2p_peer.Id.encoding) (req "block" Block_hash.encoding) + let encoding = let open Data_encoding in union + ~tag_size:`Uint8 [ case (Tag 0) - ~title:"Debug" - (obj1 (req "message" string)) - (function Debug msg -> Some msg | _ -> None) - (fun msg -> Debug msg); - case - (Tag 1) ~title:"Request" (obj2 (req "request" Request.encoding) @@ -98,7 +127,7 @@ module Event = struct (function Request (req, t, None) -> Some (req, t) | _ -> None) (fun (req, t) -> Request (req, t, None)); case - (Tag 2) + (Tag 1) ~title:"Failed request" (obj3 (req "error" RPC_error.encoding) @@ -106,11 +135,252 @@ module Event = struct (req "status" Worker_types.request_status_encoding)) (function | Request (req, t, Some errs) -> Some (errs, req, t) | _ -> None) - (fun (errs, req, t) -> Request (req, t, Some errs)) ] + (fun (errs, req, t) -> Request (req, t, Some errs)); + case + (Tag 2) + ~title:"validating_new_branch" + (obj2 (req "peer" P2p_peer.Id.encoding) (req "nb_blocks" int31)) + (function + | Validating_new_branch {peer; nb_blocks} -> + Some (peer, nb_blocks) + | _ -> + None) + (fun (peer, nb_blocks) -> Validating_new_branch {peer; nb_blocks}); + case + (Tag 3) + ~title:"new_branch_validated" + block_received_encoding + (function + | New_branch_validated {peer; hash} -> + Some (peer, hash) + | _ -> + None) + (fun (peer, hash) -> New_branch_validated {peer; hash}); + case + (Tag 4) + ~title:"fetching_operations_for_head" + block_received_encoding + (function + | Fetching_operations_for_head {peer; hash} -> + Some (peer, hash) + | _ -> + None) + (fun (peer, hash) -> Fetching_operations_for_head {peer; hash}); + case + (Tag 5) + ~title:"Requesting_new_head_validation" + block_received_encoding + (function + | Requesting_new_head_validation {peer; hash} -> + Some (peer, hash) + | _ -> + None) + (fun (peer, hash) -> Requesting_new_head_validation {peer; hash}); + case + (Tag 6) + ~title:"new_head_validation_end" + block_received_encoding + (function + | New_head_validation_end {peer; hash} -> + Some (peer, hash) + | _ -> + None) + (fun (peer, hash) -> New_head_validation_end {peer; hash}); + case + (Tag 7) + ~title:"ignoring_head" + block_received_encoding + (function + | Ignoring_head {peer; hash} -> Some (peer, hash) | _ -> None) + (fun (peer, hash) -> Ignoring_head {peer; hash}); + case + (Tag 8) + ~title:"ignoring_previously_validated_block" + block_received_encoding + (function + | Ignoring_previously_validated_block {peer; hash} -> + Some (peer, hash) + | _ -> + None) + (fun (peer, hash) -> + Ignoring_previously_validated_block {peer; hash}); + case + (Tag 9) + ~title:"ignoring_invalid_block" + block_received_encoding + (function + | Ignoring_invalid_block {peer; hash} -> + Some (peer, hash) + | _ -> + None) + (fun (peer, hash) -> Ignoring_invalid_block {peer; hash}); + case + (Tag 10) + ~title:"missing_new_head_predecessor" + block_received_encoding + (function + | Missing_new_head_predecessor {peer; hash} -> + Some (peer, hash) + | _ -> + None) + (fun (peer, hash) -> Missing_new_head_predecessor {peer; hash}); + case + (Tag 11) + ~title:"ignoring_invalid_locator_branch" + block_received_encoding + (function + | Ignoring_branch_with_invalid_locator {peer; hash} -> + Some (peer, hash) + | _ -> + None) + (fun (peer, hash) -> + Ignoring_branch_with_invalid_locator {peer; hash}); + case + (Tag 12) + ~title:"ignore_branch_without_common_ancestor" + block_received_encoding + (function + | Ignoring_branch_without_common_ancestor {peer; hash} -> + Some (peer, hash) + | _ -> + None) + (fun (peer, hash) -> + Ignoring_branch_without_common_ancestor {peer; hash}); + case + (Tag 13) + ~title:"no_new_head_from_peer" + (obj2 (req "peer" P2p_peer.Id.encoding) (req "timespan" float)) + (function + | No_new_head_from_peer {peer; timespan} -> + Some (peer, timespan) + | _ -> + None) + (fun (peer, timespan) -> No_new_head_from_peer {peer; timespan}); + case + (Tag 14) + ~title:"processing_new_head" + block_received_encoding + (function + | Processing_new_head {peer; hash} -> Some (peer, hash) | _ -> None) + (fun (peer, hash) -> Processing_new_head {peer; hash}); + case + (Tag 15) + ~title:"processing_new_branch" + block_received_encoding + (function + | Processing_new_branch {peer; hash} -> + Some (peer, hash) + | _ -> + None) + (fun (peer, hash) -> Processing_new_branch {peer; hash}); + case + (Tag 16) + ~title:"terminating_worker" + (obj2 (req "peer" P2p_peer.Id.encoding) (req "reason" string)) + (function + | Terminating_worker {peer; reason} -> + Some (peer, reason) + | _ -> + None) + (fun (peer, reason) -> Terminating_worker {peer; reason}) ] + + let pp_block_received ppf {peer; hash} = + Format.fprintf ppf "%a from %a" Block_hash.pp hash P2p_peer.Id.pp peer let pp ppf = function - | Debug msg -> - Format.fprintf ppf "%s" msg + | Validating_new_branch {peer; nb_blocks} -> + Format.fprintf + ppf + "validating new branch from peer %a (approx. %d blocks)" + P2p_peer.Id.pp + peer + nb_blocks + | New_branch_validated block_received -> + Format.fprintf + ppf + "new branch %a validated" + pp_block_received + block_received + | Fetching_operations_for_head block_received -> + Format.fprintf + ppf + "fetching operations for head %a" + pp_block_received + block_received + | Requesting_new_head_validation block_received -> + Format.fprintf + ppf + "requesting new head validation %a" + pp_block_received + block_received + | New_head_validation_end block_received -> + Format.fprintf + ppf + "new head validation ended %a" + pp_block_received + block_received + | Ignoring_head block_received -> + Format.fprintf + ppf + "ignoring head with non-increasing fitness %a" + pp_block_received + block_received + | Ignoring_previously_validated_block block_received -> + Format.fprintf + ppf + "ignoring previously validated head %a" + pp_block_received + block_received + | Ignoring_invalid_block block_received -> + Format.fprintf + ppf + "ignoring invalid block %a" + pp_block_received + block_received + | Missing_new_head_predecessor block_received -> + Format.fprintf + ppf + "missing new head's predecessor %a" + pp_block_received + block_received + | Ignoring_branch_with_invalid_locator block_received -> + Format.fprintf + ppf + "ignoring branch with invalid locator %a" + pp_block_received + block_received + | Ignoring_branch_without_common_ancestor block_received -> + Format.fprintf + ppf + "ignoring branch without common ancestor %a" + pp_block_received + block_received + | Processing_new_head block_received -> + Format.fprintf + ppf + "processing new head %a" + pp_block_received + block_received + | Processing_new_branch block_received -> + Format.fprintf + ppf + "processing new branch %a" + pp_block_received + block_received + | No_new_head_from_peer {peer; timespan} -> + Format.fprintf + ppf + "no new head from peer %a for %g seconds" + P2p_peer.Id.pp + peer + timespan + | Terminating_worker {peer; reason} -> + Format.fprintf + ppf + "terminating the validation worker for peer %a (%s)" + P2p_peer.Id.pp + peer + reason | Request (view, {pushed; treated; completed}, None) -> Format.fprintf ppf diff --git a/src/lib_shell_services/peer_validator_worker_state.mli b/src/lib_shell_services/peer_validator_worker_state.mli index 757782d29e40a9acc3451e636e320865eb0e3453..950f17368a87aa7becb9c4d88c70f89d5461f1b3 100644 --- a/src/lib_shell_services/peer_validator_worker_state.mli +++ b/src/lib_shell_services/peer_validator_worker_state.mli @@ -32,10 +32,26 @@ module Request : sig end module Event : sig + type block_received = {peer : P2p_peer.Id.t; hash : Block_hash.t} + type t = | Request of (Request.view * Worker_types.request_status * error list option) - | Debug of string + | Validating_new_branch of {peer : P2p_peer.Id.t; nb_blocks : int} + | New_branch_validated of block_received + | Fetching_operations_for_head of block_received + | Requesting_new_head_validation of block_received + | New_head_validation_end of block_received + | Ignoring_head of block_received + | Ignoring_previously_validated_block of block_received + | Ignoring_invalid_block of block_received + | Missing_new_head_predecessor of block_received + | Ignoring_branch_with_invalid_locator of block_received + | Ignoring_branch_without_common_ancestor of block_received + | No_new_head_from_peer of {peer : P2p_peer.Id.t; timespan : float} + | Processing_new_head of block_received + | Processing_new_branch of block_received + | Terminating_worker of {peer : P2p_peer.Id.t; reason : string} type view = t diff --git a/src/lib_shell_services/prevalidator_worker_state.ml b/src/lib_shell_services/prevalidator_worker_state.ml index c4a49c58d642678d83da0bc5bac5e1d23e287ccd..1989ead40d5b580b7e42bc63081fe86a3674b7c5 100644 --- a/src/lib_shell_services/prevalidator_worker_state.ml +++ b/src/lib_shell_services/prevalidator_worker_state.ml @@ -128,7 +128,12 @@ module Event = struct type t = | Request of (Request.view * Worker_types.request_status * error list option) - | Debug of string + | Invalid_mempool_filter_configuration + | Unparsable_operation of Operation_hash.t + | Processing_n_operations of int + | Fetching_operation of Operation_hash.t + | Operation_included of Operation_hash.t + | Operations_not_flushed of int type view = t @@ -137,8 +142,6 @@ module Event = struct let level req = let open Request in match req with - | Debug _ -> - Internal_event.Debug | Request (View (Flush _), _, _) -> Internal_event.Notice | Request (View (Notify _), _, _) -> @@ -151,18 +154,20 @@ module Event = struct Internal_event.Debug | Request (View Advertise, _, _) -> Internal_event.Debug + | Invalid_mempool_filter_configuration + | Unparsable_operation _ + | Processing_n_operations _ + | Fetching_operation _ + | Operation_included _ + | Operations_not_flushed _ -> + Internal_event.Debug let encoding = let open Data_encoding in union + ~tag_size:`Uint8 [ case (Tag 0) - ~title:"Debug" - (obj1 (req "message" string)) - (function Debug msg -> Some msg | _ -> None) - (fun msg -> Debug msg); - case - (Tag 1) ~title:"Request" (obj2 (req "request" Request.encoding) @@ -170,7 +175,7 @@ module Event = struct (function Request (req, t, None) -> Some (req, t) | _ -> None) (fun (req, t) -> Request (req, t, None)); case - (Tag 2) + (Tag 1) ~title:"Failed request" (obj3 (req "error" RPC_error.encoding) @@ -178,11 +183,62 @@ module Event = struct (req "status" Worker_types.request_status_encoding)) (function | Request (req, t, Some errs) -> Some (errs, req, t) | _ -> None) - (fun (errs, req, t) -> Request (req, t, Some errs)) ] + (fun (errs, req, t) -> Request (req, t, Some errs)); + case + (Tag 2) + ~title:"invalid_mempool_configuration" + empty + (function + | Invalid_mempool_filter_configuration -> Some () | _ -> None) + (fun () -> Invalid_mempool_filter_configuration); + case + (Tag 3) + ~title:"unparsable_operation" + Operation_hash.encoding + (function Unparsable_operation oph -> Some oph | _ -> None) + (fun oph -> Unparsable_operation oph); + case + (Tag 4) + ~title:"processing_n_operations" + int31 + (function Processing_n_operations n -> Some n | _ -> None) + (fun n -> Processing_n_operations n); + case + (Tag 5) + ~title:"fetching_operation" + Operation_hash.encoding + (function Fetching_operation oph -> Some oph | _ -> None) + (fun oph -> Fetching_operation oph); + case + (Tag 6) + ~title:"operation_included" + Operation_hash.encoding + (function Operation_included oph -> Some oph | _ -> None) + (fun oph -> Operation_included oph); + case + (Tag 7) + ~title:"operations_not_flushed" + int31 + (function Operations_not_flushed n -> Some n | _ -> None) + (fun n -> Operations_not_flushed n) ] let pp ppf = function - | Debug msg -> - Format.fprintf ppf "%s" msg + | Invalid_mempool_filter_configuration -> + Format.fprintf ppf "invalid mempool filter configuration" + | Unparsable_operation oph -> + Format.fprintf ppf "unparsable operation %a" Operation_hash.pp oph + | Processing_n_operations n -> + Format.fprintf ppf "processing %d operations" n + | Fetching_operation oph -> + Format.fprintf ppf "fetching operation %a" Operation_hash.pp oph + | Operation_included oph -> + Format.fprintf + ppf + "operation %a included before being prevalidated" + Operation_hash.pp + oph + | Operations_not_flushed n -> + Format.fprintf ppf "%d operations were not washed by the flush" n | Request (view, {pushed; treated; completed}, None) -> Format.fprintf ppf diff --git a/src/lib_shell_services/prevalidator_worker_state.mli b/src/lib_shell_services/prevalidator_worker_state.mli index 16f08450d837b032a0bf2e720692d2b069aa45d0..abdfc7d1ceadfc592308ce7a08e3836335abf9d3 100644 --- a/src/lib_shell_services/prevalidator_worker_state.mli +++ b/src/lib_shell_services/prevalidator_worker_state.mli @@ -45,7 +45,12 @@ module Event : sig type t = | Request of (Request.view * Worker_types.request_status * error list option) - | Debug of string + | Invalid_mempool_filter_configuration + | Unparsable_operation of Operation_hash.t + | Processing_n_operations of int + | Fetching_operation of Operation_hash.t + | Operation_included of Operation_hash.t + | Operations_not_flushed of int type view = t diff --git a/src/lib_shell_services/validation_errors.ml b/src/lib_shell_services/validation_errors.ml index 58b4ead648e9650395352980a13a1b6e45a4f6ec..57cff413db8f3dab11e61a0c65f09ef41f5aac56 100644 --- a/src/lib_shell_services/validation_errors.ml +++ b/src/lib_shell_services/validation_errors.ml @@ -330,6 +330,25 @@ let () = | Invalid_protocol {hash; error} -> Some (hash, error) | _ -> None) (fun (hash, error) -> Invalid_protocol {hash; error}) +type error += Cannot_load_protocol of Protocol_hash.t + +let () = + register_error_kind + `Permanent + ~id:"node.protocol_validator.cannot_load_protocol" + ~title:"Cannot load protocol" + ~description:"Cannot load protocol from disk" + ~pp:(fun ppf protocol -> + Format.fprintf + ppf + "Failed to load the protocol %a from disk: the corresponding files \ + might be missing or corrupted." + Protocol_hash.pp + protocol) + Data_encoding.(obj1 (req "protocol" Protocol_hash.encoding)) + (function Cannot_load_protocol protocol -> Some protocol | _ -> None) + (fun protocol -> Cannot_load_protocol protocol) + (********************* Peer validator errors ******************************) type error += Unknown_ancestor | Known_invalid diff --git a/src/lib_shell_services/validation_errors.mli b/src/lib_shell_services/validation_errors.mli index a9209133fa2b35bc0258f596a7aa9f0eff29cbf1..b182a73cce9c9bebf928e4c9aa0ed279fe335cce 100644 --- a/src/lib_shell_services/validation_errors.mli +++ b/src/lib_shell_services/validation_errors.mli @@ -70,6 +70,8 @@ type protocol_error = Compilation_failed | Dynlinking_failed type error += | Invalid_protocol of {hash : Protocol_hash.t; error : protocol_error} +type error += Cannot_load_protocol of Protocol_hash.t + (********************* Peer validator errors ******************************) type error += Unknown_ancestor | Known_invalid diff --git a/src/lib_signer_backends/encrypted.ml b/src/lib_signer_backends/encrypted.ml index 29cf03e7f5d80e41100e75330d0a883cd40bab08..4a59ee482c5b55d3654e1eeb92a35cc65c2d5f50 100644 --- a/src/lib_signer_backends/encrypted.ml +++ b/src/lib_signer_backends/encrypted.ml @@ -268,7 +268,7 @@ module Sapling_raw = struct Pbkdf.SHA512.pbkdf2 ~count:32768 ~dk_len:32l ~salt ~password let encrypt ~password msg = - let msg = Sapling.Core.Wallet.Spending_key.to_bytes msg in + let msg = Tezos_sapling.Core.Wallet.Spending_key.to_bytes msg in let salt = Hacl.Rand.gen salt_len in let key = Crypto_box.Secretbox.unsafe_of_bytes (pbkdf ~salt ~password) in Bytes.(to_string (cat salt (Crypto_box.Secretbox.secretbox key msg nonce))) @@ -280,9 +280,9 @@ module Sapling_raw = struct let key = Crypto_box.Secretbox.unsafe_of_bytes (pbkdf ~salt ~password) in Option.( Crypto_box.Secretbox.secretbox_open key encrypted_sk nonce - >>= Sapling.Core.Wallet.Spending_key.of_bytes) + >>= Tezos_sapling.Core.Wallet.Spending_key.of_bytes) - type Base58.data += Data of Sapling.Core.Wallet.Spending_key.t + type Base58.data += Data of Tezos_sapling.Core.Wallet.Spending_key.t let encrypted_b58_encoding password = Base58.register_encoding @@ -321,7 +321,7 @@ let decrypt_sapling_key (cctxt : #Client_context.io) (sk_uri : sapling_uri) = else match Base58.simple_decode - Sapling.Core.Wallet.Spending_key.b58check_encoding + Tezos_sapling.Core.Wallet.Spending_key.b58check_encoding payload with | None -> diff --git a/src/lib_signer_backends/encrypted.mli b/src/lib_signer_backends/encrypted.mli index 9e740d586164385a9e3b909332460a35d84a936c..b5a60a87d7a0e24969971e10e1bf636012005699 100644 --- a/src/lib_signer_backends/encrypted.mli +++ b/src/lib_signer_backends/encrypted.mli @@ -45,10 +45,10 @@ val encrypt : val encrypt_sapling_key : #Client_context.io -> - Sapling.Core.Wallet.Spending_key.t -> + Tezos_sapling.Core.Wallet.Spending_key.t -> Client_keys.sapling_uri tzresult Lwt.t val decrypt_sapling_key : #Client_context.io -> Client_keys.sapling_uri -> - Sapling.Core.Wallet.Spending_key.t tzresult Lwt.t + Tezos_sapling.Core.Wallet.Spending_key.t tzresult Lwt.t diff --git a/src/lib_signer_backends/unencrypted.ml b/src/lib_signer_backends/unencrypted.ml index 9603a5a755aace285eb79cf5122de1cce30913ce..6dd2a846a5688643bf09dda63e43ff4b0d97bc7f 100644 --- a/src/lib_signer_backends/unencrypted.ml +++ b/src/lib_signer_backends/unencrypted.ml @@ -48,7 +48,9 @@ let make_sk sk = let make_sapling_key sk = let path = - Base58.simple_encode Sapling.Core.Wallet.Spending_key.b58check_encoding sk + Base58.simple_encode + Tezos_sapling.Core.Wallet.Spending_key.b58check_encoding + sk in Client_keys.make_sapling_uri (Uri.make ~scheme ~path ()) diff --git a/src/lib_signer_backends/unencrypted.mli b/src/lib_signer_backends/unencrypted.mli index f60f48500c75375756485b0dc999236b7b8b3920..8eb2c16e2455d0ab12b396508512772f22db2964 100644 --- a/src/lib_signer_backends/unencrypted.mli +++ b/src/lib_signer_backends/unencrypted.mli @@ -30,4 +30,4 @@ val make_pk : Signature.public_key -> Client_keys.pk_uri tzresult Lwt.t val make_sk : Signature.secret_key -> Client_keys.sk_uri tzresult Lwt.t val make_sapling_key : - Sapling.Core.Wallet.Spending_key.t -> Client_keys.sapling_uri + Tezos_sapling.Core.Wallet.Spending_key.t -> Client_keys.sapling_uri diff --git a/src/lib_stdlib/circular_buffer.ml b/src/lib_stdlib/circular_buffer.ml new file mode 100644 index 0000000000000000000000000000000000000000..d5e5b4893d37564dc4ecd1efdc17f685346d2441 --- /dev/null +++ b/src/lib_stdlib/circular_buffer.ml @@ -0,0 +1,290 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Lwt + +(* The buffer is just an array of bytes. + We remember the segment which is full in the buffer. *) +type t = { + buffer : Bytes.t; + fresh_buf_size : int; + mutable data_start : int; + mutable data_end : int; + mutable full : bool; +} + +(* A piece of data is just an offset in the buffer with its length or a + fresh buffer if the buffer is full. *) +type data = {offset : int; length : int; buf : Bytes.t} + +let create ?(maxlength = 1 lsl 15) ?(fresh_buf_size = 2000) () = + { + buffer = Bytes.create maxlength; + data_start = 0; + data_end = 0; + full = false; + fresh_buf_size; + } + +(* Invariant: + - There is no two concurrent write at the same time + - read should be called in the same order than write + *) + +(* [get_buf_with_offset t write_len] Find a place where [write_len] data can be written onto the buffer [t]. + +Multiple situtation can arise + +1) STARTS preceeds END, + _____START____________________END_______ +[_______|ddddddddddddddddddddddd|________] +|<--Y-->|<----- data ---------->|<---X-->| + + 1.1) either X zone can contain [write_len], + 1.2) or Y zone can contain [write_len], + 1.3) or neither is big enough,we create a temporary buffer of size [write_len] + +2) END preceeds START , + ______END____________________START______ +[ddddddd|_______________________|dddddd__] + + 2.1) either the free zone between END and START can contain [write_len], + 2.2) or we create a temporary buffer of size [write_len] + +3) START and END are identical + 3.1) + ____START_END___________________________ +[_______|________________________________]=> t.full = false + + 3.2) + ____END_START___________________________ +[ddddddd|dddddddddddddddddddddddddddddd__] => t.full = true + + *) +(* Pre-condition: write_len > 0 *) +let get_buf_with_offset t write_len = + (* Case 3.1 -> put the pointers at the beginning of the buffer which + may save some space. *) + if t.data_start = t.data_end && not t.full then ( + t.data_start <- 0 ; + t.data_end <- 0 ) ; + if t.data_start < t.data_end || (t.data_start = t.data_end && not t.full) + then + if t.data_end + write_len <= Bytes.length t.buffer then + (* case 1.1 and 3.1: we write after END *) + (t.buffer, t.data_end) + else if t.data_start >= write_len then + (* case 1.2: we write before START *) + (t.buffer, 0) + else (* case 1.3: not enough space *) + (Bytes.create t.fresh_buf_size, 0) + else if t.data_end < t.data_start then + if t.data_end + write_len <= t.data_start then + (* case 2.1: we write between END and START *) + (t.buffer, t.data_end) + else (* case 2.2: not enough space *) + (Bytes.create t.fresh_buf_size, 0) + else + (* case 3.3: t.data_start =t.data_end && t.full *) + (* not enough space *) + (Bytes.create t.fresh_buf_size, 0) + +(* [write ~maxlen ~fill_using:f buffer] + - first ask a buffer,offset pair with enough space for writting maxlen data + - calls [fill_using buf offset maxlen] and get the [written] bytes count + - if we used the circular buffer and not a freshly allocated one, we update the data_end field + + After a correct write the following property holds: + +'o' stands for old data +'_' for free zone +'w' for just written data +'r' is the returned record + +- initial situation STARTS preceeds END, + ___________________START___________END_________ +[_____________________|oooooooooooooo|__________] +|<--------X zone----->| |<-Y zone->| + + - either X zone can contain [write_len], + ___________________START_________OLD_END__NEW_END +[_____________________|oooooooooooooo|wwwwwwww|_] = r.buf + |<------>| + |r.length| + | + r.offset + + - or Y zone can contain [write_len], + _________NEW_END____START_________OLD_END______ +[wwwwwwwwwwww|________|oooooooooooooo|__________] = r.buf +|<-r.length->| +| +r.offset=0 + + - or neither is big enough,we create a temporary buffer of size [write_len] + ___________________START___________END_________ |<---max_len---->| +[_____________________|oooooooooooooo|__________] [wwwwwwwwwwww____]= r.buf + |<-r.length->| + | + r.offset=0 +- END preceeds START , + ______END____________________START______ +[ooooooo|_______________________|oooooo__] + + - either empty zone can contain [write_len] and a little bit more, + _____OLD__END______NEW_END___START______ +[ooooooo|wwwwwwwwwwwwwwww|______|oooooo__] + |<------>| + |r.length| + | + r.offset + - either empty zone can contain [write_len], + _____OLD__END___________NEW_END_START___ +[ooooooo|wwwwwwwwwwwwwwwwwwwwwww|oooooo__] + |<------>| + |r.length| + | + r.offset + t.full = true + + - or we create a temporary buffer of size [max_len] + ______END____________________START______ |<--------max_len----------->| +[ooooooo|_______________________|oooooo__] [wwwwwwwwwwwwwwwwwwwwwwww____] + |<-------r.length----------->| + | + r.offset=0 + *) +let write ~maxlen ~fill_using t = + if maxlen < 0 then invalid_arg "Circular_buffer.write: negative length." ; + if maxlen = 0 then + Lwt.return {offset = t.data_end; length = 0; buf = t.buffer} + else + let (buf, offset) = get_buf_with_offset t maxlen in + let maxlen = + if buf == t.buffer then maxlen else min t.fresh_buf_size maxlen + in + fill_using buf offset maxlen + >>= fun written -> + if written > maxlen then + invalid_arg "Circular_buffer.write: written more bytes than maxlen" ; + if t.buffer == buf then ( + t.data_end <- written + offset ; + if t.data_end = t.data_start then t.full <- true ) ; + Lwt.return {offset; length = written; buf} + +(* [read data ?len t ~into ~offset] will read [len] data from + [data.buf] and update [t.data_start] pointer accordingly. + data are blit into buffer [into] at [offset]. + +if data.buf is not the circular buffer, it is supposed to be a +dedicated buffer allocated at write time and we have no bookkeeping +to do on the circular buffer. + +Else starting from + + ______START____________END_____ +[________|ddddd|ddddddddd|______] [dddddddddddddddddddddddd____] + |<--->|<------->| |<---------------------->| + d1 d3 d2 +It is required to read fully d1, d2, and then d3 in that order. + +We can have a parial read for each chunk leading to a new data chunk d1' + _________START_________END_____ +[___________|dd|ddddddddd|______] [dddddddddddddddddddddddd____] + |<>|<------->| |<---------------------->| + d1' d3 d2 +but the remainder has to be consumed to ensure that further readings + will succeed. + ____________START______END_____ +[______________|ddddddddd|______] [dddddddddddddddddddddddd____] + |<------->| |<---------------------->| + d3 d2 +When reading extra allocated chunk we don't have to do any bookkeeping + ____________START______END_____ +[______________|ddddddddd|______] [___________|dddddddddddd____] + |<------->| |<---------->| + d3 d2' + +Each time we read a chunk in the circular buffer we move start at the +end of chunk we just read. + +Most of the time START points to the begining of the next chunk to +read, but in one case starting from this situation (where d2 + was to big to fit after d1) + + _______END____START____ +[dddd|dddd|_____|dddd|__] +| d2 | d3 | | d1 | + +reading d1 then d2 leads to + + _______END___________START +[dddd|dddd|_____________|__] + +Thats why we do + t.data_start <- data.offset + len ; +and not + t.data_start <- t.data_start + len ; + +An alternative would be to remember that the last bytes of the buffer +where not used, and to check whether start should be set at the +begining of the buffer at each read. + + *) + +let read data ?(len = data.length) t ~into ~offset = + if len > data.length then + invalid_arg "Circular_buffer.read: len > (length data)." ; + if len < 0 then invalid_arg "Circular_buffer.read: negative length." ; + if len = 0 && data.length = 0 then None + else if len = 0 then Some data + else ( + (* copying data *) + Bytes.blit data.buf data.offset into offset len ; + (* updating data_start pointer *) + if data.buf == t.buffer then ( + t.full <- false ; + t.data_start <- data.offset + len ; + (* + In the buffer, data is always contiguous (in particular it is not + splitted when reaching the end: we just leave unused space at + the end and write at the beginning). + If [data] is well formed, it is the result of a write into the + buffer, and [len] is at most the length of data, so we have + previously written [len] data in [t.buffer] starting at + [offset]. So the following assertion must hold. *) + assert (t.data_start <= Bytes.length t.buffer) ) ; + (* computing remainder *) + if len = data.length then None + else + (* Return a new handler if we did not read the whole chunck *) + Some + { + offset = data.offset + len; + length = data.length - len; + buf = data.buf; + } ) + +let length {length; _} = length diff --git a/src/lib_stdlib/circular_buffer.mli b/src/lib_stdlib/circular_buffer.mli new file mode 100644 index 0000000000000000000000000000000000000000..9010a8ac1e71005533fdc62246a2c697a9bc6eba --- /dev/null +++ b/src/lib_stdlib/circular_buffer.mli @@ -0,0 +1,78 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** This module implements a bufferisation abstraction to store + temporary raw data chunks (as bytes) when chunks are read + sequentially. The function write allows to store chunks in the + buffer and the function read to read them from the buffer. + + The global contract is that if we write consecutively [d1;d2] onto + the buffer. Then we have to fully read d1 and d2, in that order. + + This contract is not enforced by the library, it is the user + responsability to respect it. + + If the circular buffer is full, a new temporary buffer is + allocated to store the chunk of data to be written. *) + +(** Type of circular buffers *) +type t + +(** An abstraction over a chunk of data written in the buffer. *) +type data + +(** Create a buffer of size maxlength. If the buffer is full, a buffer + of size [fresh_buf_size] is allocated (by default `2` kb). *) +val create : ?maxlength:int -> ?fresh_buf_size:int -> unit -> t + +(** [write ~maxlen ~fill_using:f buffer] calls [fill_using buf offset + maxlen] where [buf] is a buffer that has room for [maxlen] data + starting from [offset]. + + Assumes that [fill_using] returns the exact amount of written + bytes. + + Behaviour is unspecified if [fill_using] writes more than [maxlen] + data or lies on the number of written bytes. + + It returns a data descriptor for the supposedly written chunk. *) +val write : + maxlen:int -> + fill_using:(Bytes.t -> int -> int -> int Lwt.t) -> + t -> + data Lwt.t + +(** [read data ~len ~into:buf buffer ~offset] blit [len] data from the [data] chunk. + If [len] is not provided, blit all the data. + If [len] is less than the amount of data available, it returns a + new handler the the remainder. + + Assumes that data has been produce by a write attempt in [buffer]. + Assumes that ~len is lesser than [length data]. +*) +val read : data -> ?len:int -> t -> into:Bytes.t -> offset:int -> data option + +(** [length data] returns the amount of avalaible bytes in [data] *) +val length : data -> int diff --git a/src/lib_stdlib/test/dune b/src/lib_stdlib/test/dune index f45d19b1f0858327c490c6e62242d9b8259255dd..08640a1f5d2e283ff9f554b679fc1a4b07e37947 100644 --- a/src/lib_stdlib/test/dune +++ b/src/lib_stdlib/test/dune @@ -1,13 +1,16 @@ (executables (names test_tzList test_tzString - test_lwt_pipe) + test_lwt_pipe + test_circular_buffer + test_circular_buffer_fuzzy) (libraries tezos-stdlib alcotest alcotest-lwt lwt_log bigstring - lwt.unix) + lwt.unix + crowbar) (flags (:standard -open Tezos_stdlib))) (rule @@ -29,12 +32,22 @@ (alias runtest_lwt_pipe) (action (run %{exe:test_lwt_pipe.exe}))) +(rule + (alias runtest_circular_buffer) + (action (run %{exe:test_circular_buffer.exe}))) + +(rule + (alias runtest_circular_buffer_fuzzy) + (action (run %{exe:test_circular_buffer_fuzzy.exe}))) + (rule (alias runtest) (package tezos-stdlib) (deps (alias runtest_tzList) (alias runtest_tzString) - (alias runtest_lwt_pipe)) + (alias runtest_lwt_pipe) + (alias runtest_circular_buffer) + (alias runtest_circular_buffer_fuzzy)) (action (progn))) (rule diff --git a/src/lib_stdlib/test/test_circular_buffer.ml b/src/lib_stdlib/test/test_circular_buffer.ml new file mode 100644 index 0000000000000000000000000000000000000000..5b76777ad22916a2d7f28fadcf3cae31a296572a --- /dev/null +++ b/src/lib_stdlib/test/test_circular_buffer.ml @@ -0,0 +1,414 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: stdlib + Invocation: dune build @src/lib_stdlib/test/runtest_circular_buffer + Subject: On circular buffer +*) + +open Lwt +module Buff = Circular_buffer + +let buffer_size = ref (1 lsl 14) + +let random_bytes size = + let buff = Bytes.create size in + let rec fill_random size offset buff = + let data = Random.int64 Int64.max_int in + if size < 8 then + for i = 0 to size - 1 do + Bytes.set_int8 + buff + (offset + i) + (Int64.to_int (Int64.shift_right data i)) + done + else ( + Bytes.set_int64_ne buff offset data ; + fill_random (size - 8) (offset + 8) buff ) + in + fill_random size 0 buff ; buff + +(** Tests with constant size allocation requests *) +module Constant = struct + (**{1} Helpers functions *) + + (** Writes [chunks_count] chunks into the [circular_buffer] and + returns an array with the returned [data] witnesses. + Data for chunk [i] are copied from the chunk in [seed_chunks] at + position [i] modulo the array size. + + Assumes that [seed_chunks] are bigger than [chunks_size] + *) + let fill_full seed_chunks circular_buffer chunks_size chunks_count = + let seed_count = Array.length seed_chunks in + let data_store = + Array.init chunks_count (fun i -> + Buff.write + ~maxlen:chunks_size + ~fill_using:(fun buff off maxlen -> + Bytes.blit seed_chunks.(i mod seed_count) 0 buff off maxlen ; + Lwt.return maxlen) + circular_buffer) + in + data_store + + (** Same as [fill_full] but a only a random count of bytes are + copied into the circular buffer, not the whole required size. *) + let fill_partial seed_chunks circular_buffer chunks_size chunks_count = + let seed_count = Array.length seed_chunks in + let data_store = + Array.init chunks_count (fun i -> + Buff.write + ~maxlen:chunks_size + ~fill_using:(fun buff off maxlen -> + let length = Random.int maxlen in + Bytes.blit seed_chunks.(i mod seed_count) 0 buff off length ; + Lwt.return length) + circular_buffer) + in + data_store + + (** Reads each data chunk in one shot, and assert that they match + the chunk at the expected position in seed_chunks. + *) + let read_all seed_chunks circular_buffer chunks_size data_store = + let seed_count = Array.length seed_chunks in + let buff = random_bytes chunks_size in + Array.iteri + (fun i data -> + ignore + ( data + >>= fun data -> + let _ = Buff.read data circular_buffer ~into:buff ~offset:0 in + assert ( + Bytes.sub buff 0 (Buff.length data) + = Bytes.sub seed_chunks.(i mod seed_count) 0 (Buff.length data) ) ; + Lwt.return_unit )) + data_store + + (** Reads each data chunk fragement by fragment (10 fragments max, + each of random size), and assert that they match + the chunk at the expected position in seed_chunks. + *) + let read_by_chunk seed_chunks circular_buffer chunks_size data_store = + let seed_count = Array.length seed_chunks in + let buff = random_bytes chunks_size in + Array.iter + (fun (i, data) -> + ignore + ( data + >>= fun data -> + let max_iter = 10 in + let rec exhaust data offset iter = + let length = Buff.length data in + let len = + if iter > max_iter then length + else try Random.int length with _ -> length + (* length might be 0 *) + in + let remainder = + Buff.read ~len data circular_buffer ~into:buff ~offset + in + let offset = offset + len in + match remainder with + | None -> + offset + | Some remainder -> + exhaust remainder offset (iter + 1) + in + let read_length = exhaust data 0 0 in + assert (read_length = Buff.length data) ; + assert ( + Bytes.sub buff 0 (Buff.length data) + = Bytes.sub seed_chunks.(i mod seed_count) 0 (Buff.length data) ) ; + Lwt.return_unit )) + data_store + + (**{1} Tests *) + + (** [run ~buffer_size ~chunk_size ~chunks_count ~iter] fills the + buffer with ~chunks_count then read all the chunks and check that + it retrieved the right data. + + Data are randoms bits. *) + let run ~buffer_size ~chunks_size ~chunks_count ~iter () = + let seed_count = 20 in + let seed_chunks = + Array.init seed_count (fun _ -> random_bytes chunks_size) + in + let circular_buffer = Buff.create ~maxlength:buffer_size () in + for _i = 0 to iter do + Format.eprintf "iteration %d@." _i ; + read_all + seed_chunks + circular_buffer + chunks_size + (fill_full seed_chunks circular_buffer chunks_size chunks_count) + done ; + return_unit + + (** [run ~buffer_size ~chunk_size ~chunks_count ~iter] fills the + buffer with ~chunks_count. The writing function does not always + write ~chunk_size bytes. Then all the chunks are fully read and + checked to be the same as written data. + + Data are randoms bits. *) + let run_partial_write ~buffer_size ~chunks_size ~chunks_count ~iter () = + let seed_count = 20 in + let seed_chunks = + Array.init seed_count (fun _ -> random_bytes chunks_size) + in + let circular_buffer = Buff.create ~maxlength:buffer_size () in + for _i = 0 to iter do + Format.eprintf "iteration %d@." _i ; + read_all + seed_chunks + circular_buffer + chunks_size + (fill_partial seed_chunks circular_buffer chunks_size chunks_count) + done ; + return_unit + + (** [run ~buffer_size ~chunk_size ~chunks_count ~iter] fills the + buffer with ~chunks_count. The writing function does not always + write ~chunk_size bytes. Then all the chunks are read by smaller + chunk until exhaustion and checked to be the same as written + data. + + Data are randoms bits. *) + let run_partial_read_writes ~buffer_size ~chunks_size ~chunks_count ~iter () + = + let seed_count = 20 in + let seed_chunks = + Array.init seed_count (fun _ -> random_bytes chunks_size) + in + let circular_buffer = Buff.create ~maxlength:buffer_size () in + for _i = 0 to iter do + Format.eprintf "iteration %d@." _i ; + read_by_chunk + seed_chunks + circular_buffer + chunks_size + (Array.mapi + (fun i d -> (i, d)) + (fill_partial seed_chunks circular_buffer chunks_size chunks_count)) + done ; + return_unit + + (** [run_partial_read_writes_interleaving ~buffer_size ~chunk_size + ~chunks_count ~iter] interleaves writes of chunks_count chunks + and and reads (by chunks) of a subsets of already written data. + The writing function does not always write ~chunk_size bytes. + The chunks are read by smaller chunk until exhaustion + and checked to be the same as written data. + + Data are randoms bits. *) + let run_partial_read_writes_interleaving ~buffer_size ~chunks_size + ~chunks_count ~iter () = + let seed_count = 20 in + let seed_chunks = + Array.init seed_count (fun _ -> random_bytes chunks_size) + in + let circular_buffer = Buff.create ~maxlength:buffer_size () in + let data_store = + Array.mapi + (fun i d -> (i, d)) + (fill_partial seed_chunks circular_buffer chunks_size chunks_count) + in + let rec loop iter data_store = + if iter <= 0 then () + else ( + Format.eprintf "iteration %d@." iter ; + let length = Array.length data_store in + let to_read = Random.int length in + read_by_chunk + seed_chunks + circular_buffer + chunks_size + (Array.sub data_store 0 to_read) ; + loop + (iter - 1) + (Array.append + (Array.sub data_store to_read (length - to_read)) + (Array.mapi + (fun i d -> (i, d)) + (fill_partial + seed_chunks + circular_buffer + chunks_size + chunks_count))) ) + in + loop iter data_store ; return_unit +end + +module Fail_Test = struct + (** Expected fail on write. *) + let write_invalid ~max_buffer_len ~max_data_size ~actual_data_size = + let circular_buffer = Buff.create ~maxlength:max_buffer_len () in + let tmp_buff = Bytes.create (max max_data_size actual_data_size) in + Lwt.catch + (fun () -> + Buff.write + ~maxlen:max_data_size + ~fill_using:(fun buff off _maxlen -> + Bytes.blit tmp_buff 0 buff off actual_data_size ; + Lwt.return actual_data_size) + circular_buffer + >>= fun _data -> assert false) + (function Invalid_argument _ -> Lwt.return_unit | exn -> raise exn) + + (** Fail read too long. *) + let read_invalid ~max_buffer_len ~max_data_size ~actual_data_size = + let circular_buffer = Buff.create ~maxlength:max_buffer_len () in + let tmp_buff = Bytes.create (max max_data_size actual_data_size) in + Buff.write + ~maxlen:max_data_size + ~fill_using:(fun buff off _maxlen -> + Bytes.blit tmp_buff 0 buff off actual_data_size ; + Lwt.return actual_data_size) + circular_buffer + >>= fun data -> + try + let _ = + Buff.read + data + ~len:(actual_data_size + 1) + circular_buffer + ~into:tmp_buff + ~offset:0 + in + assert false + with Invalid_argument _ -> Lwt.return_unit + + let run_write_too_long_in_buffer () = + write_invalid ~max_buffer_len:10 ~max_data_size:5 ~actual_data_size:6 + + let run_write_too_long_extra_alloc () = + write_invalid ~max_buffer_len:4 ~max_data_size:5 ~actual_data_size:6 + + let run_read_too_long_in_buffer () = + read_invalid ~max_buffer_len:10 ~max_data_size:10 ~actual_data_size:5 + >>= fun () -> + read_invalid ~max_buffer_len:10 ~max_data_size:0 ~actual_data_size:0 + + let run_read_too_long_extra_alloc () = + read_invalid ~max_buffer_len:4 ~max_data_size:10 ~actual_data_size:5 + >>= fun () -> + read_invalid ~max_buffer_len:4 ~max_data_size:0 ~actual_data_size:0 +end + +let spec = + Arg.[("--buffer-size", Set_int buffer_size, " Size of the read buffers")] + +let () = + let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in + let usage_msg = "Usage: %s .\nArguments are:" in + Arg.parse spec anon_fun usage_msg + +let wrap n f = + Alcotest.test_case n `Quick (fun () -> + match + Lwt_main.run + (Lwt.catch + (fun () -> f () >>= fun x -> Lwt.return @@ `Ok x) + (fun exn -> Lwt.return @@ `Exn exn)) + with + | `Ok _ -> + () + | `Exn exn -> + raise exn) + +let () = + Alcotest.run + ~argv:[|""|] + "tezos-stdlib" + ( List.map + (fun (run, descr) -> + ( "circular_buffer.constant-chunks." ^ descr, + [ wrap "bad-fit" (fun () -> + let buffer_size = !buffer_size in + let chunks_size = (buffer_size / 13) + 1 in + let chunks_count = buffer_size / chunks_size in + run ~buffer_size ~chunks_size ~chunks_count ~iter:15 ()); + wrap "bad-fit-underflow" (fun () -> + let buffer_size = !buffer_size in + let chunks_size = (buffer_size / 13) + 1 in + let chunks_count = (buffer_size / chunks_size) - 1 in + run + ~buffer_size + ~chunks_size + ~chunks_count + ~iter:(chunks_count + 2) + ()); + wrap "bad-fit-overflow" (fun () -> + let buffer_size = !buffer_size in + let chunks_size = (buffer_size / 13) + 1 in + let chunks_count = (buffer_size / chunks_size) + 3 in + run ~buffer_size ~chunks_size ~chunks_count ~iter:15 ()); + wrap "perfect-fit" (fun () -> + let buffer_size = !buffer_size in + let chunks_size = buffer_size / (buffer_size lsr 3) in + let chunks_count = buffer_size / chunks_size in + run ~buffer_size ~chunks_size ~chunks_count ~iter:2 ()); + wrap "perfect-fit-underflow" (fun () -> + let buffer_size = !buffer_size in + let chunks_size = buffer_size / (buffer_size lsr 3) in + let chunks_count = (buffer_size / chunks_size) - 1 in + run + ~buffer_size + ~chunks_size + ~chunks_count + ~iter:(chunks_count + 2) + ()); + wrap "perfect-fit-overflow" (fun () -> + let buffer_size = !buffer_size in + let chunks_size = buffer_size / (buffer_size lsr 3) in + let chunks_count = (buffer_size / chunks_size) + 2 in + run + ~buffer_size + ~chunks_size + ~chunks_count + ~iter:((1 lsl 3) + 1) + ()) ] )) + [ (Constant.run, "full"); + (Constant.run_partial_write, "partial-write"); + (Constant.run_partial_read_writes, "partial-read-write"); + ( Constant.run_partial_read_writes_interleaving, + "partial-read-write-interleaving" ) ] + @ [ ( "circular_buffer.fail_cases", + [ wrap + "Write_too_long-in_buffer" + Fail_Test.run_write_too_long_in_buffer; + wrap + "Write_too_long-extra_allocated_buffer" + Fail_Test.run_write_too_long_extra_alloc; + wrap + "Read_too_long-in_buffer" + Fail_Test.run_read_too_long_in_buffer; + wrap + "Read_too_long-extra_allocated_buffer" + Fail_Test.run_read_too_long_extra_alloc ] ) ] ) diff --git a/src/lib_stdlib/test/test_circular_buffer_fuzzy.ml b/src/lib_stdlib/test/test_circular_buffer_fuzzy.ml new file mode 100644 index 0000000000000000000000000000000000000000..2c61c80fa879a4a2605835ff3bb1f1f77e25fcd6 --- /dev/null +++ b/src/lib_stdlib/test/test_circular_buffer_fuzzy.ml @@ -0,0 +1,323 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: stdlib + Invocation: dune build @src/lib_stdlib/test/runtest_circular_buffer_fuzzy + Subject: Test the circular buffer with a reference implementation + *) + +(* This test implement a fuzzy testing where we check that the + `circular_buffer` behaves similarly than a reference implementation + of the same interface. *) + +open Lwt.Infix + +module type S = sig + type t + + type data + + val create : ?maxlength:int -> ?fresh_buf_size:int -> unit -> t + + (* Write the output of [fill_using] in [data]. *) + val write : + maxlen:int -> + fill_using:(Bytes.t -> int -> int -> int Lwt.t) -> + t -> + data Lwt.t + + (* Read the value of [data]. The read may be partial if the [data] + is not fully read. We return the [data] part which was not + read. *) + val read : data -> ?len:int -> t -> into:Bytes.t -> offset:int -> data option + + val length : data -> int +end + +module Reference : S = struct + (* There is not buffer, hence the type [t] is not necessary. For + each [data] we create a new buffer. *) + type t = unit + + type data = Bytes.t + + let create ?maxlength:_ ?fresh_buf_size:_ () = () + + let write ~maxlen ~fill_using () = + let bytes = Bytes.create maxlen in + fill_using bytes 0 maxlen + >>= fun written_bytes -> Lwt.return (Bytes.sub bytes 0 written_bytes) + + let read data ?(len = Bytes.length data) () ~into ~offset = + let data_length = Bytes.length data in + if len > data_length then + raise (Invalid_argument "Circular_buffer.read: len > (length data).") ; + Bytes.blit data 0 into offset len ; + if len = data_length then None + else Some (Bytes.sub data len (data_length - len)) + + let length = Bytes.length +end + +(* Check that the circular buffer as the expected interface *) +module Circular_buffer : S = Circular_buffer + +(* A scenario will be generate as a sequence of write/read such that + at each moment, there is more writes than reads. Details are made + precise in the [pp_op] function below. *) +type op = Write of int * int | Read of int + +let pp_op fmt = function + | Write (write_len, len) -> + Format.fprintf + fmt + "Write %d bytes into a buffer of maxlen %d bytes." + (min write_len len) + len + | Read read_len -> + (* if [read_len] is too long, we may truncate to the correct size + depending on the test (see below). *) + Format.fprintf fmt "Read at most %d bytes." read_len + +let pp = Format.pp_print_list ~pp_sep:Format.pp_print_newline pp_op + +let write_op = + let open Crowbar in + map [uint8; uint8] (fun write_len len -> Write (write_len, len)) + +let op = + let open Crowbar in + map [bool; uint8; uint8] (fun b len write_len -> + if b then Write (write_len, len) else Read len) + +(* We bypass the [Crowbar.fix] operator to generate longer lists. We + record the number of writes to ensure the invariant [nb_writes > + nb_reads]. *) +let rec ops_gen (acc : (int * op list) Crowbar.gen) i = + if i = 0 then acc + else + ops_gen + (Crowbar.dynamic_bind acc (fun (nb_writes, ops) -> + let gen = if nb_writes > 0 then op else write_op in + Crowbar.map [gen] (fun op -> + let delta = match op with Write _ -> 1 | Read _ -> -1 in + (nb_writes + delta, op :: ops)))) + (i - 1) + +(* Scenarios start with a write operation. *) +let ops_gen size = + let gen = ops_gen (Crowbar.map [write_op] (fun v -> (1, [v]))) size in + Crowbar.map [gen] (fun (_, ops) -> ops) + +let values = + let open Crowbar in + (* 1000 is a good trade-off between: + - testing long scenarii using a long sequence of operations + - quick execution + *) + let size_gen = range ~min:0 1000 in + dynamic_bind size_gen (fun size -> ops_gen size) + +let values = Crowbar.with_printer pp values + +(* To generate random bytes in a buffer. *) +let random_bytes = + let state = Random.State.make_self_init () in + fun size -> + let buff = Bytes.create size in + let rec fill_random size offset buff = + let data = Random.State.int64 state Int64.max_int in + if size < 8 then + for i = 0 to size - 1 do + Bytes.set_int8 + buff + (offset + i) + (Int64.to_int (Int64.shift_right data i)) + done + else ( + Bytes.set_int64_ne buff offset data ; + fill_random (size - 8) (offset + 8) buff ) + in + fill_random size 0 buff ; buff + +let pp_buf fmt buf = + Format.fprintf fmt "Length: %d@." (Bytes.length buf) ; + Bytes.iter (fun c -> Format.fprintf fmt "%02x" (Char.code c)) buf + +type state = + | E : { + implementation : (module S with type t = 'a and type data = 'b); + internal_state : 'a; + data_to_be_read : 'b Queue.t; + mutable partial_read : 'b option; + } + -> state + +let () = + (* The module Circular buffer should have the same semantics as the + reference implementation given in the Reference module. We use + crowbar to generate write and reads, then check that both + implementations send the same result. *) + let fill_using write_len fresh_bytes bytes offset maxlen = + let len = min write_len maxlen in + Bytes.blit fresh_bytes 0 bytes offset len ; + Lwt.return len + in + let write_data write_len maxlen bytes_to_write (E state) = + let (module M) = state.implementation in + M.write + ~maxlen + ~fill_using:(fill_using write_len bytes_to_write) + state.internal_state + >>= fun data -> + Queue.add data state.data_to_be_read ; + Lwt.return_unit + in + let read_data ~without_invalid_argument read_len (E state) = + let (module M) = state.implementation in + let data_to_read = + match state.partial_read with + | None -> + Queue.take state.data_to_be_read + | Some p -> + state.partial_read <- None ; + p + in + let len = + (* to avoid the invalid_argument we take the minimum between the + size of the data to read and the one generated by the + [Crowbar] generator. *) + if without_invalid_argument then min (M.length data_to_read) read_len + else read_len + in + let buf = Bytes.create len in + try + state.partial_read <- + M.read data_to_read ~len state.internal_state ~into:buf ~offset:0 ; + (false, buf) + with Invalid_argument _ -> (true, Bytes.create 0) + in + let update_state ?(without_invalid_argument = false) left_state right_state + value = + match value with + | Write (write_len, maxlen) -> + let len = min write_len maxlen in + let bytes_to_write = random_bytes len in + write_data write_len maxlen bytes_to_write left_state + >>= fun () -> + write_data write_len maxlen bytes_to_write right_state + >>= fun () -> Lwt.return_false + | Read read_len -> ( + try + let (left_has_raised, left_buf) = + read_data ~without_invalid_argument read_len left_state + in + let (right_has_raised, right_buf) = + read_data ~without_invalid_argument read_len right_state + in + if left_has_raised then + if right_has_raised then Lwt.return true + else Crowbar.fail "Different behaviors (invalid_argument)" + else ( + Crowbar.check_eq ~pp:pp_buf left_buf right_buf ; + Lwt.return false ) + with Queue.Empty -> Crowbar.guard false ; Lwt.return_false ) + in + Crowbar.add_test + ~name: + "Stdlib.circular_bufer.equivalence-with-reference-implementation-without-invalid-argument" + [values] + (fun ops -> + (* To ensure that the number of [write] is greater than the + number of [read] we reverse the list. *) + let ops = List.rev ops in + let left_state = + E + { + implementation = (module Circular_buffer); + internal_state = Circular_buffer.create ~maxlength:(1 lsl 10) (); + data_to_be_read = Queue.create (); + partial_read = None; + } + in + let right_state = + E + { + implementation = (module Reference); + internal_state = Reference.create ~maxlength:(1 lsl 10) (); + data_to_be_read = Queue.create (); + partial_read = None; + } + in + Lwt_main.run + (Lwt_list.iter_s + (fun value -> + update_state + ~without_invalid_argument:true + left_state + right_state + value + >>= fun _ -> Lwt.return_unit) + ops)) ; + (* The test below do not try to avoid the `invalid_argument` + exception. It checks that both implementations raise this + exception at the same time. *) + Crowbar.add_test + ~name:"Stdlib.circular_bufer.equivalence-with-reference-implementation" + [values] + (fun ops -> + let ops = List.rev ops in + let left_state = + E + { + implementation = (module Circular_buffer); + internal_state = Circular_buffer.create (); + data_to_be_read = Queue.create (); + partial_read = None; + } + in + let right_state = + E + { + implementation = (module Reference); + internal_state = Reference.create (); + data_to_be_read = Queue.create (); + partial_read = None; + } + in + let _ = + Lwt_main.run + (Lwt_list.fold_left_s + (fun raised value -> + if raised then Lwt.return raised + else + update_state left_state right_state value + >>= fun raised' -> Lwt.return (raised || raised')) + false + ops) + in + ()) diff --git a/src/lib_stdlib/tezos-stdlib.opam b/src/lib_stdlib/tezos-stdlib.opam index b56cda643fe17b154da68be1caf72d75a8dafc24..10da1b831cb27f50d54bb5ce422bfade20c1e2b3 100644 --- a/src/lib_stdlib/tezos-stdlib.opam +++ b/src/lib_stdlib/tezos-stdlib.opam @@ -16,6 +16,7 @@ depends: [ "lwt_log" { with-test } "alcotest" { with-test & >= "1.1.0" } "alcotest-lwt" { with-test & >= "1.1.0" } + "crowbar" { with-test } ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/lib_storage/tezos-storage.opam b/src/lib_storage/tezos-storage.opam index b7fa94c07519054d1f8e73c4181f9dd1a9886bd9..28852eb666e23511878423b4e4cdb4121bea2ba3 100644 --- a/src/lib_storage/tezos-storage.opam +++ b/src/lib_storage/tezos-storage.opam @@ -10,7 +10,7 @@ depends: [ "dune" { >= "2.0" } "tezos-base" "tezos-lmdb" - "irmin" { >= "2.2.0" } + "irmin" { >= "2.2.0" & < "2.3.0" } "irmin-pack" "digestif" {>= "0.7.3"} "tezos-shell-services" diff --git a/src/lib_version/version.ml b/src/lib_version/version.ml index 69b9951c7399876a05528817064ff54226ec8781..48bb39842dcb0d705785d58740df1b01512ebad7 100644 --- a/src/lib_version/version.ml +++ b/src/lib_version/version.ml @@ -42,6 +42,6 @@ let to_string {major; minor; additional_info} = string_of_int major ^ "." ^ string_of_int minor ^ string_of_additional_info additional_info -let current = {major = 8; minor = 0; additional_info = Dev} +let current = {major = 8; minor = 2; additional_info = Release} let current_string = to_string current diff --git a/src/proto_000_Ps9mPmXa/lib_protocol/dune.inc b/src/proto_000_Ps9mPmXa/lib_protocol/dune.inc index 94ab311515ef8927604c4ecf8344ffbebdc8ccf8..c33ec8920d9ed0b9c702611730b7829dc750fc5c 100644 --- a/src/proto_000_Ps9mPmXa/lib_protocol/dune.inc +++ b/src/proto_000_Ps9mPmXa/lib_protocol/dune.inc @@ -66,7 +66,7 @@ include Tezos_raw_protocol_000_Ps9mPmXa.Main (libraries tezos_protocol_environment_000_Ps9mPmXa) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_000_Ps9mPmXa__Environment -open Pervasives @@ -88,19 +88,19 @@ include Tezos_raw_protocol_000_Ps9mPmXa.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_000_Ps9mPmXa) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_000_Ps9mPmXa_functor) - (public_name tezos-protocol-000-Ps9mPmXa.functor) + (public_name tezos-protocol-functor-000-Ps9mPmXa) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_000_Ps9mPmXa) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-000-Ps9mPmXa.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -112,7 +112,7 @@ include Tezos_raw_protocol_000_Ps9mPmXa.Main (libraries tezos-protocol-000-Ps9mPmXa tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_000_Ps9mPmXa/lib_protocol/tezos-protocol-functor-000-Ps9mPmXa.opam b/src/proto_000_Ps9mPmXa/lib_protocol/tezos-protocol-functor-000-Ps9mPmXa.opam new file mode 100644 index 0000000000000000000000000000000000000000..b7f477d503fdba02beebae3f60bb4c68d2392f5f --- /dev/null +++ b/src/proto_000_Ps9mPmXa/lib_protocol/tezos-protocol-functor-000-Ps9mPmXa.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-000-Ps9mPmXa" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "000_Ps9mPmXa" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: 000-Ps9mPmXa (economic-protocol definition parameterized by its environment implementation)" diff --git a/src/proto_001_PtCJ7pwo/lib_protocol/dune.inc b/src/proto_001_PtCJ7pwo/lib_protocol/dune.inc index 200b9d0cf51ff744a51bb91be46e2cd542116148..6da82fe40dd1fe662468c1e1cc2d8a96b833bc27 100644 --- a/src/proto_001_PtCJ7pwo/lib_protocol/dune.inc +++ b/src/proto_001_PtCJ7pwo/lib_protocol/dune.inc @@ -258,7 +258,7 @@ include Tezos_raw_protocol_001_PtCJ7pwo.Main (libraries tezos_protocol_environment_001_PtCJ7pwo) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_001_PtCJ7pwo__Environment -open Pervasives @@ -344,19 +344,19 @@ include Tezos_raw_protocol_001_PtCJ7pwo.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_001_PtCJ7pwo) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_001_PtCJ7pwo_functor) - (public_name tezos-protocol-001-PtCJ7pwo.functor) + (public_name tezos-protocol-functor-001-PtCJ7pwo) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_001_PtCJ7pwo) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-001-PtCJ7pwo.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -368,7 +368,7 @@ include Tezos_raw_protocol_001_PtCJ7pwo.Main (libraries tezos-protocol-001-PtCJ7pwo tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_001_PtCJ7pwo/lib_protocol/tezos-embedded-protocol-001-PtCJ7pwo.opam b/src/proto_001_PtCJ7pwo/lib_protocol/tezos-embedded-protocol-001-PtCJ7pwo.opam index e9b5fbe032e27bb9cef493ce230bd98aca9c8183..76e5925cbb0e41f2741ce79d2b2fb110c3c25c1a 100644 --- a/src/proto_001_PtCJ7pwo/lib_protocol/tezos-embedded-protocol-001-PtCJ7pwo.opam +++ b/src/proto_001_PtCJ7pwo/lib_protocol/tezos-embedded-protocol-001-PtCJ7pwo.opam @@ -7,7 +7,6 @@ dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-001-PtCJ7pwo" "tezos-protocol-compiler" "tezos-protocol-updater" diff --git a/src/proto_001_PtCJ7pwo/lib_protocol/tezos-protocol-001-PtCJ7pwo.opam b/src/proto_001_PtCJ7pwo/lib_protocol/tezos-protocol-001-PtCJ7pwo.opam index 30736ea1fac2d3a662c1d67534dccfdc8f0baab3..ce8b5a85ac5ea88b5efe2fbcdce7cea435e420b1 100644 --- a/src/proto_001_PtCJ7pwo/lib_protocol/tezos-protocol-001-PtCJ7pwo.opam +++ b/src/proto_001_PtCJ7pwo/lib_protocol/tezos-protocol-001-PtCJ7pwo.opam @@ -7,7 +7,6 @@ dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" "alcotest-lwt" { with-test & >= "1.1.0" } "tezos-stdlib-unix" { with-test } diff --git a/src/proto_001_PtCJ7pwo/lib_protocol/tezos-protocol-functor-001-PtCJ7pwo.opam b/src/proto_001_PtCJ7pwo/lib_protocol/tezos-protocol-functor-001-PtCJ7pwo.opam new file mode 100644 index 0000000000000000000000000000000000000000..210e1d736d47548467611cffce712d94de86345c --- /dev/null +++ b/src/proto_001_PtCJ7pwo/lib_protocol/tezos-protocol-functor-001-PtCJ7pwo.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-001-PtCJ7pwo" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "001_PtCJ7pwo" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: 001_PtCJ7pwo (economic-protocol definition parameterized by its environment implementation)" diff --git a/src/proto_002_PsYLVpVv/lib_protocol/dune.inc b/src/proto_002_PsYLVpVv/lib_protocol/dune.inc index 7f756a659b3aa29522ab95f3ec75c1050b093093..7ee590d3572d23d10062849b44d488581e420cf1 100644 --- a/src/proto_002_PsYLVpVv/lib_protocol/dune.inc +++ b/src/proto_002_PsYLVpVv/lib_protocol/dune.inc @@ -258,7 +258,7 @@ include Tezos_raw_protocol_002_PsYLVpVv.Main (libraries tezos_protocol_environment_002_PsYLVpVv) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_002_PsYLVpVv__Environment -open Pervasives @@ -344,19 +344,19 @@ include Tezos_raw_protocol_002_PsYLVpVv.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_002_PsYLVpVv) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_002_PsYLVpVv_functor) - (public_name tezos-protocol-002-PsYLVpVv.functor) + (public_name tezos-protocol-functor-002-PsYLVpVv) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_002_PsYLVpVv) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-002-PsYLVpVv.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -368,7 +368,7 @@ include Tezos_raw_protocol_002_PsYLVpVv.Main (libraries tezos-protocol-002-PsYLVpVv tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_002_PsYLVpVv/lib_protocol/tezos-embedded-protocol-002-PsYLVpVv.opam b/src/proto_002_PsYLVpVv/lib_protocol/tezos-embedded-protocol-002-PsYLVpVv.opam index 31a413afeb19ef033c639c3e1284ff4df51e137b..d6b0a8f13de1fc5bd7d9dbf091cc43e4cda76cae 100644 --- a/src/proto_002_PsYLVpVv/lib_protocol/tezos-embedded-protocol-002-PsYLVpVv.opam +++ b/src/proto_002_PsYLVpVv/lib_protocol/tezos-embedded-protocol-002-PsYLVpVv.opam @@ -7,7 +7,6 @@ dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-002-PsYLVpVv" "tezos-protocol-compiler" "tezos-protocol-updater" diff --git a/src/proto_002_PsYLVpVv/lib_protocol/tezos-protocol-002-PsYLVpVv.opam b/src/proto_002_PsYLVpVv/lib_protocol/tezos-protocol-002-PsYLVpVv.opam index 0298e524ef127eb058218fa876bc7e4efdec8265..cb764cc22d847f3e5a7672e1d95101e53d56ce11 100644 --- a/src/proto_002_PsYLVpVv/lib_protocol/tezos-protocol-002-PsYLVpVv.opam +++ b/src/proto_002_PsYLVpVv/lib_protocol/tezos-protocol-002-PsYLVpVv.opam @@ -7,7 +7,6 @@ dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" "alcotest-lwt" { with-test & >= "1.1.0" } "tezos-stdlib-unix" { with-test } diff --git a/src/proto_002_PsYLVpVv/lib_protocol/tezos-protocol-functor-002-PsYLVpVv.opam b/src/proto_002_PsYLVpVv/lib_protocol/tezos-protocol-functor-002-PsYLVpVv.opam new file mode 100644 index 0000000000000000000000000000000000000000..f2ef2a70e0faf44e714ea6c935f6205e14a60d75 --- /dev/null +++ b/src/proto_002_PsYLVpVv/lib_protocol/tezos-protocol-functor-002-PsYLVpVv.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-002-PsYLVpVv" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "002_PsYLVpVv" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: 002_PsYLVpVv (economic-protocol definition parameterized by its environment implementation)" diff --git a/src/proto_003_PsddFKi3/lib_protocol/dune.inc b/src/proto_003_PsddFKi3/lib_protocol/dune.inc index 2e75f5942a8ef306d109d694a35fdf27e8f1ff97..2e4610933a205f24bd2f22729a4be8ca8c3c2b89 100644 --- a/src/proto_003_PsddFKi3/lib_protocol/dune.inc +++ b/src/proto_003_PsddFKi3/lib_protocol/dune.inc @@ -261,7 +261,7 @@ include Tezos_raw_protocol_003_PsddFKi3.Main (libraries tezos_protocol_environment_003_PsddFKi3) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_003_PsddFKi3__Environment -open Pervasives @@ -348,19 +348,19 @@ include Tezos_raw_protocol_003_PsddFKi3.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_003_PsddFKi3) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_003_PsddFKi3_functor) - (public_name tezos-protocol-003-PsddFKi3.functor) + (public_name tezos-protocol-functor-003-PsddFKi3) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_003_PsddFKi3) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-003-PsddFKi3.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -372,7 +372,7 @@ include Tezos_raw_protocol_003_PsddFKi3.Main (libraries tezos-protocol-003-PsddFKi3 tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_003_PsddFKi3/lib_protocol/tezos-embedded-protocol-003-PsddFKi3.opam b/src/proto_003_PsddFKi3/lib_protocol/tezos-embedded-protocol-003-PsddFKi3.opam index bc88bef78933122024ceae2b0292a744a395cca9..0eb79aa5c9d123e2a452390041531eb39cb142a8 100644 --- a/src/proto_003_PsddFKi3/lib_protocol/tezos-embedded-protocol-003-PsddFKi3.opam +++ b/src/proto_003_PsddFKi3/lib_protocol/tezos-embedded-protocol-003-PsddFKi3.opam @@ -7,7 +7,6 @@ dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-003-PsddFKi3" "tezos-protocol-compiler" "tezos-protocol-updater" diff --git a/src/proto_003_PsddFKi3/lib_protocol/tezos-protocol-003-PsddFKi3.opam b/src/proto_003_PsddFKi3/lib_protocol/tezos-protocol-003-PsddFKi3.opam index da7f7bae54f5ad4306dd96c337783226e0135539..4326b8bdcb5a75908d2a459e6b5fef663ef7e68e 100644 --- a/src/proto_003_PsddFKi3/lib_protocol/tezos-protocol-003-PsddFKi3.opam +++ b/src/proto_003_PsddFKi3/lib_protocol/tezos-protocol-003-PsddFKi3.opam @@ -7,7 +7,6 @@ dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" "alcotest-lwt" { with-test & >= "1.1.0" } "tezos-stdlib-unix" { with-test } diff --git a/src/proto_003_PsddFKi3/lib_protocol/tezos-protocol-functor-003-PsddFKi3.opam b/src/proto_003_PsddFKi3/lib_protocol/tezos-protocol-functor-003-PsddFKi3.opam new file mode 100644 index 0000000000000000000000000000000000000000..80ba43339ce47c16aaba777a0ba4b30ebfec0bfa --- /dev/null +++ b/src/proto_003_PsddFKi3/lib_protocol/tezos-protocol-functor-003-PsddFKi3.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-003-PsddFKi3" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "003_PsddFKi3" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: 003_PsddFKi3 (economic-protocol definition parameterized by its environment implementation)" diff --git a/src/proto_004_Pt24m4xi/lib_protocol/dune.inc b/src/proto_004_Pt24m4xi/lib_protocol/dune.inc index 7d113ef85663bf17bb0a0223765273d237666b9a..fc08db95d56ed5dc5d112cb109f7a188dcae97ba 100644 --- a/src/proto_004_Pt24m4xi/lib_protocol/dune.inc +++ b/src/proto_004_Pt24m4xi/lib_protocol/dune.inc @@ -261,7 +261,7 @@ include Tezos_raw_protocol_004_Pt24m4xi.Main (libraries tezos_protocol_environment_004_Pt24m4xi) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_004_Pt24m4xi__Environment -open Pervasives @@ -348,19 +348,19 @@ include Tezos_raw_protocol_004_Pt24m4xi.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_004_Pt24m4xi) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_004_Pt24m4xi_functor) - (public_name tezos-protocol-004-Pt24m4xi.functor) + (public_name tezos-protocol-functor-004-Pt24m4xi) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_004_Pt24m4xi) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-004-Pt24m4xi.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -372,7 +372,7 @@ include Tezos_raw_protocol_004_Pt24m4xi.Main (libraries tezos-protocol-004-Pt24m4xi tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_004_Pt24m4xi/lib_protocol/tezos-embedded-protocol-004-Pt24m4xi.opam b/src/proto_004_Pt24m4xi/lib_protocol/tezos-embedded-protocol-004-Pt24m4xi.opam index 8a239e7f36ba2db4cc7f8d790e809f15f30f2301..64f77f87262665a383c64055dbf8d7517fb8b69b 100644 --- a/src/proto_004_Pt24m4xi/lib_protocol/tezos-embedded-protocol-004-Pt24m4xi.opam +++ b/src/proto_004_Pt24m4xi/lib_protocol/tezos-embedded-protocol-004-Pt24m4xi.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-004-Pt24m4xi" "tezos-protocol-compiler" "tezos-protocol-updater" diff --git a/src/proto_004_Pt24m4xi/lib_protocol/tezos-protocol-004-Pt24m4xi.opam b/src/proto_004_Pt24m4xi/lib_protocol/tezos-protocol-004-Pt24m4xi.opam index 8a2c33396fb16059a3429bd465241b9463cf67f7..a751514376254dfa3e40be062254c84026dba81b 100644 --- a/src/proto_004_Pt24m4xi/lib_protocol/tezos-protocol-004-Pt24m4xi.opam +++ b/src/proto_004_Pt24m4xi/lib_protocol/tezos-protocol-004-Pt24m4xi.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" ] build: [ diff --git a/src/proto_004_Pt24m4xi/lib_protocol/tezos-protocol-functor-004-Pt24m4xi.opam b/src/proto_004_Pt24m4xi/lib_protocol/tezos-protocol-functor-004-Pt24m4xi.opam new file mode 100644 index 0000000000000000000000000000000000000000..76addbfc7ab5227c65a6841cf736243e99c43f6b --- /dev/null +++ b/src/proto_004_Pt24m4xi/lib_protocol/tezos-protocol-functor-004-Pt24m4xi.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-004-Pt24m4xi" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "004_Pt24m4xi" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: economic-protocol definition parameterized by its environment implementation" diff --git a/src/proto_005_PsBABY5H/lib_protocol/dune.inc b/src/proto_005_PsBABY5H/lib_protocol/dune.inc index ada00fe986f356bd0db3b43a268a140678e86d0c..68c8ab2bd29244e7bc143751cfa7160afa6d331b 100644 --- a/src/proto_005_PsBABY5H/lib_protocol/dune.inc +++ b/src/proto_005_PsBABY5H/lib_protocol/dune.inc @@ -264,7 +264,7 @@ include Tezos_raw_protocol_005_PsBABY5H.Main (libraries tezos_protocol_environment_005_PsBABY5H) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_005_PsBABY5H__Environment -open Pervasives @@ -352,19 +352,19 @@ include Tezos_raw_protocol_005_PsBABY5H.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_005_PsBABY5H) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_005_PsBABY5H_functor) - (public_name tezos-protocol-005-PsBABY5H.functor) + (public_name tezos-protocol-functor-005-PsBABY5H) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_005_PsBABY5H) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-005-PsBABY5H.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -376,7 +376,7 @@ include Tezos_raw_protocol_005_PsBABY5H.Main (libraries tezos-protocol-005-PsBABY5H tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_005_PsBABY5H/lib_protocol/tezos-embedded-protocol-005-PsBABY5H.opam b/src/proto_005_PsBABY5H/lib_protocol/tezos-embedded-protocol-005-PsBABY5H.opam index bea5968b96c16684e4f717498666e241941f1314..bf382938115fc81d7a0ac3ec5e3a4f5408134e7d 100644 --- a/src/proto_005_PsBABY5H/lib_protocol/tezos-embedded-protocol-005-PsBABY5H.opam +++ b/src/proto_005_PsBABY5H/lib_protocol/tezos-embedded-protocol-005-PsBABY5H.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-005-PsBABY5H" "tezos-protocol-compiler" "tezos-protocol-updater" diff --git a/src/proto_005_PsBABY5H/lib_protocol/tezos-protocol-005-PsBABY5H.opam b/src/proto_005_PsBABY5H/lib_protocol/tezos-protocol-005-PsBABY5H.opam index c168eee9b5ee521497ebaf50938374c0d58c1823..142e13b0728a9a232d61aeb9646f7e6bd0fa3ca0 100644 --- a/src/proto_005_PsBABY5H/lib_protocol/tezos-protocol-005-PsBABY5H.opam +++ b/src/proto_005_PsBABY5H/lib_protocol/tezos-protocol-005-PsBABY5H.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" ] build: [ diff --git a/src/proto_005_PsBABY5H/lib_protocol/tezos-protocol-functor-005-PsBABY5H.opam b/src/proto_005_PsBABY5H/lib_protocol/tezos-protocol-functor-005-PsBABY5H.opam new file mode 100644 index 0000000000000000000000000000000000000000..84212ed7419cfd29ea1ddc13ab776af17424e1c6 --- /dev/null +++ b/src/proto_005_PsBABY5H/lib_protocol/tezos-protocol-functor-005-PsBABY5H.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-005-PsBABY5H" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "005_PsBABY5H" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: economic-protocol definition parameterized by its environment implementation" diff --git a/src/proto_005_PsBabyM1/lib_protocol/dune.inc b/src/proto_005_PsBabyM1/lib_protocol/dune.inc index 261b0c7dc9d71834df53b79fa0cab6b1840c9ebe..87915fc481fb216d649a6a5ce909b626a6e182d7 100644 --- a/src/proto_005_PsBabyM1/lib_protocol/dune.inc +++ b/src/proto_005_PsBabyM1/lib_protocol/dune.inc @@ -264,7 +264,7 @@ include Tezos_raw_protocol_005_PsBabyM1.Main (libraries tezos_protocol_environment_005_PsBabyM1) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_005_PsBabyM1__Environment -open Pervasives @@ -352,19 +352,19 @@ include Tezos_raw_protocol_005_PsBabyM1.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_005_PsBabyM1) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_005_PsBabyM1_functor) - (public_name tezos-protocol-005-PsBabyM1.functor) + (public_name tezos-protocol-functor-005-PsBabyM1) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_005_PsBabyM1) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-005-PsBabyM1.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -376,7 +376,7 @@ include Tezos_raw_protocol_005_PsBabyM1.Main (libraries tezos-protocol-005-PsBabyM1 tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_005_PsBabyM1/lib_protocol/tezos-embedded-protocol-005-PsBabyM1.opam b/src/proto_005_PsBabyM1/lib_protocol/tezos-embedded-protocol-005-PsBabyM1.opam index 597c0d00a2c1943d56f0913538c3d06e99c14126..9c29013d1727c781fbd919a9d60a34f190bba0e2 100644 --- a/src/proto_005_PsBabyM1/lib_protocol/tezos-embedded-protocol-005-PsBabyM1.opam +++ b/src/proto_005_PsBabyM1/lib_protocol/tezos-embedded-protocol-005-PsBabyM1.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-005-PsBabyM1" "tezos-protocol-compiler" "tezos-protocol-updater" diff --git a/src/proto_005_PsBabyM1/lib_protocol/tezos-protocol-005-PsBabyM1.opam b/src/proto_005_PsBabyM1/lib_protocol/tezos-protocol-005-PsBabyM1.opam index 93ae9634d3e80628124ab30e6126644a961b3a8f..59cf6486b91a7d9336d4d25e983e3270d15b4884 100644 --- a/src/proto_005_PsBabyM1/lib_protocol/tezos-protocol-005-PsBabyM1.opam +++ b/src/proto_005_PsBabyM1/lib_protocol/tezos-protocol-005-PsBabyM1.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" ] build: [ diff --git a/src/proto_005_PsBabyM1/lib_protocol/tezos-protocol-functor-005-PsBabyM1.opam b/src/proto_005_PsBabyM1/lib_protocol/tezos-protocol-functor-005-PsBabyM1.opam new file mode 100644 index 0000000000000000000000000000000000000000..4b2ddf8afe442988e428f78cdbc5a6511548b41f --- /dev/null +++ b/src/proto_005_PsBabyM1/lib_protocol/tezos-protocol-functor-005-PsBabyM1.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-005-PsBabyM1" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "005_PsBabyM1" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: economic-protocol definition parameterized by its environment implementation" diff --git a/src/proto_006_PsCARTHA/lib_protocol/dune.inc b/src/proto_006_PsCARTHA/lib_protocol/dune.inc index 14282a7082e27eee31b0fe28bc994f23a42635be..a80017332e139b8a0085955b869831e161bbea3a 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/dune.inc +++ b/src/proto_006_PsCARTHA/lib_protocol/dune.inc @@ -264,7 +264,7 @@ include Tezos_raw_protocol_006_PsCARTHA.Main (libraries tezos_protocol_environment_006_PsCARTHA) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_006_PsCARTHA__Environment -open Pervasives @@ -352,19 +352,19 @@ include Tezos_raw_protocol_006_PsCARTHA.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_006_PsCARTHA) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_006_PsCARTHA_functor) - (public_name tezos-protocol-006-PsCARTHA.functor) + (public_name tezos-protocol-functor-006-PsCARTHA) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_006_PsCARTHA) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-006-PsCARTHA.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -376,7 +376,7 @@ include Tezos_raw_protocol_006_PsCARTHA.Main (libraries tezos-protocol-006-PsCARTHA tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_006_PsCARTHA/lib_protocol/tezos-embedded-protocol-006-PsCARTHA.opam b/src/proto_006_PsCARTHA/lib_protocol/tezos-embedded-protocol-006-PsCARTHA.opam index c81828751533af2f6c62421de118476398848c94..12a21bf70b60dd05aeaaaeeec9e03fdf10f0a95a 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/tezos-embedded-protocol-006-PsCARTHA.opam +++ b/src/proto_006_PsCARTHA/lib_protocol/tezos-embedded-protocol-006-PsCARTHA.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-006-PsCARTHA" "tezos-protocol-compiler" "tezos-protocol-updater" diff --git a/src/proto_006_PsCARTHA/lib_protocol/tezos-protocol-006-PsCARTHA.opam b/src/proto_006_PsCARTHA/lib_protocol/tezos-protocol-006-PsCARTHA.opam index 01a31332640e8f84b148b946dbe1621520adcaa3..47cc522ff43a277fdd97e59aba797f842b644033 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/tezos-protocol-006-PsCARTHA.opam +++ b/src/proto_006_PsCARTHA/lib_protocol/tezos-protocol-006-PsCARTHA.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" ] build: [ diff --git a/src/proto_006_PsCARTHA/lib_protocol/tezos-protocol-functor-006-PsCARTHA.opam b/src/proto_006_PsCARTHA/lib_protocol/tezos-protocol-functor-006-PsCARTHA.opam new file mode 100644 index 0000000000000000000000000000000000000000..632829c4994198abe6df8fc3dc6b908a0cf23b39 --- /dev/null +++ b/src/proto_006_PsCARTHA/lib_protocol/tezos-protocol-functor-006-PsCARTHA.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-006-PsCARTHA" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "006_PsCARTHA" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: economic-protocol definition parameterized by its environment implementation" diff --git a/src/proto_007_PsDELPH1/lib_client/dune b/src/proto_007_PsDELPH1/lib_client/dune index 643fc97501e5102acf5d8f28e090d2cc2c7f7751..7cb1913854b1057cb44dbb3bcfea038718507040 100644 --- a/src/proto_007_PsDELPH1/lib_client/dune +++ b/src/proto_007_PsDELPH1/lib_client/dune @@ -8,7 +8,8 @@ tezos-mockup-registration tezos-rpc tezos-signer-backends - tezos-protocol-007-PsDELPH1-parameters) + tezos-protocol-007-PsDELPH1-parameters + tezos-protocol-plugin-007-PsDELPH1) (library_flags (:standard -linkall)) (flags (:standard -open Tezos_base__TzPervasives -open Tezos_shell_services diff --git a/src/proto_007_PsDELPH1/lib_client/mockup.ml b/src/proto_007_PsDELPH1/lib_client/mockup.ml index 1fa44f9512e3dfd22cc03316fdd84aae63451ad0..f8a05379e26d4ed0d668595e4db499e81370b667 100644 --- a/src/proto_007_PsDELPH1/lib_client/mockup.ml +++ b/src/proto_007_PsDELPH1/lib_client/mockup.ml @@ -495,7 +495,7 @@ let () = module Protocol = Protocol_client_context.Lifted_protocol module Block_services = Protocol_client_context.Alpha_block_services - let directory = Protocol.rpc_services + let directory = Tezos_protocol_plugin_007_PsDELPH1.Plugin.RPC.rpc_services let init = mem_init end in diff --git a/src/proto_007_PsDELPH1/lib_client/tezos-client-007-PsDELPH1.opam b/src/proto_007_PsDELPH1/lib_client/tezos-client-007-PsDELPH1.opam index f3cecf4f9838369bc03ec9fa91aa4b124e698cf3..7d05423677e51a67b7127918fb61f7d1c4c4349a 100644 --- a/src/proto_007_PsDELPH1/lib_client/tezos-client-007-PsDELPH1.opam +++ b/src/proto_007_PsDELPH1/lib_client/tezos-client-007-PsDELPH1.opam @@ -16,6 +16,7 @@ depends: [ "tezos-mockup-registration" "tezos-signer-backends" "tezos-protocol-007-PsDELPH1-parameters" + "tezos-protocol-plugin-007-PsDELPH1" "alcotest-lwt" { with-test & >= "1.1.0" } ] build: [ diff --git a/src/proto_007_PsDELPH1/lib_mempool/dune b/src/proto_007_PsDELPH1/lib_mempool/dune deleted file mode 100644 index 8ac964a1f5e3209437d976b08adad8cb4fab8062..0000000000000000000000000000000000000000 --- a/src/proto_007_PsDELPH1/lib_mempool/dune +++ /dev/null @@ -1,14 +0,0 @@ -(library - (name tezos_mempool_007_PsDELPH1) - (public_name tezos-mempool-007-PsDELPH1) - (libraries tezos-base - tezos-embedded-protocol-007-PsDELPH1 - tezos-protocol-007-PsDELPH1) - (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_embedded_protocol_007_PsDELPH1 - -open Tezos_protocol_007_PsDELPH1))) - -(rule - (alias runtest_lint) - (deps (glob_files *.ml{,i})) - (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/proto_007_PsDELPH1/lib_mempool/filter.ml b/src/proto_007_PsDELPH1/lib_mempool/filter.ml deleted file mode 100644 index 2be62780706129518b13e181044c6eb10b25e809..0000000000000000000000000000000000000000 --- a/src/proto_007_PsDELPH1/lib_mempool/filter.ml +++ /dev/null @@ -1,224 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Nomadic Development. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context -module Proto = Registerer.Registered - -type nanotez = Q.t - -let nanotez_enc : nanotez Data_encoding.t = - let open Data_encoding in - def - "nanotez" - ~title:"A thousandth of a mutez" - ~description:"One thousand nanotez make a mutez (1 tez = 1e9 nanotez)" - (conv - (fun q -> (q.Q.num, q.Q.den)) - (fun (num, den) -> {Q.num; den}) - (tup2 z z)) - -type config = { - minimal_fees : Tez.t; - minimal_nanotez_per_gas_unit : nanotez; - minimal_nanotez_per_byte : nanotez; - allow_script_failure : bool; -} - -let default_minimal_fees = - match Tez.of_mutez 100L with None -> assert false | Some t -> t - -let default_minimal_nanotez_per_gas_unit = Q.of_int 100 - -let default_minimal_nanotez_per_byte = Q.of_int 1000 - -let config_encoding : config Data_encoding.t = - let open Data_encoding in - conv - (fun { minimal_fees; - minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte; - allow_script_failure } -> - ( minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - allow_script_failure )) - (fun ( minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - allow_script_failure ) -> - { - minimal_fees; - minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte; - allow_script_failure; - }) - (obj4 - (dft "minimal_fees" Tez.encoding default_minimal_fees) - (dft - "minimal_nanotez_per_gas_unit" - nanotez_enc - default_minimal_nanotez_per_gas_unit) - (dft - "minimal_nanotez_per_byte" - nanotez_enc - default_minimal_nanotez_per_byte) - (dft "allow_script_failure" bool true)) - -let default_config = - { - minimal_fees = default_minimal_fees; - minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte = default_minimal_nanotez_per_byte; - allow_script_failure = true; - } - -let get_manager_operation_gas_and_fee contents = - let open Operation in - let l = to_list (Contents_list contents) in - List.fold_left - (fun acc -> function - | Contents (Manager_operation {fee; gas_limit; _}) -> ( - match acc with - | Error _ as e -> - e - | Ok (total_fee, total_gas) -> ( - match Tez.(total_fee +? fee) with - | Ok total_fee -> - Ok (total_fee, Gas.Arith.add total_gas gas_limit) - | Error _ as e -> - e ) ) | _ -> acc) - (Ok (Tez.zero, Gas.Arith.zero)) - l - -let pre_filter_manager : - type t. config -> t Kind.manager contents_list -> int -> bool = - fun config op size -> - match get_manager_operation_gas_and_fee op with - | Error _ -> - false - | Ok (fee, gas) -> - let fees_in_nanotez = - Q.mul (Q.of_int64 (Tez.to_mutez fee)) (Q.of_int 1000) - in - let minimal_fees_in_nanotez = - Q.mul (Q.of_int64 (Tez.to_mutez config.minimal_fees)) (Q.of_int 1000) - in - let minimal_fees_for_gas_in_nanotez = - Q.mul - config.minimal_nanotez_per_gas_unit - (Q.of_bigint @@ Gas.Arith.integral_to_z gas) - in - let minimal_fees_for_size_in_nanotez = - Q.mul config.minimal_nanotez_per_byte (Q.of_int size) - in - Q.compare - fees_in_nanotez - (Q.add - minimal_fees_in_nanotez - (Q.add - minimal_fees_for_gas_in_nanotez - minimal_fees_for_size_in_nanotez)) - >= 0 - -let pre_filter config - (Operation_data {contents; _} as op : Operation.packed_protocol_data) = - let bytes = - Data_encoding.Binary.fixed_length_exn - Tezos_base.Operation.shell_header_encoding - + Data_encoding.Binary.length Operation.protocol_data_encoding op - in - match contents with - | Single (Endorsement _) -> - true - | Single (Seed_nonce_revelation _) -> - true - | Single (Double_endorsement_evidence _) -> - true - | Single (Double_baking_evidence _) -> - true - | Single (Activate_account _) -> - true - | Single (Proposals _) -> - true - | Single (Ballot _) -> - true - | Single (Manager_operation _) as op -> - pre_filter_manager config op bytes - | Cons (Manager_operation _, _) as op -> - pre_filter_manager config op bytes - -open Apply_results - -let rec post_filter_manager : - type t. - Alpha_context.t -> - t Kind.manager contents_result_list -> - config -> - bool Lwt.t = - fun ctxt op config -> - match op with - | Single_result (Manager_operation_result {operation_result; _}) -> ( - match operation_result with - | Applied _ -> - Lwt.return_true - | Skipped _ | Failed _ | Backtracked _ -> - Lwt.return config.allow_script_failure ) - | Cons_result (Manager_operation_result res, rest) -> ( - post_filter_manager - ctxt - (Single_result (Manager_operation_result res)) - config - >>= function - | false -> - Lwt.return_false - | true -> - post_filter_manager ctxt rest config ) - -let post_filter config ~validation_state_before:_ - ~validation_state_after:({ctxt; _} : validation_state) (_op, receipt) = - match receipt with - | No_operation_metadata -> - assert false (* only for multipass validator *) - | Operation_metadata {contents} -> ( - match contents with - | Single_result (Endorsement_result _) -> - Lwt.return_true - | Single_result (Seed_nonce_revelation_result _) -> - Lwt.return_true - | Single_result (Double_endorsement_evidence_result _) -> - Lwt.return_true - | Single_result (Double_baking_evidence_result _) -> - Lwt.return_true - | Single_result (Activate_account_result _) -> - Lwt.return_true - | Single_result Proposals_result -> - Lwt.return_true - | Single_result Ballot_result -> - Lwt.return_true - | Single_result (Manager_operation_result _) as op -> - post_filter_manager ctxt op config - | Cons_result (Manager_operation_result _, _) as op -> - post_filter_manager ctxt op config ) diff --git a/src/proto_007_PsDELPH1/lib_mempool/.ocamlformat b/src/proto_007_PsDELPH1/lib_plugin/.ocamlformat similarity index 100% rename from src/proto_007_PsDELPH1/lib_mempool/.ocamlformat rename to src/proto_007_PsDELPH1/lib_plugin/.ocamlformat diff --git a/src/proto_007_PsDELPH1/lib_plugin/dune b/src/proto_007_PsDELPH1/lib_plugin/dune new file mode 100644 index 0000000000000000000000000000000000000000..36bb218c19e7449f7faee53a78a770bbbba05542 --- /dev/null +++ b/src/proto_007_PsDELPH1/lib_plugin/dune @@ -0,0 +1,26 @@ +(library + (name tezos_protocol_plugin_007_PsDELPH1) + (public_name tezos-protocol-plugin-007-PsDELPH1) + (libraries tezos-base + tezos-embedded-protocol-007-PsDELPH1 + tezos-protocol-007-PsDELPH1) + (modules (:standard) \ Registerer) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_embedded_protocol_007_PsDELPH1 + -open Tezos_protocol_007_PsDELPH1))) + +(library + (name tezos_protocol_plugin_007_PsDELPH1_registerer) + (public_name tezos-protocol-plugin-007-PsDELPH1-registerer) + (libraries tezos-base + tezos-protocol-plugin-007-PsDELPH1 + tezos-shell) + (modules Registerer) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_protocol_plugin_007_PsDELPH1 + -open Tezos_shell))) + +(rule + (alias runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/proto_007_PsDELPH1/lib_mempool/dune-project b/src/proto_007_PsDELPH1/lib_plugin/dune-project similarity index 59% rename from src/proto_007_PsDELPH1/lib_mempool/dune-project rename to src/proto_007_PsDELPH1/lib_plugin/dune-project index bc94cade5507d0c943485da90119539302a6031c..7c81cbf84b341304a87d5752a243d6a70c996f97 100644 --- a/src/proto_007_PsDELPH1/lib_mempool/dune-project +++ b/src/proto_007_PsDELPH1/lib_plugin/dune-project @@ -1,3 +1,3 @@ (lang dune 2.0) (formatting (enabled_for ocaml)) -(name tezos-mempool-alpha) +(name tezos-filters-007-PsDELPH1) diff --git a/src/proto_007_PsDELPH1/lib_plugin/plugin.ml b/src/proto_007_PsDELPH1/lib_plugin/plugin.ml new file mode 100644 index 0000000000000000000000000000000000000000..a52e3c565d8a273be00aec9aafe63ae58808ebb7 --- /dev/null +++ b/src/proto_007_PsDELPH1/lib_plugin/plugin.ml @@ -0,0 +1,231 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Nomadic Development. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +module Proto = Registerer.Registered + +module Mempool = struct + type nanotez = Q.t + + let nanotez_enc : nanotez Data_encoding.t = + let open Data_encoding in + def + "nanotez" + ~title:"A thousandth of a mutez" + ~description:"One thousand nanotez make a mutez (1 tez = 1e9 nanotez)" + (conv + (fun q -> (q.Q.num, q.Q.den)) + (fun (num, den) -> {Q.num; den}) + (tup2 z z)) + + type config = { + minimal_fees : Tez.t; + minimal_nanotez_per_gas_unit : nanotez; + minimal_nanotez_per_byte : nanotez; + allow_script_failure : bool; + } + + let default_minimal_fees = + match Tez.of_mutez 100L with None -> assert false | Some t -> t + + let default_minimal_nanotez_per_gas_unit = Q.of_int 100 + + let default_minimal_nanotez_per_byte = Q.of_int 1000 + + let config_encoding : config Data_encoding.t = + let open Data_encoding in + conv + (fun { minimal_fees; + minimal_nanotez_per_gas_unit; + minimal_nanotez_per_byte; + allow_script_failure } -> + ( minimal_fees, + minimal_nanotez_per_gas_unit, + minimal_nanotez_per_byte, + allow_script_failure )) + (fun ( minimal_fees, + minimal_nanotez_per_gas_unit, + minimal_nanotez_per_byte, + allow_script_failure ) -> + { + minimal_fees; + minimal_nanotez_per_gas_unit; + minimal_nanotez_per_byte; + allow_script_failure; + }) + (obj4 + (dft "minimal_fees" Tez.encoding default_minimal_fees) + (dft + "minimal_nanotez_per_gas_unit" + nanotez_enc + default_minimal_nanotez_per_gas_unit) + (dft + "minimal_nanotez_per_byte" + nanotez_enc + default_minimal_nanotez_per_byte) + (dft "allow_script_failure" bool true)) + + let default_config = + { + minimal_fees = default_minimal_fees; + minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit; + minimal_nanotez_per_byte = default_minimal_nanotez_per_byte; + allow_script_failure = true; + } + + let get_manager_operation_gas_and_fee contents = + let open Operation in + let l = to_list (Contents_list contents) in + List.fold_left + (fun acc -> function + | Contents (Manager_operation {fee; gas_limit; _}) -> ( + match acc with + | Error _ as e -> + e + | Ok (total_fee, total_gas) -> ( + match Tez.(total_fee +? fee) with + | Ok total_fee -> + Ok (total_fee, Gas.Arith.add total_gas gas_limit) + | Error _ as e -> + e ) ) | _ -> acc) + (Ok (Tez.zero, Gas.Arith.zero)) + l + + let pre_filter_manager : + type t. config -> t Kind.manager contents_list -> int -> bool = + fun config op size -> + match get_manager_operation_gas_and_fee op with + | Error _ -> + false + | Ok (fee, gas) -> + let fees_in_nanotez = + Q.mul (Q.of_int64 (Tez.to_mutez fee)) (Q.of_int 1000) + in + let minimal_fees_in_nanotez = + Q.mul (Q.of_int64 (Tez.to_mutez config.minimal_fees)) (Q.of_int 1000) + in + let minimal_fees_for_gas_in_nanotez = + Q.mul + config.minimal_nanotez_per_gas_unit + (Q.of_bigint @@ Gas.Arith.integral_to_z gas) + in + let minimal_fees_for_size_in_nanotez = + Q.mul config.minimal_nanotez_per_byte (Q.of_int size) + in + Q.compare + fees_in_nanotez + (Q.add + minimal_fees_in_nanotez + (Q.add + minimal_fees_for_gas_in_nanotez + minimal_fees_for_size_in_nanotez)) + >= 0 + + let pre_filter config + (Operation_data {contents; _} as op : Operation.packed_protocol_data) = + let bytes = + Data_encoding.Binary.fixed_length_exn + Tezos_base.Operation.shell_header_encoding + + Data_encoding.Binary.length Operation.protocol_data_encoding op + in + match contents with + | Single (Endorsement _) -> + true + | Single (Seed_nonce_revelation _) -> + true + | Single (Double_endorsement_evidence _) -> + true + | Single (Double_baking_evidence _) -> + true + | Single (Activate_account _) -> + true + | Single (Proposals _) -> + true + | Single (Ballot _) -> + true + | Single (Manager_operation _) as op -> + pre_filter_manager config op bytes + | Cons (Manager_operation _, _) as op -> + pre_filter_manager config op bytes + + open Apply_results + + let rec post_filter_manager : + type t. + Alpha_context.t -> + t Kind.manager contents_result_list -> + config -> + bool Lwt.t = + fun ctxt op config -> + match op with + | Single_result (Manager_operation_result {operation_result; _}) -> ( + match operation_result with + | Applied _ -> + Lwt.return_true + | Skipped _ | Failed _ | Backtracked _ -> + Lwt.return config.allow_script_failure ) + | Cons_result (Manager_operation_result res, rest) -> ( + post_filter_manager + ctxt + (Single_result (Manager_operation_result res)) + config + >>= function + | false -> + Lwt.return_false + | true -> + post_filter_manager ctxt rest config ) + + let post_filter config ~validation_state_before:_ + ~validation_state_after:({ctxt; _} : validation_state) (_op, receipt) = + match receipt with + | No_operation_metadata -> + assert false (* only for multipass validator *) + | Operation_metadata {contents} -> ( + match contents with + | Single_result (Endorsement_result _) -> + Lwt.return_true + | Single_result (Seed_nonce_revelation_result _) -> + Lwt.return_true + | Single_result (Double_endorsement_evidence_result _) -> + Lwt.return_true + | Single_result (Double_baking_evidence_result _) -> + Lwt.return_true + | Single_result (Activate_account_result _) -> + Lwt.return_true + | Single_result Proposals_result -> + Lwt.return_true + | Single_result Ballot_result -> + Lwt.return_true + | Single_result (Manager_operation_result _) as op -> + post_filter_manager ctxt op config + | Cons_result (Manager_operation_result _, _) as op -> + post_filter_manager ctxt op config ) +end + +module RPC = struct + let rpc_services : Environment.Updater.rpc_context RPC_directory.t = + Protocol.rpc_services +end diff --git a/src/proto_007_PsDELPH1/lib_plugin/registerer.ml b/src/proto_007_PsDELPH1/lib_plugin/registerer.ml new file mode 100644 index 0000000000000000000000000000000000000000..41094d65528ff8381c4bd87194b5f479c155cf46 --- /dev/null +++ b/src/proto_007_PsDELPH1/lib_plugin/registerer.ml @@ -0,0 +1,28 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Development. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let () = + Prevalidator_filters.register + (module Tezos_protocol_plugin_007_PsDELPH1.Plugin) diff --git a/src/proto_008_PtEdoTez/lib_mempool/tezos-mempool-008-PtEdoTez.opam b/src/proto_007_PsDELPH1/lib_plugin/tezos-protocol-plugin-007-PsDELPH1-registerer.opam similarity index 82% rename from src/proto_008_PtEdoTez/lib_mempool/tezos-mempool-008-PtEdoTez.opam rename to src/proto_007_PsDELPH1/lib_plugin/tezos-protocol-plugin-007-PsDELPH1-registerer.opam index d5bd4f16476fd82ceda706e6fe99d3f7521ba971..6ba5b78c6a8c2d216968b8c2b8db63c94d202909 100644 --- a/src/proto_008_PtEdoTez/lib_mempool/tezos-mempool-008-PtEdoTez.opam +++ b/src/proto_007_PsDELPH1/lib_plugin/tezos-protocol-plugin-007-PsDELPH1-registerer.opam @@ -9,11 +9,11 @@ depends: [ "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-base" - "tezos-embedded-protocol-008-PtEdoTez" + "tezos-protocol-plugin-007-PsDELPH1" "tezos-shell" ] build: [ ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] -synopsis: "Tezos/Protocol: mempool-filters" +synopsis: "Tezos/Protocol: protocol plugin registerer" diff --git a/src/proto_007_PsDELPH1/lib_mempool/tezos-mempool-007-PsDELPH1.opam b/src/proto_007_PsDELPH1/lib_plugin/tezos-protocol-plugin-007-PsDELPH1.opam similarity index 88% rename from src/proto_007_PsDELPH1/lib_mempool/tezos-mempool-007-PsDELPH1.opam rename to src/proto_007_PsDELPH1/lib_plugin/tezos-protocol-plugin-007-PsDELPH1.opam index ec2d941d5748004b44bedc962630bab1636837d4..b98f226e8ce8992d90e04c1f35a8ffdc4162a1ff 100644 --- a/src/proto_007_PsDELPH1/lib_mempool/tezos-mempool-007-PsDELPH1.opam +++ b/src/proto_007_PsDELPH1/lib_plugin/tezos-protocol-plugin-007-PsDELPH1.opam @@ -10,10 +10,9 @@ depends: [ "dune" { >= "2.0" } "tezos-base" "tezos-embedded-protocol-007-PsDELPH1" - "tezos-shell" ] build: [ ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] -synopsis: "Tezos/Protocol: mempool-filters" +synopsis: "Tezos/Protocol: protocol plugin" diff --git a/src/proto_007_PsDELPH1/lib_protocol/dune.inc b/src/proto_007_PsDELPH1/lib_protocol/dune.inc index 01f3cb643c7c28f5c605f8aef7afa63b9629b453..74b1b293ae103df3221a58612d9d883bf7857c19 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/dune.inc +++ b/src/proto_007_PsDELPH1/lib_protocol/dune.inc @@ -270,7 +270,7 @@ include Tezos_raw_protocol_007_PsDELPH1.Main (libraries tezos_protocol_environment_007_PsDELPH1) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_007_PsDELPH1__Environment -open Pervasives @@ -360,19 +360,19 @@ include Tezos_raw_protocol_007_PsDELPH1.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_007_PsDELPH1) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_007_PsDELPH1_functor) - (public_name tezos-protocol-007-PsDELPH1.functor) + (public_name tezos-protocol-functor-007-PsDELPH1) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_007_PsDELPH1) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-007-PsDELPH1.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -384,7 +384,7 @@ include Tezos_raw_protocol_007_PsDELPH1.Main (libraries tezos-protocol-007-PsDELPH1 tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_007_PsDELPH1/lib_protocol/tezos-embedded-protocol-007-PsDELPH1.opam b/src/proto_007_PsDELPH1/lib_protocol/tezos-embedded-protocol-007-PsDELPH1.opam index c117be3027f07523c5056bfb365401ae72791f30..2572089ab0f57fa93c10c93ea5b7a3cbafcfbc3a 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/tezos-embedded-protocol-007-PsDELPH1.opam +++ b/src/proto_007_PsDELPH1/lib_protocol/tezos-embedded-protocol-007-PsDELPH1.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-007-PsDELPH1" "tezos-protocol-compiler" "tezos-protocol-updater" diff --git a/src/proto_007_PsDELPH1/lib_protocol/tezos-protocol-007-PsDELPH1-tests.opam b/src/proto_007_PsDELPH1/lib_protocol/tezos-protocol-007-PsDELPH1-tests.opam index 7fcbd48d35ada29229e75365a2b8b07bea4ed542..a1bc00eb605a6f9cd0b443e3c99b97ede8ac097d 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/tezos-protocol-007-PsDELPH1-tests.opam +++ b/src/proto_007_PsDELPH1/lib_protocol/tezos-protocol-007-PsDELPH1-tests.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" "alcotest-lwt" { with-test & >= "1.1.0" } "tezos-007-PsDELPH1-test-helpers" { with-test } diff --git a/src/proto_007_PsDELPH1/lib_protocol/tezos-protocol-007-PsDELPH1.opam b/src/proto_007_PsDELPH1/lib_protocol/tezos-protocol-007-PsDELPH1.opam index b6dd1bfe1db214e5e8ad778de21cf5f8ad36c64c..0cf3f0d81d02498d645a205d37966fa866d33e09 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/tezos-protocol-007-PsDELPH1.opam +++ b/src/proto_007_PsDELPH1/lib_protocol/tezos-protocol-007-PsDELPH1.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" ] build: [ diff --git a/src/proto_007_PsDELPH1/lib_protocol/tezos-protocol-functor-007-PsDELPH1.opam b/src/proto_007_PsDELPH1/lib_protocol/tezos-protocol-functor-007-PsDELPH1.opam new file mode 100644 index 0000000000000000000000000000000000000000..cfd802287f81db58f18520de5ff2e291bc45fe13 --- /dev/null +++ b/src/proto_007_PsDELPH1/lib_protocol/tezos-protocol-functor-007-PsDELPH1.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-007-PsDELPH1" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "007_PsDELPH1" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: economic-protocol definition parameterized by its environment implementation" diff --git a/src/proto_008_PtEdoTez/bin_accuser/.ocamlformat b/src/proto_008_PtEdo2Zk/bin_accuser/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/bin_accuser/.ocamlformat rename to src/proto_008_PtEdo2Zk/bin_accuser/.ocamlformat diff --git a/src/proto_008_PtEdoTez/bin_accuser/dune b/src/proto_008_PtEdo2Zk/bin_accuser/dune similarity index 57% rename from src/proto_008_PtEdoTez/bin_accuser/dune rename to src/proto_008_PtEdo2Zk/bin_accuser/dune index 7474b94d82c54174a3ec0bf3ec31cd6e8c525643..acf83c90f18c2a8cecb566daf9561331cf74fde9 100644 --- a/src/proto_008_PtEdoTez/bin_accuser/dune +++ b/src/proto_008_PtEdo2Zk/bin_accuser/dune @@ -1,14 +1,14 @@ (executable - (name main_accuser_008_PtEdoTez) - (public_name tezos-accuser-008-PtEdoTez) + (name main_accuser_008_PtEdo2Zk) + (public_name tezos-accuser-008-PtEdo2Zk) (libraries tezos-client-base-unix tezos-client-commands - tezos-baking-008-PtEdoTez-commands) + tezos-baking-008-PtEdo2Zk-commands) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_008_PtEdoTez - -open Tezos_client_008_PtEdoTez + -open Tezos_protocol_008_PtEdo2Zk + -open Tezos_client_008_PtEdo2Zk -open Tezos_client_commands - -open Tezos_baking_008_PtEdoTez_commands + -open Tezos_baking_008_PtEdo2Zk_commands -open Tezos_stdlib_unix -open Tezos_client_base_unix))) diff --git a/src/proto_008_PtEdoTez/bin_accuser/dune-project b/src/proto_008_PtEdo2Zk/bin_accuser/dune-project similarity index 100% rename from src/proto_008_PtEdoTez/bin_accuser/dune-project rename to src/proto_008_PtEdo2Zk/bin_accuser/dune-project diff --git a/src/proto_008_PtEdoTez/bin_accuser/main_accuser_008_PtEdoTez.ml b/src/proto_008_PtEdo2Zk/bin_accuser/main_accuser_008_PtEdo2Zk.ml similarity index 100% rename from src/proto_008_PtEdoTez/bin_accuser/main_accuser_008_PtEdoTez.ml rename to src/proto_008_PtEdo2Zk/bin_accuser/main_accuser_008_PtEdo2Zk.ml diff --git a/src/proto_008_PtEdoTez/bin_accuser/tezos-accuser-008-PtEdoTez.opam b/src/proto_008_PtEdo2Zk/bin_accuser/tezos-accuser-008-PtEdo2Zk.opam similarity index 88% rename from src/proto_008_PtEdoTez/bin_accuser/tezos-accuser-008-PtEdoTez.opam rename to src/proto_008_PtEdo2Zk/bin_accuser/tezos-accuser-008-PtEdo2Zk.opam index 65302ba58f35b3390e3b9b2e9e8588ce1bace558..9728cc365a7cbaf344eb55a9f853e0a10a39ba27 100644 --- a/src/proto_008_PtEdoTez/bin_accuser/tezos-accuser-008-PtEdoTez.opam +++ b/src/proto_008_PtEdo2Zk/bin_accuser/tezos-accuser-008-PtEdo2Zk.opam @@ -9,9 +9,9 @@ depends: [ "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-base" - "tezos-client-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" "tezos-client-commands" - "tezos-baking-008-PtEdoTez-commands" + "tezos-baking-008-PtEdo2Zk-commands" "tezos-client-base-unix" ] build: [ diff --git a/src/proto_008_PtEdoTez/bin_baker/.ocamlformat b/src/proto_008_PtEdo2Zk/bin_baker/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/bin_baker/.ocamlformat rename to src/proto_008_PtEdo2Zk/bin_baker/.ocamlformat diff --git a/src/proto_008_PtEdoTez/bin_baker/dune b/src/proto_008_PtEdo2Zk/bin_baker/dune similarity index 57% rename from src/proto_008_PtEdoTez/bin_baker/dune rename to src/proto_008_PtEdo2Zk/bin_baker/dune index 3131e95c81be4f711e483b823d85c5be0547cdca..dc369f48155158dc742aa81cd0818b332ef8e9e5 100644 --- a/src/proto_008_PtEdoTez/bin_baker/dune +++ b/src/proto_008_PtEdo2Zk/bin_baker/dune @@ -1,14 +1,14 @@ (executable - (name main_baker_008_PtEdoTez) - (public_name tezos-baker-008-PtEdoTez) + (name main_baker_008_PtEdo2Zk) + (public_name tezos-baker-008-PtEdo2Zk) (libraries tezos-client-base-unix tezos-client-commands - tezos-baking-008-PtEdoTez-commands) + tezos-baking-008-PtEdo2Zk-commands) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_008_PtEdoTez - -open Tezos_client_008_PtEdoTez + -open Tezos_protocol_008_PtEdo2Zk + -open Tezos_client_008_PtEdo2Zk -open Tezos_client_commands - -open Tezos_baking_008_PtEdoTez_commands + -open Tezos_baking_008_PtEdo2Zk_commands -open Tezos_stdlib_unix -open Tezos_client_base_unix))) diff --git a/src/proto_008_PtEdoTez/bin_baker/dune-project b/src/proto_008_PtEdo2Zk/bin_baker/dune-project similarity index 100% rename from src/proto_008_PtEdoTez/bin_baker/dune-project rename to src/proto_008_PtEdo2Zk/bin_baker/dune-project diff --git a/src/proto_008_PtEdoTez/bin_baker/main_baker_008_PtEdoTez.ml b/src/proto_008_PtEdo2Zk/bin_baker/main_baker_008_PtEdo2Zk.ml similarity index 82% rename from src/proto_008_PtEdoTez/bin_baker/main_baker_008_PtEdoTez.ml rename to src/proto_008_PtEdo2Zk/bin_baker/main_baker_008_PtEdo2Zk.ml index d3584e1cd534da593029d34f5654edfcae7de73b..9c2db8f1506a20f1119ad614c9535f1c80a2bcc6 100644 --- a/src/proto_008_PtEdoTez/bin_baker/main_baker_008_PtEdoTez.ml +++ b/src/proto_008_PtEdo2Zk/bin_baker/main_baker_008_PtEdo2Zk.ml @@ -40,4 +40,13 @@ let select_commands _ _ = (Clic.map_command (new Protocol_client_context.wrap_full)) (Delegate_commands.baker_commands ())) +(* This call is not strictly necessary as the parameters are initialized + lazily the first time a Sapling operation (validation or forging) is + done. This is what the client does. + For a long running binary however it is important to make sure that the + parameters files are there at the start and avoid failing much later while + validating an operation. Plus paying this cost upfront means that the first + validation will not be more expensive. *) +let () = Tezos_sapling.Core.Validator.init_params () + let () = Client_main_run.run (module Client_config) ~select_commands diff --git a/src/proto_008_PtEdoTez/bin_baker/tezos-baker-008-PtEdoTez.opam b/src/proto_008_PtEdo2Zk/bin_baker/tezos-baker-008-PtEdo2Zk.opam similarity index 88% rename from src/proto_008_PtEdoTez/bin_baker/tezos-baker-008-PtEdoTez.opam rename to src/proto_008_PtEdo2Zk/bin_baker/tezos-baker-008-PtEdo2Zk.opam index b3ee511ceeea28cdd7ea7e35d6c7082a6205a889..15192e5ce3258d08b89cf96f80f25d0dda1307ad 100644 --- a/src/proto_008_PtEdoTez/bin_baker/tezos-baker-008-PtEdoTez.opam +++ b/src/proto_008_PtEdo2Zk/bin_baker/tezos-baker-008-PtEdo2Zk.opam @@ -9,9 +9,9 @@ depends: [ "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-base" - "tezos-client-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" "tezos-client-commands" - "tezos-baking-008-PtEdoTez-commands" + "tezos-baking-008-PtEdo2Zk-commands" "tezos-client-base-unix" ] build: [ diff --git a/src/proto_008_PtEdoTez/bin_endorser/.ocamlformat b/src/proto_008_PtEdo2Zk/bin_endorser/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/bin_endorser/.ocamlformat rename to src/proto_008_PtEdo2Zk/bin_endorser/.ocamlformat diff --git a/src/proto_008_PtEdoTez/bin_endorser/dune b/src/proto_008_PtEdo2Zk/bin_endorser/dune similarity index 57% rename from src/proto_008_PtEdoTez/bin_endorser/dune rename to src/proto_008_PtEdo2Zk/bin_endorser/dune index 81ebe60753f916f261dfb731ad2133661aef6899..1df9d7639e5f781983d6d8ab753c419af415774a 100644 --- a/src/proto_008_PtEdoTez/bin_endorser/dune +++ b/src/proto_008_PtEdo2Zk/bin_endorser/dune @@ -1,14 +1,14 @@ (executable - (name main_endorser_008_PtEdoTez) - (public_name tezos-endorser-008-PtEdoTez) + (name main_endorser_008_PtEdo2Zk) + (public_name tezos-endorser-008-PtEdo2Zk) (libraries tezos-client-base-unix tezos-client-commands - tezos-baking-008-PtEdoTez-commands) + tezos-baking-008-PtEdo2Zk-commands) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_008_PtEdoTez - -open Tezos_client_008_PtEdoTez + -open Tezos_protocol_008_PtEdo2Zk + -open Tezos_client_008_PtEdo2Zk -open Tezos_client_commands - -open Tezos_baking_008_PtEdoTez_commands + -open Tezos_baking_008_PtEdo2Zk_commands -open Tezos_stdlib_unix -open Tezos_client_base_unix))) diff --git a/src/proto_008_PtEdoTez/bin_endorser/dune-project b/src/proto_008_PtEdo2Zk/bin_endorser/dune-project similarity index 100% rename from src/proto_008_PtEdoTez/bin_endorser/dune-project rename to src/proto_008_PtEdo2Zk/bin_endorser/dune-project diff --git a/src/proto_008_PtEdoTez/bin_endorser/main_endorser_008_PtEdoTez.ml b/src/proto_008_PtEdo2Zk/bin_endorser/main_endorser_008_PtEdo2Zk.ml similarity index 100% rename from src/proto_008_PtEdoTez/bin_endorser/main_endorser_008_PtEdoTez.ml rename to src/proto_008_PtEdo2Zk/bin_endorser/main_endorser_008_PtEdo2Zk.ml diff --git a/src/proto_008_PtEdoTez/bin_endorser/tezos-endorser-008-PtEdoTez.opam b/src/proto_008_PtEdo2Zk/bin_endorser/tezos-endorser-008-PtEdo2Zk.opam similarity index 88% rename from src/proto_008_PtEdoTez/bin_endorser/tezos-endorser-008-PtEdoTez.opam rename to src/proto_008_PtEdo2Zk/bin_endorser/tezos-endorser-008-PtEdo2Zk.opam index 59abbab2547c13081ba58e87939210d6e7c94da4..44768c158ee4c8e87c43516f9bb73540938af72e 100644 --- a/src/proto_008_PtEdoTez/bin_endorser/tezos-endorser-008-PtEdoTez.opam +++ b/src/proto_008_PtEdo2Zk/bin_endorser/tezos-endorser-008-PtEdo2Zk.opam @@ -9,9 +9,9 @@ depends: [ "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-base" - "tezos-client-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" "tezos-client-commands" - "tezos-baking-008-PtEdoTez-commands" + "tezos-baking-008-PtEdo2Zk-commands" "tezos-client-base-unix" ] build: [ diff --git a/src/proto_008_PtEdoTez/lib_client/.ocamlformat b/src/proto_008_PtEdo2Zk/lib_client/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/.ocamlformat rename to src/proto_008_PtEdo2Zk/lib_client/.ocamlformat diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_args.ml b/src/proto_008_PtEdo2Zk/lib_client/client_proto_args.ml similarity index 90% rename from src/proto_008_PtEdoTez/lib_client/client_proto_args.ml rename to src/proto_008_PtEdo2Zk/lib_client/client_proto_args.ml index e7d4300d0010cb52b56099b40f84fc448c3e03ca..47ff8548c2d8130dfd3521270ac08167a69c23de 100644 --- a/src/proto_008_PtEdoTez/lib_client/client_proto_args.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_args.ml @@ -469,6 +469,45 @@ let signature_parameter = | None -> failwith "Not given a valid signature") +let unparsing_mode_parameter = + parameter + ~autocomplete:(fun _cctxt -> + return ["Readable"; "Optimized"; "Optimized_legacy"]) + (fun _cctxt s -> + match s with + | "Readable" -> + return Script_ir_translator.Readable + | "Optimized" -> + return Script_ir_translator.Optimized + | "Optimized_legacy" -> + return Script_ir_translator.Optimized_legacy + | _ -> + failwith "Unknown unparsing mode %s" s) + +let unparsing_mode_arg ~default = + default_arg + ~long:"unparsing-mode" + ~placeholder:"mode" + ~doc: + "Unparsing mode to use\n\ + One of \"Readable\", \"Optimized\", or \"Optimized_legacy\".\n\ + This option affects the way the values of the following Michelson \ + types are represented:\n\ + - timestamp: the Readable representation is a RFC3339 string, the \ + Optimized and Optimized_legacy representations are the number of \ + seconds since Epoch\n\ + - key, signature, key_hash, address, contract, chain_id: the Readable \ + representation is a Base58Check string, the Optimized and \ + Optimized_legacy representations are byte sequences\n\ + - nested pairs: in Readable mode, the Pair constructor is used even \ + with arity bigger than 2 such as in Pair 0 1 2; in Optimized_legacy \ + mode, the Pair constructor is always use with arity 2 such as in Pair \ + 0 (Pair 1 2); in Optimized mode, a sequence is used if there are at \ + least 4 elements and the behavior is the same as in Optimized_legacy \ + mode otherwise.\n" + ~default + unparsing_mode_parameter + module Daemon = struct let baking_switch = switch ~long:"baking" ~short:'B' ~doc:"run the baking daemon" () diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_args.mli b/src/proto_008_PtEdo2Zk/lib_client/client_proto_args.mli similarity index 97% rename from src/proto_008_PtEdoTez/lib_client/client_proto_args.mli rename to src/proto_008_PtEdo2Zk/lib_client/client_proto_args.mli index 1a0f57bf594d9a299492248e60f03679d6e07c17..a095bd9d5e3a9c21b6b83135fbd921ebf9e5de87 100644 --- a/src/proto_008_PtEdoTez/lib_client/client_proto_args.mli +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_args.mli @@ -114,3 +114,6 @@ val string_parameter : (string, full) Clic.parameter val bytes_of_prefixed_string : string -> Bytes.t tzresult Lwt.t val bytes_parameter : (Bytes.t, full) Clic.parameter + +val unparsing_mode_arg : + default:string -> (Script_ir_translator.unparsing_mode, full) Clic.arg diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_context.ml b/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.ml similarity index 99% rename from src/proto_008_PtEdoTez/lib_client/client_proto_context.ml rename to src/proto_008_PtEdo2Zk/lib_client/client_proto_context.ml index 0b766e2f2318ebeda75209ddc7a3efc6878993ef..d95821939e7b1302a46803d5067bbacd39dc4024 100644 --- a/src/proto_008_PtEdoTez/lib_client/client_proto_context.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.ml @@ -36,8 +36,9 @@ let get_balance (rpc : #rpc_context) ~chain ~block contract = let get_storage (rpc : #rpc_context) ~chain ~block contract = Alpha_services.Contract.storage_opt rpc (chain, block) contract -let get_big_map_value (rpc : #rpc_context) ~chain ~block id key = - Alpha_services.Contract.big_map_get rpc (chain, block) id key +let get_big_map_value (rpc : #rpc_context) ~chain ~block id key ~unparsing_mode + = + Plugin.RPC.big_map_get_normalized rpc (chain, block) id key ~unparsing_mode let get_contract_big_map_value (rpc : #rpc_context) ~chain ~block contract key = diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_context.mli b/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.mli similarity index 99% rename from src/proto_008_PtEdoTez/lib_client/client_proto_context.mli rename to src/proto_008_PtEdo2Zk/lib_client/client_proto_context.mli index 1c09a136e61fa37658e3f218c168854bfdcee0c3..64752af54c96dc805cfd1bdbe7c9613cf1cb22ea 100644 --- a/src/proto_008_PtEdoTez/lib_client/client_proto_context.mli +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.mli @@ -53,6 +53,7 @@ val get_big_map_value : block:Shell_services.block -> Big_map.Id.t -> Script_expr_hash.t -> + unparsing_mode:Script_ir_translator.unparsing_mode -> Script.expr tzresult Lwt.t val get_script : diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_contracts.ml b/src/proto_008_PtEdo2Zk/lib_client/client_proto_contracts.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/client_proto_contracts.ml rename to src/proto_008_PtEdo2Zk/lib_client/client_proto_contracts.ml diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_contracts.mli b/src/proto_008_PtEdo2Zk/lib_client/client_proto_contracts.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/client_proto_contracts.mli rename to src/proto_008_PtEdo2Zk/lib_client/client_proto_contracts.mli diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_multisig.ml b/src/proto_008_PtEdo2Zk/lib_client/client_proto_multisig.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/client_proto_multisig.ml rename to src/proto_008_PtEdo2Zk/lib_client/client_proto_multisig.ml diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_multisig.mli b/src/proto_008_PtEdo2Zk/lib_client/client_proto_multisig.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/client_proto_multisig.mli rename to src/proto_008_PtEdo2Zk/lib_client/client_proto_multisig.mli diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_programs.ml b/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.ml similarity index 95% rename from src/proto_008_PtEdoTez/lib_client/client_proto_programs.ml rename to src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.ml index c446884eec3d34ddea983b09b09a081a4c75c8b4..5bcab5a47ae93c0556cd118cecbc18e04f8521de 100644 --- a/src/proto_008_PtEdoTez/lib_client/client_proto_programs.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.ml @@ -105,10 +105,12 @@ let run (cctxt : #Protocol_client_context.rpc_context) ~(chain : Chain_services.chain) ~block ?(amount = Tez.fifty_cents) ~balance ~(program : Michelson_v1_parser.parsed) ~(storage : Michelson_v1_parser.parsed) - ~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas ?entrypoint () = + ~(input : Michelson_v1_parser.parsed) + ~(unparsing_mode : Script_ir_translator.unparsing_mode) ?source ?payer ?gas + ?entrypoint () = Chain_services.chain_id cctxt ~chain () >>=? fun chain_id -> - Alpha_services.Helpers.Scripts.run_code + Plugin.RPC.run_code_normalized cctxt (chain, block) ?gas @@ -121,15 +123,18 @@ let run (cctxt : #Protocol_client_context.rpc_context) ~chain_id ~source ~payer + ~unparsing_mode let trace (cctxt : #Protocol_client_context.rpc_context) ~(chain : Chain_services.chain) ~block ?(amount = Tez.fifty_cents) ~balance ~(program : Michelson_v1_parser.parsed) ~(storage : Michelson_v1_parser.parsed) - ~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas ?entrypoint () = + ~(input : Michelson_v1_parser.parsed) + ~(unparsing_mode : Script_ir_translator.unparsing_mode) ?source ?payer ?gas + ?entrypoint () = Chain_services.chain_id cctxt ~chain () >>=? fun chain_id -> - Alpha_services.Helpers.Scripts.trace_code + Plugin.RPC.trace_code_normalized cctxt (chain, block) ?gas @@ -142,6 +147,7 @@ let trace (cctxt : #Protocol_client_context.rpc_context) ~chain_id ~source ~payer + ~unparsing_mode let typecheck_data cctxt ~(chain : Chain_services.chain) ~block ?gas ?legacy ~(data : Michelson_v1_parser.parsed) ~(ty : Michelson_v1_parser.parsed) () diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_programs.mli b/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.mli similarity index 98% rename from src/proto_008_PtEdoTez/lib_client/client_proto_programs.mli rename to src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.mli index d0a79acabb940abeb73c07ad1870be358eaccc19..f66958f9f693c107f1d17b0451965bff85799b90 100644 --- a/src/proto_008_PtEdoTez/lib_client/client_proto_programs.mli +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.mli @@ -41,6 +41,7 @@ val run : program:Michelson_v1_parser.parsed -> storage:Michelson_v1_parser.parsed -> input:Michelson_v1_parser.parsed -> + unparsing_mode:Script_ir_translator.unparsing_mode -> ?source:Contract.t -> ?payer:Contract.t -> ?gas:Gas.Arith.integral -> @@ -59,6 +60,7 @@ val trace : program:Michelson_v1_parser.parsed -> storage:Michelson_v1_parser.parsed -> input:Michelson_v1_parser.parsed -> + unparsing_mode:Script_ir_translator.unparsing_mode -> ?source:Contract.t -> ?payer:Contract.t -> ?gas:Gas.Arith.integral -> diff --git a/src/proto_008_PtEdoTez/lib_client/dune b/src/proto_008_PtEdo2Zk/lib_client/dune similarity index 52% rename from src/proto_008_PtEdoTez/lib_client/dune rename to src/proto_008_PtEdo2Zk/lib_client/dune index f3774567d5d4555daca106ab1000bd7fb7e6eb40..5915bfba9cd2afdbf7f351392e4eb5f77a7bba78 100644 --- a/src/proto_008_PtEdoTez/lib_client/dune +++ b/src/proto_008_PtEdo2Zk/lib_client/dune @@ -1,21 +1,23 @@ (library - (name tezos_client_008_PtEdoTez) - (public_name tezos-client-008-PtEdoTez) + (name tezos_client_008_PtEdo2Zk) + (public_name tezos-client-008-PtEdo2Zk) (libraries tezos-base - tezos-protocol-008-PtEdoTez + tezos-protocol-008-PtEdo2Zk tezos-shell-services tezos-client-base tezos-mockup-registration tezos-rpc tezos-signer-backends - tezos-protocol-008-PtEdoTez-parameters) + tezos-protocol-008-PtEdo2Zk-parameters + tezos-protocol-plugin-008-PtEdo2Zk) (library_flags (:standard -linkall)) (flags (:standard -open Tezos_base__TzPervasives -open Tezos_shell_services -open Tezos_client_base - -open Tezos_protocol_008_PtEdoTez - -open Tezos_protocol_008_PtEdoTez_parameters - -open Tezos_rpc))) + -open Tezos_protocol_008_PtEdo2Zk + -open Tezos_protocol_008_PtEdo2Zk_parameters + -open Tezos_rpc + -open Tezos_protocol_plugin_008_PtEdo2Zk))) (rule (alias runtest_lint) diff --git a/src/proto_008_PtEdoTez/lib_client/dune-project b/src/proto_008_PtEdo2Zk/lib_client/dune-project similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/dune-project rename to src/proto_008_PtEdo2Zk/lib_client/dune-project diff --git a/src/proto_008_PtEdoTez/lib_client/injection.ml b/src/proto_008_PtEdo2Zk/lib_client/injection.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/injection.ml rename to src/proto_008_PtEdo2Zk/lib_client/injection.ml diff --git a/src/proto_008_PtEdoTez/lib_client/injection.mli b/src/proto_008_PtEdo2Zk/lib_client/injection.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/injection.mli rename to src/proto_008_PtEdo2Zk/lib_client/injection.mli diff --git a/src/proto_008_PtEdoTez/lib_client/managed_contract.ml b/src/proto_008_PtEdo2Zk/lib_client/managed_contract.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/managed_contract.ml rename to src/proto_008_PtEdo2Zk/lib_client/managed_contract.ml diff --git a/src/proto_008_PtEdoTez/lib_client/managed_contract.mli b/src/proto_008_PtEdo2Zk/lib_client/managed_contract.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/managed_contract.mli rename to src/proto_008_PtEdo2Zk/lib_client/managed_contract.mli diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_emacs.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_emacs.ml rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.ml diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_emacs.mli b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_emacs.mli rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.mli diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_entrypoints.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_entrypoints.ml rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.ml diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_entrypoints.mli b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_entrypoints.mli rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.mli diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_error_reporter.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_error_reporter.ml rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.ml diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_error_reporter.mli b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_error_reporter.mli rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.mli diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_macros.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_macros.ml rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.ml diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_macros.mli b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_macros.mli rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.mli diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_parser.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_parser.ml rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.ml diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_parser.mli b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_parser.mli rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.mli diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_printer.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_printer.ml rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.ml diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_printer.mli b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/michelson_v1_printer.mli rename to src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.mli diff --git a/src/proto_008_PtEdoTez/lib_client/mockup.ml b/src/proto_008_PtEdo2Zk/lib_client/mockup.ml similarity index 99% rename from src/proto_008_PtEdoTez/lib_client/mockup.ml rename to src/proto_008_PtEdo2Zk/lib_client/mockup.ml index 1fa44f9512e3dfd22cc03316fdd84aae63451ad0..ed65bd8eb96c555954e2c1c6b045aa861c0793c4 100644 --- a/src/proto_008_PtEdoTez/lib_client/mockup.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/mockup.ml @@ -495,7 +495,7 @@ let () = module Protocol = Protocol_client_context.Lifted_protocol module Block_services = Protocol_client_context.Alpha_block_services - let directory = Protocol.rpc_services + let directory = Tezos_protocol_plugin_008_PtEdo2Zk.Plugin.RPC.rpc_services let init = mem_init end in diff --git a/src/proto_008_PtEdoTez/lib_client/operation_result.ml b/src/proto_008_PtEdo2Zk/lib_client/operation_result.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/operation_result.ml rename to src/proto_008_PtEdo2Zk/lib_client/operation_result.ml diff --git a/src/proto_008_PtEdoTez/lib_client/operation_result.mli b/src/proto_008_PtEdo2Zk/lib_client/operation_result.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/operation_result.mli rename to src/proto_008_PtEdo2Zk/lib_client/operation_result.mli diff --git a/src/proto_008_PtEdoTez/lib_client/protocol_client_context.ml b/src/proto_008_PtEdo2Zk/lib_client/protocol_client_context.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/protocol_client_context.ml rename to src/proto_008_PtEdo2Zk/lib_client/protocol_client_context.ml diff --git a/src/proto_008_PtEdoTez/lib_client/test/.ocamlformat b/src/proto_008_PtEdo2Zk/lib_client/test/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/test/.ocamlformat rename to src/proto_008_PtEdo2Zk/lib_client/test/.ocamlformat diff --git a/src/proto_008_PtEdoTez/lib_client/test/assert.ml b/src/proto_008_PtEdo2Zk/lib_client/test/assert.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/test/assert.ml rename to src/proto_008_PtEdo2Zk/lib_client/test/assert.ml diff --git a/src/proto_008_PtEdoTez/lib_client/test/dune b/src/proto_008_PtEdo2Zk/lib_client/test/dune similarity index 72% rename from src/proto_008_PtEdoTez/lib_client/test/dune rename to src/proto_008_PtEdo2Zk/lib_client/test/dune index e972c86904c4091633026c7821845785fe2485b0..45149bdf49c1588a88ef4513705311bbaa0ba01d 100644 --- a/src/proto_008_PtEdoTez/lib_client/test/dune +++ b/src/proto_008_PtEdo2Zk/lib_client/test/dune @@ -2,13 +2,13 @@ (names test_michelson_v1_macros) (libraries tezos-base tezos-micheline - tezos-protocol-008-PtEdoTez - tezos-client-008-PtEdoTez + tezos-protocol-008-PtEdo2Zk + tezos-client-008-PtEdo2Zk alcotest-lwt) (flags (:standard -open Tezos_base__TzPervasives -open Tezos_micheline - -open Tezos_client_008_PtEdoTez - -open Tezos_protocol_008_PtEdoTez))) + -open Tezos_client_008_PtEdo2Zk + -open Tezos_protocol_008_PtEdo2Zk))) (rule @@ -22,7 +22,7 @@ (rule (alias runtest) -(package tezos-client-008-PtEdoTez) +(package tezos-client-008-PtEdo2Zk) (deps (alias runtest_michelson_v1_macros)) (action (progn))) diff --git a/src/proto_008_PtEdoTez/lib_client/test/test_michelson_v1_macros.ml b/src/proto_008_PtEdo2Zk/lib_client/test/test_michelson_v1_macros.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client/test/test_michelson_v1_macros.ml rename to src/proto_008_PtEdo2Zk/lib_client/test/test_michelson_v1_macros.ml diff --git a/src/proto_008_PtEdoTez/lib_client/tezos-client-008-PtEdoTez.opam b/src/proto_008_PtEdo2Zk/lib_client/tezos-client-008-PtEdo2Zk.opam similarity index 85% rename from src/proto_008_PtEdoTez/lib_client/tezos-client-008-PtEdoTez.opam rename to src/proto_008_PtEdo2Zk/lib_client/tezos-client-008-PtEdo2Zk.opam index 83c8ca8b9ac3e9b940100e7097e14ca0a1803340..f2e5bf23bd5bf5a37dcfabf031ceb4530a21e999 100644 --- a/src/proto_008_PtEdoTez/lib_client/tezos-client-008-PtEdoTez.opam +++ b/src/proto_008_PtEdo2Zk/lib_client/tezos-client-008-PtEdo2Zk.opam @@ -10,12 +10,13 @@ depends: [ "dune" { >= "2.0" } "tezos-base" "tezos-protocol-environment" - "tezos-protocol-008-PtEdoTez" + "tezos-protocol-008-PtEdo2Zk" "tezos-shell-services" "tezos-client-base-unix" "tezos-mockup-registration" "tezos-signer-backends" - "tezos-protocol-008-PtEdoTez-parameters" + "tezos-protocol-008-PtEdo2Zk-parameters" + "tezos-protocol-plugin-008-PtEdo2Zk" "alcotest-lwt" { with-test & >= "1.1.0" } ] build: [ diff --git a/src/proto_008_PtEdoTez/lib_client_commands/.ocamlformat b/src/proto_008_PtEdo2Zk/lib_client_commands/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_commands/.ocamlformat rename to src/proto_008_PtEdo2Zk/lib_client_commands/.ocamlformat diff --git a/src/proto_008_PtEdoTez/lib_client_commands/alpha_commands_registration.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/alpha_commands_registration.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_commands/alpha_commands_registration.ml rename to src/proto_008_PtEdo2Zk/lib_client_commands/alpha_commands_registration.ml diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_context_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml similarity index 98% rename from src/proto_008_PtEdoTez/lib_client_commands/client_proto_context_commands.ml rename to src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml index ae254fc70d52d68a57c8926fd50ce33723e7f4d0..1cdaf361335b90e012ec806baf7185f86ac700b9 100644 --- a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml @@ -296,12 +296,16 @@ let commands network () = command ~group ~desc:"Get the storage of a contract." - no_options + (args1 (unparsing_mode_arg ~default:"Readable")) ( prefixes ["get"; "contract"; "storage"; "for"] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop ) - (fun () (_, contract) (cctxt : Protocol_client_context.full) -> - get_storage cctxt ~chain:cctxt#chain ~block:cctxt#block contract + (fun unparsing_mode (_, contract) (cctxt : Protocol_client_context.full) -> + Plugin.RPC.get_storage_normalized + cctxt + (cctxt#chain, cctxt#block) + ~contract + ~unparsing_mode >>=? function | None -> cctxt#error "This is not a smart contract." @@ -337,7 +341,7 @@ let commands network () = command ~group ~desc:"Get a value in a big map." - no_options + (args1 (unparsing_mode_arg ~default:"Readable")) ( prefixes ["get"; "element"] @@ Clic.param ~name:"key" @@ -350,25 +354,30 @@ let commands network () = ~desc:"identifier of the big_map" int_parameter @@ stop ) - (fun () key id (cctxt : Protocol_client_context.full) -> + (fun unparsing_mode key id (cctxt : Protocol_client_context.full) -> get_big_map_value cctxt ~chain:cctxt#chain ~block:cctxt#block (Big_map.Id.parse_z (Z.of_int id)) key + ~unparsing_mode >>=? fun value -> cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value >>= fun () -> return_unit); command ~group ~desc:"Get the code of a contract." - no_options + (args1 (unparsing_mode_arg ~default:"Readable")) ( prefixes ["get"; "contract"; "code"; "for"] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop ) - (fun () (_, contract) (cctxt : Protocol_client_context.full) -> - get_script cctxt ~chain:cctxt#chain ~block:cctxt#block contract + (fun unparsing_mode (_, contract) (cctxt : Protocol_client_context.full) -> + Plugin.RPC.get_script_normalized + cctxt + (cctxt#chain, cctxt#block) + ~contract + ~unparsing_mode >>=? function | None -> cctxt#error "This is not a smart contract." diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_contracts_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_contracts_commands.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_commands/client_proto_contracts_commands.ml rename to src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_contracts_commands.ml diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_mockup_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_mockup_commands.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_commands/client_proto_mockup_commands.ml rename to src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_mockup_commands.ml diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_mockup_commands.mli b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_mockup_commands.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_commands/client_proto_mockup_commands.mli rename to src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_mockup_commands.mli diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_multisig_commands.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_commands/client_proto_multisig_commands.ml rename to src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_multisig_commands.ml diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_multisig_commands.mli b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_multisig_commands.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_commands/client_proto_multisig_commands.mli rename to src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_multisig_commands.mli diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_programs_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.ml similarity index 89% rename from src/proto_008_PtEdoTez/lib_client_commands/client_proto_programs_commands.ml rename to src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.ml index c7bc31894536f42f115315e1c2384af82e2e0aca..909cbd91b890121ef4998c335cd53431aa29a945 100644 --- a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.ml @@ -220,7 +220,7 @@ let commands () = command ~group ~desc:"Ask the node to run a script." - (args8 + (args9 trace_stack_switch amount_arg balance_arg @@ -228,7 +228,8 @@ let commands () = payer_arg no_print_source_flag custom_gas_flag - entrypoint_arg) + entrypoint_arg + (unparsing_mode_arg ~default:"Readable")) ( prefixes ["run"; "script"] @@ Program.source_param @@ prefixes ["on"; "storage"] @@ -243,7 +244,8 @@ let commands () = payer, no_print_source, gas, - entrypoint ) + entrypoint, + unparsing_mode ) program storage input @@ -263,6 +265,7 @@ let commands () = ~program ~storage ~input + ~unparsing_mode ?source ?payer ?gas @@ -280,6 +283,7 @@ let commands () = ~program ~storage ~input + ~unparsing_mode ?source ?payer ?gas @@ -458,6 +462,95 @@ let commands () = | Some expr -> cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr >>= fun () -> return_unit); + command + ~group + ~desc:"Ask the node to normalize a data expression." + (args2 (unparsing_mode_arg ~default:"Readable") legacy_switch) + ( prefixes ["normalize"; "data"] + @@ param + ~name:"data" + ~desc:"the data expression to normalize" + data_parameter + @@ prefixes ["of"; "type"] + @@ param ~name:"type" ~desc:"type of the data expression" data_parameter + @@ stop ) + (fun (unparsing_mode, legacy) data typ cctxt -> + Plugin.RPC.normalize_data + cctxt + (cctxt#chain, cctxt#block) + ~legacy + ~data:data.expanded + ~ty:typ.expanded + ~unparsing_mode + >>= function + | Ok expr -> + cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr + >>= fun () -> return_unit + | Error errs -> + cctxt#warning + "%a" + (Michelson_v1_error_reporter.report_errors + ~details:false + ~show_source:false + ?parsed:None) + errs + >>= fun () -> cctxt#error "ill-typed data expression"); + command + ~group + ~desc:"Ask the node to normalize a Michelson script." + (args1 (unparsing_mode_arg ~default:"Readable")) + (prefixes ["normalize"; "script"] @@ Program.source_param @@ stop) + (fun unparsing_mode script cctxt -> + match script with + | (script, []) -> + Plugin.RPC.normalize_script + cctxt + (cctxt#chain, cctxt#block) + ~script:script.expanded + ~unparsing_mode + >>=? fun expr -> + cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr + >>= fun () -> return_unit + | (parsed, errors) -> + cctxt#message + "%a" + (fun ppf () -> + Michelson_v1_error_reporter.report_errors + ~details:true + ~parsed + ~show_source:true + ppf + errors) + () + >>= fun () -> cctxt#error "syntax error in program"); + command + ~group + ~desc:"Ask the node to normalize a type." + no_options + ( prefixes ["normalize"; "type"] + @@ param + ~name:"typ" + ~desc:"the Michelson type to normalize" + data_parameter + @@ stop ) + (fun () typ cctxt -> + Plugin.RPC.normalize_type + cctxt + (cctxt#chain, cctxt#block) + ~ty:typ.expanded + >>= function + | Ok expr -> + cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr + >>= fun () -> return_unit + | Error errs -> + cctxt#warning + "%a" + (Michelson_v1_error_reporter.report_errors + ~details:false + ~show_source:false + ?parsed:None) + errs + >>= fun () -> cctxt#error "ill-formed type"); command ~group ~desc: diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_programs_commands.mli b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_commands/client_proto_programs_commands.mli rename to src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.mli diff --git a/src/proto_008_PtEdoTez/lib_client_commands/dune b/src/proto_008_PtEdo2Zk/lib_client_commands/dune similarity index 50% rename from src/proto_008_PtEdoTez/lib_client_commands/dune rename to src/proto_008_PtEdo2Zk/lib_client_commands/dune index d43f79cbb90403a28047c6e4c964c2f7977b2865..8c832520c7d2131987ced9111c0e29e429bc94f5 100644 --- a/src/proto_008_PtEdoTez/lib_client_commands/dune +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/dune @@ -1,52 +1,56 @@ (library - (name tezos_client_008_PtEdoTez_commands) - (public_name tezos-client-008-PtEdoTez-commands) + (name tezos_client_008_PtEdo2Zk_commands) + (public_name tezos-client-008-PtEdo2Zk-commands) (libraries tezos-base tezos-stdlib-unix - tezos-protocol-008-PtEdoTez + tezos-protocol-008-PtEdo2Zk tezos-protocol-environment tezos-shell-services tezos-mockup tezos-mockup-registration tezos-mockup-commands - tezos-client-008-PtEdoTez + tezos-client-008-PtEdo2Zk tezos-client-commands - tezos-rpc) + tezos-rpc + tezos-protocol-plugin-008-PtEdo2Zk) (library_flags (:standard -linkall)) (modules (:standard \ alpha_commands_registration)) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_008_PtEdoTez + -open Tezos_protocol_008_PtEdo2Zk -open Tezos_stdlib_unix -open Tezos_shell_services -open Tezos_client_base - -open Tezos_client_008_PtEdoTez + -open Tezos_client_008_PtEdo2Zk -open Tezos_client_commands - -open Tezos_rpc))) + -open Tezos_rpc + -open Tezos_protocol_plugin_008_PtEdo2Zk))) (library - (name tezos_client_008_PtEdoTez_commands_registration) - (public_name tezos-client-008-PtEdoTez-commands-registration) + (name tezos_client_008_PtEdo2Zk_commands_registration) + (public_name tezos-client-008-PtEdo2Zk-commands-registration) (libraries tezos-base - tezos-protocol-008-PtEdoTez + tezos-protocol-008-PtEdo2Zk tezos-protocol-environment tezos-shell-services tezos-client-base - tezos-client-008-PtEdoTez + tezos-client-008-PtEdo2Zk tezos-client-commands - tezos-client-008-PtEdoTez-commands - tezos-client-sapling-008-PtEdoTez - tezos-rpc) + tezos-client-008-PtEdo2Zk-commands + tezos-client-sapling-008-PtEdo2Zk + tezos-rpc + tezos-protocol-plugin-008-PtEdo2Zk) (library_flags (:standard -linkall)) (modules alpha_commands_registration) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_008_PtEdoTez + -open Tezos_protocol_008_PtEdo2Zk -open Tezos_shell_services -open Tezos_client_base - -open Tezos_client_008_PtEdoTez + -open Tezos_client_008_PtEdo2Zk -open Tezos_client_commands - -open Tezos_client_008_PtEdoTez_commands - -open Tezos_client_sapling_008_PtEdoTez - -open Tezos_rpc))) + -open Tezos_client_008_PtEdo2Zk_commands + -open Tezos_client_sapling_008_PtEdo2Zk + -open Tezos_rpc + -open Tezos_protocol_plugin_008_PtEdo2Zk))) (rule (alias runtest_lint) diff --git a/src/proto_008_PtEdoTez/lib_client_commands/dune-project b/src/proto_008_PtEdo2Zk/lib_client_commands/dune-project similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_commands/dune-project rename to src/proto_008_PtEdo2Zk/lib_client_commands/dune-project diff --git a/src/proto_008_PtEdoTez/lib_client_commands/tezos-client-008-PtEdoTez-commands-registration.opam b/src/proto_008_PtEdo2Zk/lib_client_commands/tezos-client-008-PtEdo2Zk-commands-registration.opam similarity index 81% rename from src/proto_008_PtEdoTez/lib_client_commands/tezos-client-008-PtEdoTez-commands-registration.opam rename to src/proto_008_PtEdo2Zk/lib_client_commands/tezos-client-008-PtEdo2Zk-commands-registration.opam index d3c3f88fda002f0bc9ad2ce4063aeb505e9451e2..eb4b2a9d3d3d66aafc8a90501e9f36c6241822e0 100644 --- a/src/proto_008_PtEdoTez/lib_client_commands/tezos-client-008-PtEdoTez-commands-registration.opam +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/tezos-client-008-PtEdo2Zk-commands-registration.opam @@ -10,12 +10,12 @@ depends: [ "dune" { >= "2.0" } "tezos-base" "tezos-protocol-environment" - "tezos-protocol-008-PtEdoTez" + "tezos-protocol-008-PtEdo2Zk" "tezos-shell-services" "tezos-client-base" - "tezos-client-008-PtEdoTez" - "tezos-client-008-PtEdoTez-commands" - "tezos-client-sapling-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" + "tezos-client-008-PtEdo2Zk-commands" + "tezos-client-sapling-008-PtEdo2Zk" "tezos-client-commands" ] build: [ diff --git a/src/proto_008_PtEdoTez/lib_client_commands/tezos-client-008-PtEdoTez-commands.opam b/src/proto_008_PtEdo2Zk/lib_client_commands/tezos-client-008-PtEdo2Zk-commands.opam similarity index 90% rename from src/proto_008_PtEdoTez/lib_client_commands/tezos-client-008-PtEdoTez-commands.opam rename to src/proto_008_PtEdo2Zk/lib_client_commands/tezos-client-008-PtEdo2Zk-commands.opam index 2f576f43b473e64cb5a8577e2ca7984a7412c0cb..80de5f365119b2115850f8089cdbba289b3c10e3 100644 --- a/src/proto_008_PtEdoTez/lib_client_commands/tezos-client-008-PtEdoTez-commands.opam +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/tezos-client-008-PtEdo2Zk-commands.opam @@ -10,10 +10,10 @@ depends: [ "dune" { >= "2.0" } "tezos-base" "tezos-protocol-environment" - "tezos-protocol-008-PtEdoTez" + "tezos-protocol-008-PtEdo2Zk" "tezos-shell-services" "tezos-client-base-unix" - "tezos-client-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" "tezos-client-commands" ] build: [ diff --git a/src/proto_008_PtEdoTez/lib_client_sapling/.ocamlformat b/src/proto_008_PtEdo2Zk/lib_client_sapling/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_sapling/.ocamlformat rename to src/proto_008_PtEdo2Zk/lib_client_sapling/.ocamlformat diff --git a/src/proto_008_PtEdoTez/lib_client_sapling/client_sapling_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.ml similarity index 99% rename from src/proto_008_PtEdoTez/lib_client_sapling/client_sapling_commands.ml rename to src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.ml index f089cbf09b5e38bfc8dcb3d9eee0f66c51710ebe..fd8680ded472ecb37e61e583bd345bc04a9c42fc 100644 --- a/src/proto_008_PtEdoTez/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.ml @@ -22,7 +22,7 @@ open Clic open Client_keys -open Sapling.Core.Client +open Tezos_sapling.Core.Client let json_switch = switch ~long:"json" ~doc:"Use JSON format" () diff --git a/src/proto_008_PtEdoTez/lib_client_sapling/client_sapling_commands.mli b/src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_sapling/client_sapling_commands.mli rename to src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.mli diff --git a/src/proto_008_PtEdoTez/lib_client_sapling/context.ml b/src/proto_008_PtEdo2Zk/lib_client_sapling/context.ml similarity index 99% rename from src/proto_008_PtEdoTez/lib_client_sapling/context.ml rename to src/proto_008_PtEdo2Zk/lib_client_sapling/context.ml index 02f4a1ca3b793f948050d1a9b2f735f84a5b5f15..700e2c3343a60cb22e867b732632691d96fe9cf9 100644 --- a/src/proto_008_PtEdoTez/lib_client_sapling/context.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_sapling/context.ml @@ -20,7 +20,7 @@ * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. *) -open Sapling.Core.Client +open Tezos_sapling.Core.Client let _ = Random.self_init () @@ -158,8 +158,8 @@ let () = | Balance_too_low (balance, amount) -> Some (balance, amount) | _ -> None) (fun (balance, amount) -> Balance_too_low (balance, amount)) -module Storage = Sapling.Storage -module F = Sapling.Forge +module Storage = Tezos_sapling.Storage +module F = Tezos_sapling.Forge module Input_set = struct include Set.Make (F.Input) @@ -350,7 +350,7 @@ module Contract_state = struct let update_storage contract_state (root, diff) = let open Protocol.Alpha_context.Sapling in let storage = - Sapling.Storage.add + Tezos_sapling.Storage.add contract_state.storage diff.commitments_and_ciphertexts in diff --git a/src/proto_008_PtEdoTez/lib_client_sapling/context.mli b/src/proto_008_PtEdo2Zk/lib_client_sapling/context.mli similarity index 99% rename from src/proto_008_PtEdoTez/lib_client_sapling/context.mli rename to src/proto_008_PtEdo2Zk/lib_client_sapling/context.mli index 88f53678b358c471edfde17d19d731ddd130891d..72963733eb7c0732c740bb32c0790015fe5f2276 100644 --- a/src/proto_008_PtEdoTez/lib_client_sapling/context.mli +++ b/src/proto_008_PtEdo2Zk/lib_client_sapling/context.mli @@ -30,7 +30,7 @@ from the last scanned state. *) -open Sapling.Core.Client +open Tezos_sapling.Core.Client module Tez : module type of Protocol.Alpha_context.Tez diff --git a/src/proto_008_PtEdo2Zk/lib_client_sapling/dune b/src/proto_008_PtEdo2Zk/lib_client_sapling/dune new file mode 100644 index 0000000000000000000000000000000000000000..998548d4eac340bd427c046ceaa9fdf84c2b1f82 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_client_sapling/dune @@ -0,0 +1,23 @@ +(library + (name tezos_client_sapling_008_PtEdo2Zk) + (public_name tezos-client-sapling-008-PtEdo2Zk) + (libraries tezos-base + tezos-crypto + tezos-client-base + tezos-signer-backends + tezos-client-008-PtEdo2Zk + tezos-client-008-PtEdo2Zk-commands + tezos-protocol-008-PtEdo2Zk) + (library_flags (:standard -linkall)) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_stdlib_unix + -open Tezos_client_base + -open Tezos_client_008_PtEdo2Zk + -open Tezos_client_008_PtEdo2Zk_commands + -open Tezos_protocol_008_PtEdo2Zk + -open Tezos_protocol_environment_008_PtEdo2Zk))) + +(alias + (name runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/proto_008_PtEdoTez/lib_client_sapling/dune-project b/src/proto_008_PtEdo2Zk/lib_client_sapling/dune-project similarity index 100% rename from src/proto_008_PtEdoTez/lib_client_sapling/dune-project rename to src/proto_008_PtEdo2Zk/lib_client_sapling/dune-project diff --git a/src/proto_008_PtEdoTez/lib_client_sapling/tezos-client-sapling-008-PtEdoTez.opam b/src/proto_008_PtEdo2Zk/lib_client_sapling/tezos-client-sapling-008-PtEdo2Zk.opam similarity index 85% rename from src/proto_008_PtEdoTez/lib_client_sapling/tezos-client-sapling-008-PtEdoTez.opam rename to src/proto_008_PtEdo2Zk/lib_client_sapling/tezos-client-sapling-008-PtEdo2Zk.opam index d7a5015f7e8f37bfdc7376acb0ba1bc4154080ed..e554a2c9ec84cbce40893024d00f0da58edb60ba 100644 --- a/src/proto_008_PtEdoTez/lib_client_sapling/tezos-client-sapling-008-PtEdoTez.opam +++ b/src/proto_008_PtEdo2Zk/lib_client_sapling/tezos-client-sapling-008-PtEdo2Zk.opam @@ -14,9 +14,9 @@ depends: [ "tezos-crypto" "tezos-client-base" "tezos-signer-backends" - "tezos-client-008-PtEdoTez" - "tezos-client-008-PtEdoTez-commands" - "tezos-protocol-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" + "tezos-client-008-PtEdo2Zk-commands" + "tezos-protocol-008-PtEdo2Zk" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/proto_008_PtEdoTez/lib_client_sapling/wallet.ml b/src/proto_008_PtEdo2Zk/lib_client_sapling/wallet.ml similarity index 99% rename from src/proto_008_PtEdoTez/lib_client_sapling/wallet.ml rename to src/proto_008_PtEdo2Zk/lib_client_sapling/wallet.ml index 8a81b76d1d6cdf39025b2e1b4aa7510770f0ce73..df6295ec16b7490a847c28838a2372f4aa3e2aa0 100644 --- a/src/proto_008_PtEdoTez/lib_client_sapling/wallet.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_sapling/wallet.ml @@ -21,7 +21,7 @@ * SOFTWARE. *) open Client_keys -open Sapling.Core.Client +open Tezos_sapling.Core.Client module Mnemonic = struct let new_random = Bip39.of_entropy (Hacl.Rand.gen 32) diff --git a/src/proto_008_PtEdoTez/lib_client_sapling/wallet.mli b/src/proto_008_PtEdo2Zk/lib_client_sapling/wallet.mli similarity index 98% rename from src/proto_008_PtEdoTez/lib_client_sapling/wallet.mli rename to src/proto_008_PtEdo2Zk/lib_client_sapling/wallet.mli index 2d5483a42c877f75283be8e48ec5c33cbb826b0e..17e0e59d0af4acfdd6d415ed53c2f593d357d9b8 100644 --- a/src/proto_008_PtEdoTez/lib_client_sapling/wallet.mli +++ b/src/proto_008_PtEdo2Zk/lib_client_sapling/wallet.mli @@ -20,7 +20,7 @@ * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * SOFTWARE. *) -open Sapling.Core.Client +open Tezos_sapling.Core.Client (** Mnemonic of 24 common english words from which a key can be derived. The mnemonic follows the BIP-39 spec. *) diff --git a/src/proto_008_PtEdoTez/lib_delegate/.ocamlformat b/src/proto_008_PtEdo2Zk/lib_delegate/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/.ocamlformat rename to src/proto_008_PtEdo2Zk/lib_delegate/.ocamlformat diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_blocks.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_blocks.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_blocks.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_blocks.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_blocks.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_blocks.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_blocks.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_blocks.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_denunciation.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_denunciation.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_denunciation.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_denunciation.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_denunciation.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_denunciation.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_denunciation.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_denunciation.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_endorsement.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_endorsement.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_endorsement.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_endorsement.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_endorsement.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_endorsement.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_endorsement.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_endorsement.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_files.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_files.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_files.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_files.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_files.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_files.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_files.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_files.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_forge.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_forge.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_forge.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_forge.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_highwatermarks.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_highwatermarks.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_highwatermarks.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_highwatermarks.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_highwatermarks.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_highwatermarks.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_highwatermarks.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_highwatermarks.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_lib.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_lib.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_lib.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_lib.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_lib.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_lib.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_lib.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_lib.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_nonces.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_nonces.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_nonces.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_nonces.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_nonces.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_nonces.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_nonces.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_nonces.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_pow.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_pow.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_pow.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_pow.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_pow.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_pow.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_pow.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_pow.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_revelation.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_revelation.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_revelation.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_revelation.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_revelation.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_revelation.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_revelation.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_revelation.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_scheduling.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_scheduling.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_scheduling.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_scheduling.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_scheduling.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_scheduling.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_scheduling.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_scheduling.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_simulator.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_simulator.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_simulator.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_simulator.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_simulator.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_baking_simulator.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_baking_simulator.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_baking_simulator.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_daemon.ml b/src/proto_008_PtEdo2Zk/lib_delegate/client_daemon.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_daemon.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/client_daemon.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_daemon.mli b/src/proto_008_PtEdo2Zk/lib_delegate/client_daemon.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/client_daemon.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/client_daemon.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/delegate_commands.ml b/src/proto_008_PtEdo2Zk/lib_delegate/delegate_commands.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/delegate_commands.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/delegate_commands.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/delegate_commands.mli b/src/proto_008_PtEdo2Zk/lib_delegate/delegate_commands.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/delegate_commands.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/delegate_commands.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/delegate_commands_registration.ml b/src/proto_008_PtEdo2Zk/lib_delegate/delegate_commands_registration.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/delegate_commands_registration.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/delegate_commands_registration.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/dune b/src/proto_008_PtEdo2Zk/lib_delegate/dune similarity index 64% rename from src/proto_008_PtEdoTez/lib_delegate/dune rename to src/proto_008_PtEdo2Zk/lib_delegate/dune index d8a8517f93e4eb3c62c1638fbdce178bbcea6b19..18cadaf860d4a342537d8cd894f6c82be23fefc8 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/dune +++ b/src/proto_008_PtEdo2Zk/lib_delegate/dune @@ -1,14 +1,14 @@ (library - (name tezos_baking_008_PtEdoTez) - (public_name tezos-baking-008-PtEdoTez) + (name tezos_baking_008_PtEdo2Zk) + (public_name tezos-baking-008-PtEdo2Zk) (libraries tezos-base tezos-version - tezos-protocol-008-PtEdoTez + tezos-protocol-008-PtEdo2Zk tezos-protocol-environment tezos-shell-context tezos-shell-services tezos-client-base - tezos-client-008-PtEdoTez + tezos-client-008-PtEdo2Zk tezos-client-commands tezos-stdlib-unix tezos-storage @@ -20,10 +20,10 @@ delegate_commands delegate_commands_registration)) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_008_PtEdoTez + -open Tezos_protocol_008_PtEdo2Zk -open Tezos_shell_services -open Tezos_client_base - -open Tezos_client_008_PtEdoTez + -open Tezos_client_008_PtEdo2Zk -open Tezos_client_commands -open Tezos_stdlib_unix -open Tezos_shell_context @@ -32,51 +32,51 @@ -open Tezos_rpc_http))) (library - (name tezos_baking_008_PtEdoTez_commands) - (public_name tezos-baking-008-PtEdoTez-commands) + (name tezos_baking_008_PtEdo2Zk_commands) + (public_name tezos-baking-008-PtEdo2Zk-commands) (libraries tezos-base - tezos-protocol-008-PtEdoTez + tezos-protocol-008-PtEdo2Zk tezos-protocol-environment tezos-shell-services tezos-client-base - tezos-client-008-PtEdoTez + tezos-client-008-PtEdo2Zk tezos-client-commands - tezos-baking-008-PtEdoTez) + tezos-baking-008-PtEdo2Zk) (library_flags (:standard -linkall)) (modules delegate_commands) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_008_PtEdoTez + -open Tezos_protocol_008_PtEdo2Zk -open Tezos_stdlib_unix -open Tezos_shell_services -open Tezos_client_base - -open Tezos_client_008_PtEdoTez + -open Tezos_client_008_PtEdo2Zk -open Tezos_client_commands - -open Tezos_baking_008_PtEdoTez + -open Tezos_baking_008_PtEdo2Zk -open Tezos_rpc))) (library - (name tezos_baking_008_PtEdoTez_commands_registration) - (public_name tezos-baking-008-PtEdoTez-commands.registration) + (name tezos_baking_008_PtEdo2Zk_commands_registration) + (public_name tezos-baking-008-PtEdo2Zk-commands.registration) (libraries tezos-base - tezos-protocol-008-PtEdoTez + tezos-protocol-008-PtEdo2Zk tezos-protocol-environment tezos-shell-services tezos-client-base - tezos-client-008-PtEdoTez + tezos-client-008-PtEdo2Zk tezos-client-commands - tezos-baking-008-PtEdoTez - tezos-baking-008-PtEdoTez-commands + tezos-baking-008-PtEdo2Zk + tezos-baking-008-PtEdo2Zk-commands tezos-rpc) (library_flags (:standard -linkall)) (modules delegate_commands_registration) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_008_PtEdoTez + -open Tezos_protocol_008_PtEdo2Zk -open Tezos_shell_services -open Tezos_client_base - -open Tezos_client_008_PtEdoTez + -open Tezos_client_008_PtEdo2Zk -open Tezos_client_commands - -open Tezos_baking_008_PtEdoTez - -open Tezos_baking_008_PtEdoTez_commands + -open Tezos_baking_008_PtEdo2Zk + -open Tezos_baking_008_PtEdo2Zk_commands -open Tezos_rpc))) (rule diff --git a/src/proto_008_PtEdoTez/lib_delegate/dune-project b/src/proto_008_PtEdo2Zk/lib_delegate/dune-project similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/dune-project rename to src/proto_008_PtEdo2Zk/lib_delegate/dune-project diff --git a/src/proto_008_PtEdoTez/lib_delegate/logging.ml b/src/proto_008_PtEdo2Zk/lib_delegate/logging.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/logging.ml rename to src/proto_008_PtEdo2Zk/lib_delegate/logging.ml diff --git a/src/proto_008_PtEdoTez/lib_delegate/logging.mli b/src/proto_008_PtEdo2Zk/lib_delegate/logging.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_delegate/logging.mli rename to src/proto_008_PtEdo2Zk/lib_delegate/logging.mli diff --git a/src/proto_008_PtEdoTez/lib_delegate/tezos-accuser-008-PtEdoTez-commands.opam b/src/proto_008_PtEdo2Zk/lib_delegate/tezos-accuser-008-PtEdo2Zk-commands.opam similarity index 86% rename from src/proto_008_PtEdoTez/lib_delegate/tezos-accuser-008-PtEdoTez-commands.opam rename to src/proto_008_PtEdo2Zk/lib_delegate/tezos-accuser-008-PtEdo2Zk-commands.opam index 3e8d42431e840b146a74d8bc50da9289103835ee..7992402ca17a38aeae09dc249e95f8dc6095485a 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/tezos-accuser-008-PtEdoTez-commands.opam +++ b/src/proto_008_PtEdo2Zk/lib_delegate/tezos-accuser-008-PtEdo2Zk-commands.opam @@ -10,12 +10,12 @@ depends: [ "dune" { >= "2.0" } "tezos-base" "tezos-protocol-environment" - "tezos-protocol-008-PtEdoTez" + "tezos-protocol-008-PtEdo2Zk" "tezos-shell-services" "tezos-client-base" "tezos-client-commands" - "tezos-client-008-PtEdoTez" - "tezos-baking-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" + "tezos-baking-008-PtEdo2Zk" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/proto_008_PtEdoTez/lib_delegate/tezos-baking-008-PtEdoTez-commands.opam b/src/proto_008_PtEdo2Zk/lib_delegate/tezos-baking-008-PtEdo2Zk-commands.opam similarity index 86% rename from src/proto_008_PtEdoTez/lib_delegate/tezos-baking-008-PtEdoTez-commands.opam rename to src/proto_008_PtEdo2Zk/lib_delegate/tezos-baking-008-PtEdo2Zk-commands.opam index f0b34b539b543e94a8ae7c11616b28c60c3a01f7..e9392b48bc8a0e5e002b70d5d2ed5e62a8831da3 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/tezos-baking-008-PtEdoTez-commands.opam +++ b/src/proto_008_PtEdo2Zk/lib_delegate/tezos-baking-008-PtEdo2Zk-commands.opam @@ -10,13 +10,13 @@ depends: [ "dune" { >= "2.0" } "tezos-base" "tezos-protocol-environment" - "tezos-protocol-008-PtEdoTez" + "tezos-protocol-008-PtEdo2Zk" "tezos-shell-services" "tezos-shell-context" "tezos-client-base" "tezos-client-commands" - "tezos-client-008-PtEdoTez" - "tezos-baking-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" + "tezos-baking-008-PtEdo2Zk" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/proto_008_PtEdoTez/lib_delegate/tezos-baking-008-PtEdoTez.opam b/src/proto_008_PtEdo2Zk/lib_delegate/tezos-baking-008-PtEdo2Zk.opam similarity index 91% rename from src/proto_008_PtEdoTez/lib_delegate/tezos-baking-008-PtEdoTez.opam rename to src/proto_008_PtEdo2Zk/lib_delegate/tezos-baking-008-PtEdo2Zk.opam index 67e51fc854ce30272d0fad1c47f6b46187ad0f36..9a55ca9295a7c1f13d0de3170f7803360bb192a4 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/tezos-baking-008-PtEdoTez.opam +++ b/src/proto_008_PtEdo2Zk/lib_delegate/tezos-baking-008-PtEdo2Zk.opam @@ -11,12 +11,12 @@ depends: [ "tezos-base" "tezos-version" "tezos-protocol-environment" - "tezos-protocol-008-PtEdoTez" + "tezos-protocol-008-PtEdo2Zk" "tezos-shell-context" "tezos-shell-services" "tezos-client-base" "tezos-client-commands" - "tezos-client-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" "lwt-canceler" { = "0.2" } ] build: [ diff --git a/src/proto_008_PtEdoTez/lib_delegate/tezos-endorser-008-PtEdoTez-commands.opam b/src/proto_008_PtEdo2Zk/lib_delegate/tezos-endorser-008-PtEdo2Zk-commands.opam similarity index 86% rename from src/proto_008_PtEdoTez/lib_delegate/tezos-endorser-008-PtEdoTez-commands.opam rename to src/proto_008_PtEdo2Zk/lib_delegate/tezos-endorser-008-PtEdo2Zk-commands.opam index 67e05aa835e689696323d4c40c63095b61a3784f..e9b6b9741e21a63375040d742287e27929bc6b06 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/tezos-endorser-008-PtEdoTez-commands.opam +++ b/src/proto_008_PtEdo2Zk/lib_delegate/tezos-endorser-008-PtEdo2Zk-commands.opam @@ -10,12 +10,12 @@ depends: [ "dune" { >= "2.0" } "tezos-base" "tezos-protocol-environment" - "tezos-protocol-008-PtEdoTez" + "tezos-protocol-008-PtEdo2Zk" "tezos-shell-services" "tezos-client-base" "tezos-client-commands" - "tezos-client-008-PtEdoTez" - "tezos-baking-008-PtEdoTez" + "tezos-client-008-PtEdo2Zk" + "tezos-baking-008-PtEdo2Zk" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/proto_008_PtEdoTez/lib_mempool/.ocamlformat b/src/proto_008_PtEdo2Zk/lib_parameters/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/lib_mempool/.ocamlformat rename to src/proto_008_PtEdo2Zk/lib_parameters/.ocamlformat diff --git a/src/proto_008_PtEdoTez/lib_parameters/default_parameters.ml b/src/proto_008_PtEdo2Zk/lib_parameters/default_parameters.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_parameters/default_parameters.ml rename to src/proto_008_PtEdo2Zk/lib_parameters/default_parameters.ml diff --git a/src/proto_008_PtEdoTez/lib_parameters/default_parameters.mli b/src/proto_008_PtEdo2Zk/lib_parameters/default_parameters.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_parameters/default_parameters.mli rename to src/proto_008_PtEdo2Zk/lib_parameters/default_parameters.mli diff --git a/src/proto_008_PtEdoTez/lib_parameters/dune b/src/proto_008_PtEdo2Zk/lib_parameters/dune similarity index 72% rename from src/proto_008_PtEdoTez/lib_parameters/dune rename to src/proto_008_PtEdo2Zk/lib_parameters/dune index cab543c4e7b76918c99b87ad5561e248cde55688..c660e8fe8d1f9b5e7c125a33135d634de11a9991 100644 --- a/src/proto_008_PtEdoTez/lib_parameters/dune +++ b/src/proto_008_PtEdo2Zk/lib_parameters/dune @@ -1,22 +1,22 @@ (library - (name tezos_protocol_008_PtEdoTez_parameters) - (public_name tezos-protocol-008-PtEdoTez-parameters) + (name tezos_protocol_008_PtEdo2Zk_parameters) + (public_name tezos-protocol-008-PtEdo2Zk-parameters) (modules :standard \ gen) (libraries tezos-base tezos-protocol-environment - tezos-protocol-008-PtEdoTez) + tezos-protocol-008-PtEdo2Zk) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_008_PtEdoTez + -open Tezos_protocol_008_PtEdo2Zk -linkall)) ) (executable (name gen) (libraries tezos-base - tezos-protocol-008-PtEdoTez-parameters) + tezos-protocol-008-PtEdo2Zk-parameters) (modules gen) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_008_PtEdoTez_parameters + -open Tezos_protocol_008_PtEdo2Zk_parameters -linkall))) (rule diff --git a/src/proto_008_PtEdoTez/lib_parameters/dune-project b/src/proto_008_PtEdo2Zk/lib_parameters/dune-project similarity index 100% rename from src/proto_008_PtEdoTez/lib_parameters/dune-project rename to src/proto_008_PtEdo2Zk/lib_parameters/dune-project diff --git a/src/proto_008_PtEdoTez/lib_parameters/gen.ml b/src/proto_008_PtEdo2Zk/lib_parameters/gen.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_parameters/gen.ml rename to src/proto_008_PtEdo2Zk/lib_parameters/gen.ml diff --git a/src/proto_008_PtEdoTez/lib_parameters/tezos-protocol-008-PtEdoTez-parameters.opam b/src/proto_008_PtEdo2Zk/lib_parameters/tezos-protocol-008-PtEdo2Zk-parameters.opam similarity index 93% rename from src/proto_008_PtEdoTez/lib_parameters/tezos-protocol-008-PtEdoTez-parameters.opam rename to src/proto_008_PtEdo2Zk/lib_parameters/tezos-protocol-008-PtEdo2Zk-parameters.opam index 0e8fe3dc4a5ba87105034d299422bfd90adcd4ac..ad8a7fbaa4f71147bef733d8800ef7a71c5a3957 100644 --- a/src/proto_008_PtEdoTez/lib_parameters/tezos-protocol-008-PtEdoTez-parameters.opam +++ b/src/proto_008_PtEdo2Zk/lib_parameters/tezos-protocol-008-PtEdo2Zk-parameters.opam @@ -10,7 +10,7 @@ depends: [ "dune" { >= "2.0" } "tezos-base" "tezos-protocol-environment" - "tezos-protocol-008-PtEdoTez" + "tezos-protocol-008-PtEdo2Zk" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/proto_008_PtEdoTez/lib_parameters/.ocamlformat b/src/proto_008_PtEdo2Zk/lib_plugin/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/lib_parameters/.ocamlformat rename to src/proto_008_PtEdo2Zk/lib_plugin/.ocamlformat diff --git a/src/proto_008_PtEdo2Zk/lib_plugin/dune b/src/proto_008_PtEdo2Zk/lib_plugin/dune new file mode 100644 index 0000000000000000000000000000000000000000..3de457735e51d121fdd291b0d9319cf32725f079 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_plugin/dune @@ -0,0 +1,26 @@ +(library + (name tezos_protocol_plugin_008_PtEdo2Zk) + (public_name tezos-protocol-plugin-008-PtEdo2Zk) + (libraries tezos-base + tezos-embedded-protocol-008-PtEdo2Zk + tezos-protocol-008-PtEdo2Zk) + (modules (:standard) \ Registerer) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_embedded_protocol_008_PtEdo2Zk + -open Tezos_protocol_008_PtEdo2Zk))) + +(library + (name tezos_protocol_plugin_008_PtEdo2Zk_registerer) + (public_name tezos-protocol-plugin-008-PtEdo2Zk-registerer) + (libraries tezos-base + tezos-protocol-plugin-008-PtEdo2Zk + tezos-shell) + (modules Registerer) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_protocol_plugin_008_PtEdo2Zk + -open Tezos_shell))) + +(rule + (alias runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/proto_008_PtEdoTez/lib_mempool/dune-project b/src/proto_008_PtEdo2Zk/lib_plugin/dune-project similarity index 59% rename from src/proto_008_PtEdoTez/lib_mempool/dune-project rename to src/proto_008_PtEdo2Zk/lib_plugin/dune-project index bc94cade5507d0c943485da90119539302a6031c..63ca57ade64cba718e9f0e23647c81204f53bfcb 100644 --- a/src/proto_008_PtEdoTez/lib_mempool/dune-project +++ b/src/proto_008_PtEdo2Zk/lib_plugin/dune-project @@ -1,3 +1,3 @@ (lang dune 2.0) (formatting (enabled_for ocaml)) -(name tezos-mempool-alpha) +(name tezos-filters-008-PtEdo2Zk) diff --git a/src/proto_008_PtEdo2Zk/lib_plugin/plugin.ml b/src/proto_008_PtEdo2Zk/lib_plugin/plugin.ml new file mode 100644 index 0000000000000000000000000000000000000000..2e4a232a718de82eaacf59c73cd354b6599c5f6a --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_plugin/plugin.ml @@ -0,0 +1,1018 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Nomadic Development. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +module Proto = Registerer.Registered + +module Mempool = struct + type nanotez = Q.t + + let nanotez_enc : nanotez Data_encoding.t = + let open Data_encoding in + def + "nanotez" + ~title:"A thousandth of a mutez" + ~description:"One thousand nanotez make a mutez (1 tez = 1e9 nanotez)" + (conv + (fun q -> (q.Q.num, q.Q.den)) + (fun (num, den) -> {Q.num; den}) + (tup2 z z)) + + type config = { + minimal_fees : Tez.t; + minimal_nanotez_per_gas_unit : nanotez; + minimal_nanotez_per_byte : nanotez; + allow_script_failure : bool; + } + + let default_minimal_fees = + match Tez.of_mutez 100L with None -> assert false | Some t -> t + + let default_minimal_nanotez_per_gas_unit = Q.of_int 100 + + let default_minimal_nanotez_per_byte = Q.of_int 1000 + + let config_encoding : config Data_encoding.t = + let open Data_encoding in + conv + (fun { minimal_fees; + minimal_nanotez_per_gas_unit; + minimal_nanotez_per_byte; + allow_script_failure } -> + ( minimal_fees, + minimal_nanotez_per_gas_unit, + minimal_nanotez_per_byte, + allow_script_failure )) + (fun ( minimal_fees, + minimal_nanotez_per_gas_unit, + minimal_nanotez_per_byte, + allow_script_failure ) -> + { + minimal_fees; + minimal_nanotez_per_gas_unit; + minimal_nanotez_per_byte; + allow_script_failure; + }) + (obj4 + (dft "minimal_fees" Tez.encoding default_minimal_fees) + (dft + "minimal_nanotez_per_gas_unit" + nanotez_enc + default_minimal_nanotez_per_gas_unit) + (dft + "minimal_nanotez_per_byte" + nanotez_enc + default_minimal_nanotez_per_byte) + (dft "allow_script_failure" bool true)) + + let default_config = + { + minimal_fees = default_minimal_fees; + minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit; + minimal_nanotez_per_byte = default_minimal_nanotez_per_byte; + allow_script_failure = true; + } + + let get_manager_operation_gas_and_fee contents = + let open Operation in + let l = to_list (Contents_list contents) in + List.fold_left + (fun acc -> function + | Contents (Manager_operation {fee; gas_limit; _}) -> ( + match acc with + | Error _ as e -> + e + | Ok (total_fee, total_gas) -> ( + match Tez.(total_fee +? fee) with + | Ok total_fee -> + Ok (total_fee, Gas.Arith.add total_gas gas_limit) + | Error _ as e -> + e ) ) | _ -> acc) + (Ok (Tez.zero, Gas.Arith.zero)) + l + + let pre_filter_manager : + type t. config -> t Kind.manager contents_list -> int -> bool = + fun config op size -> + match get_manager_operation_gas_and_fee op with + | Error _ -> + false + | Ok (fee, gas) -> + let fees_in_nanotez = + Q.mul (Q.of_int64 (Tez.to_mutez fee)) (Q.of_int 1000) + in + let minimal_fees_in_nanotez = + Q.mul (Q.of_int64 (Tez.to_mutez config.minimal_fees)) (Q.of_int 1000) + in + let minimal_fees_for_gas_in_nanotez = + Q.mul + config.minimal_nanotez_per_gas_unit + (Q.of_bigint @@ Gas.Arith.integral_to_z gas) + in + let minimal_fees_for_size_in_nanotez = + Q.mul config.minimal_nanotez_per_byte (Q.of_int size) + in + Q.compare + fees_in_nanotez + (Q.add + minimal_fees_in_nanotez + (Q.add + minimal_fees_for_gas_in_nanotez + minimal_fees_for_size_in_nanotez)) + >= 0 + + let pre_filter config + (Operation_data {contents; _} as op : Operation.packed_protocol_data) = + let bytes = + Data_encoding.Binary.fixed_length_exn + Tezos_base.Operation.shell_header_encoding + + Data_encoding.Binary.length Operation.protocol_data_encoding op + in + match contents with + | Single (Endorsement _) -> + true + | Single (Seed_nonce_revelation _) -> + true + | Single (Double_endorsement_evidence _) -> + true + | Single (Double_baking_evidence _) -> + true + | Single (Activate_account _) -> + true + | Single (Proposals _) -> + true + | Single (Ballot _) -> + true + | Single (Manager_operation _) as op -> + pre_filter_manager config op bytes + | Cons (Manager_operation _, _) as op -> + pre_filter_manager config op bytes + + open Apply_results + + let rec post_filter_manager : + type t. + Alpha_context.t -> + t Kind.manager contents_result_list -> + config -> + bool Lwt.t = + fun ctxt op config -> + match op with + | Single_result (Manager_operation_result {operation_result; _}) -> ( + match operation_result with + | Applied _ -> + Lwt.return_true + | Skipped _ | Failed _ | Backtracked _ -> + Lwt.return config.allow_script_failure ) + | Cons_result (Manager_operation_result res, rest) -> ( + post_filter_manager + ctxt + (Single_result (Manager_operation_result res)) + config + >>= function + | false -> + Lwt.return_false + | true -> + post_filter_manager ctxt rest config ) + + let post_filter config ~validation_state_before:_ + ~validation_state_after:({ctxt; _} : validation_state) (_op, receipt) = + match receipt with + | No_operation_metadata -> + assert false (* only for multipass validator *) + | Operation_metadata {contents} -> ( + match contents with + | Single_result (Endorsement_result _) -> + Lwt.return_true + | Single_result (Seed_nonce_revelation_result _) -> + Lwt.return_true + | Single_result (Double_endorsement_evidence_result _) -> + Lwt.return_true + | Single_result (Double_baking_evidence_result _) -> + Lwt.return_true + | Single_result (Activate_account_result _) -> + Lwt.return_true + | Single_result Proposals_result -> + Lwt.return_true + | Single_result Ballot_result -> + Lwt.return_true + | Single_result (Manager_operation_result _) as op -> + post_filter_manager ctxt op config + | Cons_result (Manager_operation_result _, _) as op -> + post_filter_manager ctxt op config ) +end + +module RPC = struct + open Environment + + type Environment.Error_monad.error += Cannot_serialize_log_normalized + + let () = + (* Cannot serialize log *) + Environment.Error_monad.register_error_kind + `Temporary + ~id:"michelson_v1.cannot_serialize_log_normalized" + ~title:"Not enough gas to serialize normalized execution trace" + ~description: + "Execution trace with normalized stacks was to big to be serialized \ + with the provided gas" + Data_encoding.empty + (function Cannot_serialize_log_normalized -> Some () | _ -> None) + (fun () -> Cannot_serialize_log_normalized) + + module Unparse_types = struct + (* Same as the unparsing functions for types in Script_ir_translator but + does not consume gas and never folds (pair a (pair b c)) *) + + open Script_ir_translator + open Micheline + open Michelson_v1_primitives + open Script_ir_annot + open Script_typed_ir + + let rec unparse_comparable_ty : type a. a comparable_ty -> Script.node = + function + | Unit_key tname -> + Prim (-1, T_unit, [], unparse_type_annot tname) + | Never_key tname -> + Prim (-1, T_never, [], unparse_type_annot tname) + | Int_key tname -> + Prim (-1, T_int, [], unparse_type_annot tname) + | Nat_key tname -> + Prim (-1, T_nat, [], unparse_type_annot tname) + | Signature_key tname -> + Prim (-1, T_signature, [], unparse_type_annot tname) + | String_key tname -> + Prim (-1, T_string, [], unparse_type_annot tname) + | Bytes_key tname -> + Prim (-1, T_bytes, [], unparse_type_annot tname) + | Mutez_key tname -> + Prim (-1, T_mutez, [], unparse_type_annot tname) + | Bool_key tname -> + Prim (-1, T_bool, [], unparse_type_annot tname) + | Key_hash_key tname -> + Prim (-1, T_key_hash, [], unparse_type_annot tname) + | Key_key tname -> + Prim (-1, T_key, [], unparse_type_annot tname) + | Timestamp_key tname -> + Prim (-1, T_timestamp, [], unparse_type_annot tname) + | Address_key tname -> + Prim (-1, T_address, [], unparse_type_annot tname) + | Chain_id_key tname -> + Prim (-1, T_chain_id, [], unparse_type_annot tname) + | Pair_key ((l, al), (r, ar), pname) -> + let tl = add_field_annot al None (unparse_comparable_ty l) in + let tr = add_field_annot ar None (unparse_comparable_ty r) in + Prim (-1, T_pair, [tl; tr], unparse_type_annot pname) + | Union_key ((l, al), (r, ar), tname) -> + let tl = add_field_annot al None (unparse_comparable_ty l) in + let tr = add_field_annot ar None (unparse_comparable_ty r) in + Prim (-1, T_or, [tl; tr], unparse_type_annot tname) + | Option_key (t, tname) -> + Prim + (-1, T_option, [unparse_comparable_ty t], unparse_type_annot tname) + + let unparse_memo_size memo_size = + let z = Alpha_context.Sapling.Memo_size.unparse_to_z memo_size in + Int (-1, z) + + let rec unparse_ty : type a. a ty -> Script.node = + fun ty -> + let return (name, args, annot) = Prim (-1, name, args, annot) in + match ty with + | Unit_t tname -> + return (T_unit, [], unparse_type_annot tname) + | Int_t tname -> + return (T_int, [], unparse_type_annot tname) + | Nat_t tname -> + return (T_nat, [], unparse_type_annot tname) + | Signature_t tname -> + return (T_signature, [], unparse_type_annot tname) + | String_t tname -> + return (T_string, [], unparse_type_annot tname) + | Bytes_t tname -> + return (T_bytes, [], unparse_type_annot tname) + | Mutez_t tname -> + return (T_mutez, [], unparse_type_annot tname) + | Bool_t tname -> + return (T_bool, [], unparse_type_annot tname) + | Key_hash_t tname -> + return (T_key_hash, [], unparse_type_annot tname) + | Key_t tname -> + return (T_key, [], unparse_type_annot tname) + | Timestamp_t tname -> + return (T_timestamp, [], unparse_type_annot tname) + | Address_t tname -> + return (T_address, [], unparse_type_annot tname) + | Operation_t tname -> + return (T_operation, [], unparse_type_annot tname) + | Chain_id_t tname -> + return (T_chain_id, [], unparse_type_annot tname) + | Never_t tname -> + return (T_never, [], unparse_type_annot tname) + | Bls12_381_g1_t tname -> + return (T_bls12_381_g1, [], unparse_type_annot tname) + | Bls12_381_g2_t tname -> + return (T_bls12_381_g2, [], unparse_type_annot tname) + | Bls12_381_fr_t tname -> + return (T_bls12_381_fr, [], unparse_type_annot tname) + | Contract_t (ut, tname) -> + let t = unparse_ty ut in + return (T_contract, [t], unparse_type_annot tname) + | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname) -> + let annot = unparse_type_annot tname in + let utl = unparse_ty utl in + let tl = add_field_annot l_field l_var utl in + let utr = unparse_ty utr in + let tr = add_field_annot r_field r_var utr in + return (T_pair, [tl; tr], annot) + | Union_t ((utl, l_field), (utr, r_field), tname) -> + let annot = unparse_type_annot tname in + let utl = unparse_ty utl in + let tl = add_field_annot l_field None utl in + let utr = unparse_ty utr in + let tr = add_field_annot r_field None utr in + return (T_or, [tl; tr], annot) + | Lambda_t (uta, utr, tname) -> + let ta = unparse_ty uta in + let tr = unparse_ty utr in + return (T_lambda, [ta; tr], unparse_type_annot tname) + | Option_t (ut, tname) -> + let annot = unparse_type_annot tname in + let ut = unparse_ty ut in + return (T_option, [ut], annot) + | List_t (ut, tname) -> + let t = unparse_ty ut in + return (T_list, [t], unparse_type_annot tname) + | Ticket_t (ut, tname) -> + let t = unparse_comparable_ty ut in + return (T_ticket, [t], unparse_type_annot tname) + | Set_t (ut, tname) -> + let t = unparse_comparable_ty ut in + return (T_set, [t], unparse_type_annot tname) + | Map_t (uta, utr, tname) -> + let ta = unparse_comparable_ty uta in + let tr = unparse_ty utr in + return (T_map, [ta; tr], unparse_type_annot tname) + | Big_map_t (uta, utr, tname) -> + let ta = unparse_comparable_ty uta in + let tr = unparse_ty utr in + return (T_big_map, [ta; tr], unparse_type_annot tname) + | Sapling_transaction_t (memo_size, tname) -> + return + ( T_sapling_transaction, + [unparse_memo_size memo_size], + unparse_type_annot tname ) + | Sapling_state_t (memo_size, tname) -> + return + ( T_sapling_state, + [unparse_memo_size memo_size], + unparse_type_annot tname ) + end + + let helpers_path = RPC_path.(open_root / "helpers" / "scripts") + + let contract_root = + ( RPC_path.(open_root / "context" / "contracts") + : RPC_context.t RPC_path.context ) + + let big_map_root = + ( RPC_path.(open_root / "context" / "big_maps") + : RPC_context.t RPC_path.context ) + + let unparsing_mode_encoding = + let open Data_encoding in + union + ~tag_size:`Uint8 + [ case + (Tag 0) + ~title:"Readable" + (constant "Readable") + (function + | Script_ir_translator.Readable -> + Some () + | Script_ir_translator.Optimized + | Script_ir_translator.Optimized_legacy -> + None) + (fun () -> Script_ir_translator.Readable); + case + (Tag 1) + ~title:"Optimized" + (constant "Optimized") + (function + | Script_ir_translator.Optimized -> + Some () + | Script_ir_translator.Readable + | Script_ir_translator.Optimized_legacy -> + None) + (fun () -> Script_ir_translator.Optimized); + case + (Tag 2) + ~title:"Optimized_legacy" + (constant "Optimized_legacy") + (function + | Script_ir_translator.Optimized_legacy -> + Some () + | Script_ir_translator.Readable | Script_ir_translator.Optimized -> + None) + (fun () -> Script_ir_translator.Optimized_legacy) ] + + let run_code_input_encoding = + let open Data_encoding in + merge_objs + (obj10 + (req "script" Script.expr_encoding) + (req "storage" Script.expr_encoding) + (req "input" Script.expr_encoding) + (req "amount" Tez.encoding) + (req "balance" Tez.encoding) + (req "chain_id" Chain_id.encoding) + (opt "source" Contract.encoding) + (opt "payer" Contract.encoding) + (opt "gas" Gas.Arith.z_integral_encoding) + (dft "entrypoint" string "default")) + (obj1 (req "unparsing_mode" unparsing_mode_encoding)) + + let normalize_data = + let open Data_encoding in + RPC_service.post_service + ~description: + "Normalizes some data expression using the requested unparsing mode" + ~input: + (obj4 + (req "data" Script.expr_encoding) + (req "type" Script.expr_encoding) + (req "unparsing_mode" unparsing_mode_encoding) + (opt "legacy" bool)) + ~output:(obj1 (req "normalized" Script.expr_encoding)) + ~query:RPC_query.empty + RPC_path.(helpers_path / "normalize_data") + + let normalize_script = + let open Data_encoding in + RPC_service.post_service + ~description: + "Normalizes a Michelson script using the requested unparsing mode" + ~input: + (obj2 + (req "script" Script.expr_encoding) + (req "unparsing_mode" unparsing_mode_encoding)) + ~output:(obj1 (req "normalized" Script.expr_encoding)) + ~query:RPC_query.empty + RPC_path.(helpers_path / "normalize_script") + + let normalize_type = + let open Data_encoding in + RPC_service.post_service + ~description: + "Normalizes some Michelson type by expanding `pair a b c` as `pair a \ + (pair b c)" + ~input:(obj1 (req "type" Script.expr_encoding)) + ~output:(obj1 (req "normalized" Script.expr_encoding)) + ~query:RPC_query.empty + RPC_path.(helpers_path / "normalize_type") + + let get_storage_normalized = + let open Data_encoding in + RPC_service.post_service + ~description: + "Access the data of the contract and normalize it using the requested \ + unparsing mode." + ~input:(obj1 (req "unparsing_mode" unparsing_mode_encoding)) + ~query:RPC_query.empty + ~output:(option Script.expr_encoding) + RPC_path.(contract_root /: Contract.rpc_arg / "storage" / "normalized") + + let get_script_normalized = + let open Data_encoding in + RPC_service.post_service + ~description: + "Access the script of the contract and normalize it using the \ + requested unparsing mode." + ~input:(obj1 (req "unparsing_mode" unparsing_mode_encoding)) + ~query:RPC_query.empty + ~output:(option Script.encoding) + RPC_path.(contract_root /: Contract.rpc_arg / "script" / "normalized") + + let run_code_normalized = + let open Data_encoding in + RPC_service.post_service + ~description: + "Run a piece of code in the current context, normalize the output \ + using the requested unparsing mode." + ~query:RPC_query.empty + ~input:run_code_input_encoding + ~output: + (conv + (fun (storage, operations, lazy_storage_diff) -> + (storage, operations, lazy_storage_diff, lazy_storage_diff)) + (fun ( storage, + operations, + legacy_lazy_storage_diff, + lazy_storage_diff ) -> + let lazy_storage_diff = + Option.first_some lazy_storage_diff legacy_lazy_storage_diff + in + (storage, operations, lazy_storage_diff)) + (obj4 + (req "storage" Script.expr_encoding) + (req + "operations" + (list Alpha_context.Operation.internal_operation_encoding)) + (opt "big_map_diff" Lazy_storage.legacy_big_map_diff_encoding) + (opt "lazy_storage_diff" Lazy_storage.encoding))) + RPC_path.(helpers_path / "run_code" / "normalized") + + let trace_encoding = + let open Data_encoding in + def "scripted.trace" @@ list + @@ obj3 + (req "location" Script.location_encoding) + (req "gas" Gas.encoding) + (req + "stack" + (list (obj2 (req "item" Script.expr_encoding) (opt "annot" string)))) + + let trace_code_normalized = + let open Data_encoding in + RPC_service.post_service + ~description: + "Run a piece of code in the current context, keeping a trace, \ + normalize the output using the requested unparsing mode." + ~query:RPC_query.empty + ~input:run_code_input_encoding + ~output: + (conv + (fun (storage, operations, trace, lazy_storage_diff) -> + (storage, operations, trace, lazy_storage_diff, lazy_storage_diff)) + (fun ( storage, + operations, + trace, + legacy_lazy_storage_diff, + lazy_storage_diff ) -> + let lazy_storage_diff = + Option.first_some lazy_storage_diff legacy_lazy_storage_diff + in + (storage, operations, trace, lazy_storage_diff)) + (obj5 + (req "storage" Script.expr_encoding) + (req + "operations" + (list Alpha_context.Operation.internal_operation_encoding)) + (req "trace" trace_encoding) + (opt "big_map_diff" Lazy_storage.legacy_big_map_diff_encoding) + (opt "lazy_storage_diff" Lazy_storage.encoding))) + RPC_path.(helpers_path / "trace_code" / "normalized") + + let big_map_get_normalized = + let open Data_encoding in + RPC_service.post_service + ~description: + "Access the value associated with a key in a big map, normalize the \ + output using the requested unparsing mode." + ~query:RPC_query.empty + ~input:(obj1 (req "unparsing_mode" unparsing_mode_encoding)) + ~output:Script.expr_encoding + RPC_path.( + big_map_root /: Big_map.Id.rpc_arg /: Script_expr_hash.rpc_arg + / "normalized") + + let rpc_services = + let patched_services = + ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t) + in + let register0_fullctxt s f = + patched_services := + RPC_directory.register !patched_services s (fun ctxt q i -> + Services_registration.rpc_init ctxt >>=? fun ctxt -> f ctxt q i) + in + let register0 s f = register0_fullctxt s (fun {context; _} -> f context) in + let register1_fullctxt s f = + patched_services := + RPC_directory.register !patched_services s (fun (ctxt, arg) q i -> + Services_registration.rpc_init ctxt >>=? fun ctxt -> f ctxt arg q i) + in + let register1 s f = + register1_fullctxt s (fun {context; _} x -> f context x) + in + let _register1_noctxt s f = + patched_services := + RPC_directory.register !patched_services s (fun (_, arg) q i -> + f arg q i) + in + let register2_fullctxt s f = + patched_services := + RPC_directory.register + !patched_services + s + (fun ((ctxt, arg1), arg2) q i -> + Services_registration.rpc_init ctxt + >>=? fun ctxt -> f ctxt arg1 arg2 q i) + in + let register2 s f = + register2_fullctxt s (fun {context; _} a1 a2 q i -> f context a1 a2 q i) + in + let register_field s f = + register1 s (fun ctxt contract () () -> + Contract.exists ctxt contract + >>=? function true -> f ctxt contract | false -> raise Not_found) + in + let _register_opt_field s f = + register_field s (fun ctxt a1 -> + f ctxt a1 >|=? function None -> raise Not_found | Some v -> v) + in + let originate_dummy_contract ctxt script balance = + let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in + Lwt.return (Contract.fresh_contract_from_current_nonce ctxt) + >>=? fun (ctxt, dummy_contract) -> + Contract.originate + ctxt + dummy_contract + ~balance + ~delegate:None + ~script:(script, None) + >>=? fun ctxt -> return (ctxt, dummy_contract) + in + register0 + normalize_data + (fun ctxt () (expr, typ, unparsing_mode, legacy) -> + let open Script_ir_translator in + let legacy = Option.value ~default:false legacy in + let ctxt = Gas.set_unlimited ctxt in + (* Unfortunately, Script_ir_translator.parse_any_ty is not exported *) + Script_ir_translator.parse_ty + ctxt + ~legacy + ~allow_lazy_storage:true + ~allow_operation:true + ~allow_contract:true + ~allow_ticket:true + (Micheline.root typ) + >>?= fun (Ex_ty typ, ctxt) -> + parse_data ctxt ~legacy ~allow_forged:true typ (Micheline.root expr) + >>=? fun (data, ctxt) -> + Script_ir_translator.unparse_data ctxt unparsing_mode typ data + >|=? fun (normalized, _ctxt) -> Micheline.strip_locations normalized) ; + register0 normalize_script (fun ctxt () (script, unparsing_mode) -> + let ctxt = Gas.set_unlimited ctxt in + Script_ir_translator.unparse_code + ctxt + unparsing_mode + (Micheline.root script) + >|=? fun (normalized, _ctxt) -> Micheline.strip_locations normalized) ; + register0 normalize_type (fun ctxt () typ -> + let open Script_ir_translator in + let ctxt = Gas.set_unlimited ctxt in + (* Unfortunately, Script_ir_translator.parse_any_ty is not exported *) + Script_ir_translator.parse_ty + ctxt + ~legacy:true + ~allow_lazy_storage:true + ~allow_operation:true + ~allow_contract:true + ~allow_ticket:true + (Micheline.root typ) + >>?= fun (Ex_ty typ, _ctxt) -> + let normalized = Unparse_types.unparse_ty typ in + return @@ Micheline.strip_locations normalized) ; + (* Patched RPC: get_storage *) + register1 get_storage_normalized (fun ctxt contract () unparsing_mode -> + Contract.get_script ctxt contract + >>=? fun (ctxt, script) -> + match script with + | None -> + return_none + | Some script -> + let ctxt = Gas.set_unlimited ctxt in + let open Script_ir_translator in + parse_script ctxt ~legacy:true ~allow_forged_in_storage:true script + >>=? fun (Ex_script script, ctxt) -> + unparse_script ctxt unparsing_mode script + >>=? fun (script, ctxt) -> + Script.force_decode_in_context ctxt script.storage + >>?= fun (storage, _ctxt) -> return_some storage) ; + (* Patched RPC: get_script *) + register1 get_script_normalized (fun ctxt contract () unparsing_mode -> + Contract.get_script ctxt contract + >>=? fun (ctxt, script) -> + match script with + | None -> + return_none + | Some script -> + let ctxt = Gas.set_unlimited ctxt in + let open Script_ir_translator in + parse_script ctxt ~legacy:true ~allow_forged_in_storage:true script + >>=? fun (Ex_script script, ctxt) -> + unparse_script ctxt unparsing_mode script + >>=? fun (script, _ctxt) -> return_some script) ; + register0 + run_code_normalized + (fun ctxt + () + ( ( code, + storage, + parameter, + amount, + balance, + chain_id, + source, + payer, + gas, + entrypoint ), + unparsing_mode ) + -> + let storage = Script.lazy_expr storage in + let code = Script.lazy_expr code in + originate_dummy_contract ctxt {storage; code} balance + >>=? fun (ctxt, dummy_contract) -> + let (source, payer) = + match (source, payer) with + | (Some source, Some payer) -> + (source, payer) + | (Some source, None) -> + (source, source) + | (None, Some payer) -> + (payer, payer) + | (None, None) -> + (dummy_contract, dummy_contract) + in + let gas = + match gas with + | Some gas -> + gas + | None -> + Constants.hard_gas_limit_per_operation ctxt + in + let ctxt = Gas.set_limit ctxt gas in + let step_constants = + let open Script_interpreter in + {source; payer; self = dummy_contract; amount; chain_id} + in + Script_interpreter.execute + ctxt + unparsing_mode + step_constants + ~script:{storage; code} + ~entrypoint + ~parameter + ~internal:true + >|=? fun {Script_interpreter.storage; operations; lazy_storage_diff; _} -> + (storage, operations, lazy_storage_diff)) ; + register0 + trace_code_normalized + (fun ctxt + () + ( ( code, + storage, + parameter, + amount, + balance, + chain_id, + source, + payer, + gas, + entrypoint ), + unparsing_mode ) + -> + let module Traced_interpreter = struct + type log_element = + | Log : + context * Script.location * 'a * 'a Script_typed_ir.stack_ty + -> log_element + + let unparse_stack ctxt (stack, stack_ty) = + (* We drop the gas limit as this function is only used for debugging/errors. *) + let ctxt = Gas.set_unlimited ctxt in + let rec unparse_stack : + type a. + a Script_typed_ir.stack_ty * a -> + (Script.expr * string option) list + Environment.Error_monad.tzresult + Lwt.t = function + | (Empty_t, ()) -> + return_nil + | (Item_t (ty, rest_ty, annot), (v, rest)) -> + Script_ir_translator.unparse_data ctxt unparsing_mode ty v + >>=? fun (data, _ctxt) -> + unparse_stack (rest_ty, rest) + >|=? fun rest -> + let annot = + match Script_ir_annot.unparse_var_annot annot with + | [] -> + None + | [a] -> + Some a + | _ -> + assert false + in + let data = Micheline.strip_locations data in + (data, annot) :: rest + in + unparse_stack (stack_ty, stack) + + module Trace_logger () : Script_interpreter.STEP_LOGGER = struct + let log : log_element list ref = ref [] + + let log_interp ctxt (descr : (_, _) Script_typed_ir.descr) stack = + log := Log (ctxt, descr.loc, stack, descr.bef) :: !log + + let log_entry _ctxt _descr _stack = () + + let log_exit ctxt (descr : (_, _) Script_typed_ir.descr) stack = + log := Log (ctxt, descr.loc, stack, descr.aft) :: !log + + let get_log () = + Environment.Error_monad.map_s + (fun (Log (ctxt, loc, stack, stack_ty)) -> + Environment.Error_monad.trace + Cannot_serialize_log_normalized + (unparse_stack ctxt (stack, stack_ty)) + >>=? fun stack -> return (loc, Gas.level ctxt, stack)) + !log + >>=? fun res -> return (Some (List.rev res)) + end + end in + let storage = Script.lazy_expr storage in + let code = Script.lazy_expr code in + originate_dummy_contract ctxt {storage; code} balance + >>=? fun (ctxt, dummy_contract) -> + let (source, payer) = + match (source, payer) with + | (Some source, Some payer) -> + (source, payer) + | (Some source, None) -> + (source, source) + | (None, Some payer) -> + (payer, payer) + | (None, None) -> + (dummy_contract, dummy_contract) + in + let gas = + match gas with + | Some gas -> + gas + | None -> + Constants.hard_gas_limit_per_operation ctxt + in + let ctxt = Gas.set_limit ctxt gas in + let step_constants = + let open Script_interpreter in + {source; payer; self = dummy_contract; amount; chain_id} + in + let module Logger = Traced_interpreter.Trace_logger () in + let logger = (module Logger : Script_interpreter.STEP_LOGGER) in + Script_interpreter.execute + ~logger + ctxt + unparsing_mode + step_constants + ~script:{storage; code} + ~entrypoint + ~parameter + ~internal:true + >>=? fun {storage; lazy_storage_diff; operations; _} -> + Logger.get_log () + >|=? fun trace -> + let trace = Option.value ~default:[] trace in + (storage, operations, trace, lazy_storage_diff)) ; + register2 big_map_get_normalized (fun ctxt id key () unparsing_mode -> + let open Script_ir_translator in + let ctxt = Gas.set_unlimited ctxt in + Big_map.exists ctxt id + >>=? fun (ctxt, types) -> + match types with + | None -> + raise Not_found + | Some (_, value_type) -> ( + parse_big_map_value_ty + ctxt + ~legacy:true + (Micheline.root value_type) + >>?= fun (Ex_ty value_type, ctxt) -> + Big_map.get_opt ctxt id key + >>=? fun (_ctxt, value) -> + match value with + | None -> + raise Not_found + | Some value -> + parse_data + ctxt + ~legacy:true + ~allow_forged:true + value_type + (Micheline.root value) + >>=? fun (value, ctxt) -> + unparse_data ctxt unparsing_mode value_type value + >|=? fun (value, _ctxt) -> Micheline.strip_locations value )) ; + RPC_directory.merge rpc_services !patched_services + + let normalize_data ctxt block ?legacy ~data ~ty ~unparsing_mode = + RPC_context.make_call0 + normalize_data + ctxt + block + () + (data, ty, unparsing_mode, legacy) + + let normalize_script ctxt block ~script ~unparsing_mode = + RPC_context.make_call0 + normalize_script + ctxt + block + () + (script, unparsing_mode) + + let normalize_type ctxt block ~ty = + RPC_context.make_call0 normalize_type ctxt block () ty + + let get_storage_normalized ctxt block ~contract ~unparsing_mode = + RPC_context.make_call1 + get_storage_normalized + ctxt + block + contract + () + unparsing_mode + + let get_script_normalized ctxt block ~contract ~unparsing_mode = + RPC_context.make_call1 + get_script_normalized + ctxt + block + contract + () + unparsing_mode + + let run_code_normalized ctxt block ?gas ?(entrypoint = "default") ~script + ~storage ~input ~amount ~balance ~chain_id ~source ~payer ~unparsing_mode + = + RPC_context.make_call0 + run_code_normalized + ctxt + block + () + ( ( script, + storage, + input, + amount, + balance, + chain_id, + source, + payer, + gas, + entrypoint ), + unparsing_mode ) + + let trace_code_normalized ctxt block ?gas ?(entrypoint = "default") ~script + ~storage ~input ~amount ~balance ~chain_id ~source ~payer ~unparsing_mode + = + RPC_context.make_call0 + trace_code_normalized + ctxt + block + () + ( ( script, + storage, + input, + amount, + balance, + chain_id, + source, + payer, + gas, + entrypoint ), + unparsing_mode ) + + let big_map_get_normalized ctxt block id key ~unparsing_mode = + RPC_context.make_call2 + big_map_get_normalized + ctxt + block + id + key + () + unparsing_mode +end diff --git a/src/proto_008_PtEdo2Zk/lib_plugin/registerer.ml b/src/proto_008_PtEdo2Zk/lib_plugin/registerer.ml new file mode 100644 index 0000000000000000000000000000000000000000..07a9a2e02085d477b760c66d600167745893ee7c --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_plugin/registerer.ml @@ -0,0 +1,28 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Development. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let () = + Prevalidator_filters.register + (module Tezos_protocol_plugin_008_PtEdo2Zk.Plugin) diff --git a/src/proto_alpha/lib_mempool/tezos-mempool-alpha.opam b/src/proto_008_PtEdo2Zk/lib_plugin/tezos-protocol-plugin-008-PtEdo2Zk-registerer.opam similarity index 82% rename from src/proto_alpha/lib_mempool/tezos-mempool-alpha.opam rename to src/proto_008_PtEdo2Zk/lib_plugin/tezos-protocol-plugin-008-PtEdo2Zk-registerer.opam index d21baeedd9707f516a1fe70fbd676c7bd4b75312..801080bfafbce4d1a2c961306190b954cce8a0e9 100644 --- a/src/proto_alpha/lib_mempool/tezos-mempool-alpha.opam +++ b/src/proto_008_PtEdo2Zk/lib_plugin/tezos-protocol-plugin-008-PtEdo2Zk-registerer.opam @@ -9,11 +9,11 @@ depends: [ "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-base" - "tezos-embedded-protocol-alpha" + "tezos-protocol-plugin-008-PtEdo2Zk" "tezos-shell" ] build: [ ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] -synopsis: "Tezos/Protocol: mempool-filters" +synopsis: "Tezos/Protocol: protocol plugin registerer" diff --git a/src/proto_008_PtEdo2Zk/lib_plugin/tezos-protocol-plugin-008-PtEdo2Zk.opam b/src/proto_008_PtEdo2Zk/lib_plugin/tezos-protocol-plugin-008-PtEdo2Zk.opam new file mode 100644 index 0000000000000000000000000000000000000000..0924047ed81db1d7b7e33de90f0ae710d1a01f96 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_plugin/tezos-protocol-plugin-008-PtEdo2Zk.opam @@ -0,0 +1,18 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "tezos-tooling" { with-test } + "dune" { >= "2.0" } + "tezos-base" + "tezos-embedded-protocol-008-PtEdo2Zk" +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: protocol plugin" diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/.ocamlformat b/src/proto_008_PtEdo2Zk/lib_protocol/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/.ocamlformat rename to src/proto_008_PtEdo2Zk/lib_protocol/.ocamlformat diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/TEZOS_PROTOCOL b/src/proto_008_PtEdo2Zk/lib_protocol/TEZOS_PROTOCOL new file mode 100644 index 0000000000000000000000000000000000000000..e0da2ce7debdfd1b95bdc450144f37669c2e8fcd --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/TEZOS_PROTOCOL @@ -0,0 +1,90 @@ +{ + "expected_env_version": 1, + "hash": "PtEdo2ZkT9oKpimTah6x2embF25oss54njMuPzkJTEi5RqfdZFA", + "modules": [ + "Misc", + "Storage_description", + "State_hash", + "Nonce_hash", + "Script_expr_hash", + "Contract_hash", + "Blinded_public_key_hash", + + "Tez_repr", + "Period_repr", + "Time_repr", + "Fixed_point_repr", + "Gas_limit_repr", + "Constants_repr", + "Fitness_repr", + "Raw_level_repr", + "Cycle_repr", + "Level_repr", + "Seed_repr", + "Voting_period_repr", + "Script_int_repr", + "Script_timestamp_repr", + "Michelson_v1_primitives", + "Script_repr", + "Contract_repr", + "Roll_repr", + "Vote_repr", + "Block_header_repr", + "Operation_repr", + "Manager_repr", + "Commitment_repr", + "Parameters_repr", + "Sapling_repr", + "Lazy_storage_kind", + + "Raw_context", + "Storage_costs", + "Storage_sigs", + "Storage_functors", + "Storage", + + "Constants_storage", + "Level_storage", + "Nonce_storage", + "Seed_storage", + "Roll_storage", + "Delegate_storage", + "Sapling_storage", + "Lazy_storage_diff", + "Contract_storage", + "Bootstrap_storage", + "Fitness_storage", + "Voting_period_storage", + "Vote_storage", + "Commitment_storage", + "Init_storage", + "Fees_storage", + "Sapling_validator", + + "Alpha_context", + + "Script_typed_ir", + "Script_tc_errors", + "Michelson_v1_gas", + "Script_ir_annot", + "Script_ir_translator", + "Script_tc_errors_registration", + "Script_interpreter", + + "Baking", + "Amendment", + "Apply_results", + "Apply", + + "Services_registration", + "Constants_services", + "Sapling_services", + "Contract_services", + "Delegate_services", + "Helpers_services", + "Voting_services", + "Alpha_services", + + "Main" + ] +} diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/alpha_context.ml b/src/proto_008_PtEdo2Zk/lib_protocol/alpha_context.ml new file mode 100644 index 0000000000000000000000000000000000000000..3a70b76db070f6834e18b026639cf36ca3ad52c2 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/alpha_context.ml @@ -0,0 +1,293 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = Raw_context.t + +type context = t + +module type BASIC_DATA = sig + type t + + include Compare.S with type t := t + + val encoding : t Data_encoding.t + + val pp : Format.formatter -> t -> unit +end + +module Tez = Tez_repr +module Period = Period_repr + +module Timestamp = struct + include Time_repr + + let current = Raw_context.current_timestamp +end + +include Operation_repr + +module Operation = struct + type 'kind t = 'kind operation = { + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; + } + + type packed = packed_operation + + let unsigned_encoding = unsigned_operation_encoding + + include Operation_repr +end + +module Block_header = Block_header_repr + +module Vote = struct + include Vote_repr + include Vote_storage +end + +module Raw_level = Raw_level_repr +module Cycle = Cycle_repr +module Script_int = Script_int_repr + +module Script_timestamp = struct + include Script_timestamp_repr + + let now ctxt = + let {Constants_repr.time_between_blocks; _} = Raw_context.constants ctxt in + match time_between_blocks with + | [] -> + failwith + "Internal error: 'time_between_block' constants is an empty list." + | first_delay :: _ -> + let current_timestamp = Raw_context.predecessor_timestamp ctxt in + Time.add current_timestamp (Period_repr.to_seconds first_delay) + |> Timestamp.to_seconds |> of_int64 +end + +module Script = struct + include Michelson_v1_primitives + include Script_repr + + let force_decode_in_context ctxt lexpr = + Script_repr.force_decode lexpr + >>? fun (v, cost) -> + Raw_context.consume_gas ctxt cost >|? fun ctxt -> (v, ctxt) + + let force_bytes_in_context ctxt lexpr = + Script_repr.force_bytes lexpr + >>? fun (b, cost) -> + Raw_context.consume_gas ctxt cost >|? fun ctxt -> (b, ctxt) +end + +module Fees = Fees_storage + +type public_key = Signature.Public_key.t + +type public_key_hash = Signature.Public_key_hash.t + +type signature = Signature.t + +module Constants = struct + include Constants_repr + include Constants_storage +end + +module Voting_period = struct + include Voting_period_repr + include Voting_period_storage +end + +module Gas = struct + include Gas_limit_repr + + type error += Gas_limit_too_high = Raw_context.Gas_limit_too_high + + let check_limit = Raw_context.check_gas_limit + + let set_limit = Raw_context.set_gas_limit + + let set_unlimited = Raw_context.set_gas_unlimited + + let consume = Raw_context.consume_gas + + let check_enough = Raw_context.check_enough_gas + + let level = Raw_context.gas_level + + let consumed = Raw_context.gas_consumed + + let block_level = Raw_context.block_gas_level + + (* Necessary to inject costs for Storage_costs into Gas.cost *) + let cost_of_repr cost = cost +end + +module Level = struct + include Level_repr + include Level_storage +end + +module Lazy_storage = struct + module Kind = Lazy_storage_kind + module IdSet = Kind.IdSet + include Lazy_storage_diff + + let legacy_big_map_diff_encoding = + Data_encoding.conv + Contract_storage.Legacy_big_map_diff.of_lazy_storage_diff + Contract_storage.Legacy_big_map_diff.to_lazy_storage_diff + Contract_storage.Legacy_big_map_diff.encoding +end + +module Contract = struct + include Contract_repr + include Contract_storage + + let originate c contract ~balance ~script ~delegate = + raw_originate c contract ~balance ~script ~delegate + + let init_origination_nonce = Raw_context.init_origination_nonce + + let unset_origination_nonce = Raw_context.unset_origination_nonce +end + +module Big_map = struct + include Lazy_storage_kind.Big_map + + let fresh ~temporary c = Lazy_storage.fresh Big_map ~temporary c + + let mem c m k = Storage.Big_map.Contents.mem (c, m) k + + let get_opt c m k = Storage.Big_map.Contents.get_option (c, m) k + + let exists c id = + Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero) + >>?= fun c -> + Storage.Big_map.Key_type.get_option c id + >>=? fun kt -> + match kt with + | None -> + return (c, None) + | Some kt -> + Storage.Big_map.Value_type.get c id >|=? fun kv -> (c, Some (kt, kv)) +end + +module Sapling = struct + include Lazy_storage_kind.Sapling_state + include Sapling_repr + include Sapling_storage + include Sapling_validator + + let fresh ~temporary c = Lazy_storage.fresh Sapling_state ~temporary c +end + +module Delegate = Delegate_storage + +module Roll = struct + include Roll_repr + include Roll_storage +end + +module Nonce = Nonce_storage + +module Seed = struct + include Seed_repr + include Seed_storage +end + +module Fitness = struct + include Fitness_repr + include Fitness + + type fitness = t + + include Fitness_storage +end + +module Bootstrap = Bootstrap_storage + +module Commitment = struct + include Commitment_repr + include Commitment_storage +end + +module Global = struct + let get_block_priority = Storage.Block_priority.get + + let set_block_priority = Storage.Block_priority.set +end + +let prepare_first_block = Init_storage.prepare_first_block + +let prepare = Init_storage.prepare + +let finalize ?commit_message:message c = + let fitness = Fitness.from_int64 (Fitness.current c) in + let context = Raw_context.recover c in + { + Updater.context; + fitness; + message; + max_operations_ttl = 60; + last_allowed_fork_level = + Raw_level.to_int32 @@ Level.last_allowed_fork_level c; + } + +let activate = Raw_context.activate + +let fork_test_chain = Raw_context.fork_test_chain + +let record_endorsement = Raw_context.record_endorsement + +let allowed_endorsements = Raw_context.allowed_endorsements + +let init_endorsements = Raw_context.init_endorsements + +let included_endorsements = Raw_context.included_endorsements + +let reset_internal_nonce = Raw_context.reset_internal_nonce + +let fresh_internal_nonce = Raw_context.fresh_internal_nonce + +let record_internal_nonce = Raw_context.record_internal_nonce + +let internal_nonce_already_recorded = + Raw_context.internal_nonce_already_recorded + +let add_deposit = Raw_context.add_deposit + +let add_fees = Raw_context.add_fees + +let add_rewards = Raw_context.add_rewards + +let get_deposits = Raw_context.get_deposits + +let get_fees = Raw_context.get_fees + +let get_rewards = Raw_context.get_rewards + +let description = Raw_context.description diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/alpha_context.mli b/src/proto_008_PtEdo2Zk/lib_protocol/alpha_context.mli new file mode 100644 index 0000000000000000000000000000000000000000..8e6334011a4fca5d440146f4011753a82d13ad3f --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/alpha_context.mli @@ -0,0 +1,1587 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module type BASIC_DATA = sig + type t + + include Compare.S with type t := t + + val encoding : t Data_encoding.t + + val pp : Format.formatter -> t -> unit +end + +type t + +type context = t + +type public_key = Signature.Public_key.t + +type public_key_hash = Signature.Public_key_hash.t + +type signature = Signature.t + +module Tez : sig + include BASIC_DATA + + type tez = t + + val zero : tez + + val one_mutez : tez + + val one_cent : tez + + val fifty_cents : tez + + val one : tez + + val ( -? ) : tez -> tez -> tez tzresult + + val ( +? ) : tez -> tez -> tez tzresult + + val ( *? ) : tez -> int64 -> tez tzresult + + val ( /? ) : tez -> int64 -> tez tzresult + + val of_string : string -> tez option + + val to_string : tez -> string + + val of_mutez : int64 -> tez option + + val to_mutez : tez -> int64 +end + +module Period : sig + include BASIC_DATA + + type period = t + + val rpc_arg : period RPC_arg.arg + + val of_seconds : int64 -> period tzresult + + val to_seconds : period -> int64 + + val mult : int32 -> period -> period tzresult + + val zero : period + + val one_second : period + + val one_minute : period + + val one_hour : period +end + +module Timestamp : sig + include BASIC_DATA with type t = Time.t + + type time = t + + val ( +? ) : time -> Period.t -> time tzresult + + val ( -? ) : time -> time -> Period.t tzresult + + val of_notation : string -> time option + + val to_notation : time -> string + + val of_seconds_string : string -> time option + + val to_seconds_string : time -> string + + val current : context -> time +end + +module Raw_level : sig + include BASIC_DATA + + type raw_level = t + + val rpc_arg : raw_level RPC_arg.arg + + val diff : raw_level -> raw_level -> int32 + + val root : raw_level + + val succ : raw_level -> raw_level + + val pred : raw_level -> raw_level option + + val to_int32 : raw_level -> int32 + + val of_int32 : int32 -> raw_level tzresult +end + +module Cycle : sig + include BASIC_DATA + + type cycle = t + + val rpc_arg : cycle RPC_arg.arg + + val root : cycle + + val succ : cycle -> cycle + + val pred : cycle -> cycle option + + val add : cycle -> int -> cycle + + val sub : cycle -> int -> cycle option + + val to_int32 : cycle -> int32 + + module Map : S.MAP with type key = cycle +end + +module Gas : sig + module Arith : Fixed_point_repr.Safe + + type t = private Unaccounted | Limited of {remaining : Arith.fp} + + val encoding : t Data_encoding.encoding + + val pp : Format.formatter -> t -> unit + + type cost + + val cost_encoding : cost Data_encoding.encoding + + val pp_cost : Format.formatter -> cost -> unit + + type error += Block_quota_exceeded (* `Temporary *) + + type error += Operation_quota_exceeded (* `Temporary *) + + type error += Gas_limit_too_high (* `Permanent *) + + val free : cost + + val atomic_step_cost : Z.t -> cost + + val step_cost : Z.t -> cost + + val alloc_cost : Z.t -> cost + + val alloc_bytes_cost : int -> cost + + val alloc_mbytes_cost : int -> cost + + val read_bytes_cost : Z.t -> cost + + val write_bytes_cost : Z.t -> cost + + val ( *@ ) : Z.t -> cost -> cost + + val ( +@ ) : cost -> cost -> cost + + val check_limit : context -> 'a Arith.t -> unit tzresult + + val set_limit : context -> 'a Arith.t -> context + + val set_unlimited : context -> context + + val consume : context -> cost -> context tzresult + + val check_enough : context -> cost -> unit tzresult + + val level : context -> t + + val consumed : since:context -> until:context -> Arith.fp + + val block_level : context -> Arith.fp + + val cost_of_repr : Gas_limit_repr.cost -> cost +end + +module Script_int : module type of Script_int_repr + +module Script_timestamp : sig + open Script_int + + type t + + val compare : t -> t -> int + + val to_string : t -> string + + val to_notation : t -> string option + + val to_num_str : t -> string + + val of_string : string -> t option + + val diff : t -> t -> z num + + val add_delta : t -> z num -> t + + val sub_delta : t -> z num -> t + + val now : context -> t + + val to_zint : t -> Z.t + + val of_zint : Z.t -> t +end + +module Script : sig + type prim = Michelson_v1_primitives.prim = + | K_parameter + | K_storage + | K_code + | D_False + | D_Elt + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit + | I_PACK + | I_UNPACK + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHAIN_ID + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_IMPLICIT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_BIG_MAP + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_APPLY + | I_FAILWITH + | I_GE + | I_GET + | I_GET_AND_UPDATE + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LEVEL + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_UNPAIR + | I_PUSH + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_SENDER + | I_SELF + | I_SELF_ADDRESS + | I_SLICE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_SET_DELEGATE + | I_UNIT + | I_UPDATE + | I_XOR + | I_ITER + | I_LOOP_LEFT + | I_ADDRESS + | I_CONTRACT + | I_ISNAT + | I_CAST + | I_RENAME + | I_SAPLING_EMPTY_STATE + | I_SAPLING_VERIFY_UPDATE + | I_DIG + | I_DUG + | I_NEVER + | I_VOTING_POWER + | I_TOTAL_VOTING_POWER + | I_KECCAK + | I_SHA3 + | I_PAIRING_CHECK + | I_TICKET + | I_READ_TICKET + | I_SPLIT_TICKET + | I_JOIN_TICKETS + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_big_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_bytes + | T_mutez + | T_timestamp + | T_unit + | T_operation + | T_address + | T_sapling_transaction + | T_sapling_state + | T_chain_id + | T_never + | T_bls12_381_g1 + | T_bls12_381_g2 + | T_bls12_381_fr + | T_ticket + + type location = Micheline.canonical_location + + type annot = Micheline.annot + + type expr = prim Micheline.canonical + + type lazy_expr = expr Data_encoding.lazy_t + + val lazy_expr : expr -> lazy_expr + + type node = (location, prim) Micheline.node + + type t = {code : lazy_expr; storage : lazy_expr} + + val location_encoding : location Data_encoding.t + + val expr_encoding : expr Data_encoding.t + + val prim_encoding : prim Data_encoding.t + + val encoding : t Data_encoding.t + + val lazy_expr_encoding : lazy_expr Data_encoding.t + + val deserialized_cost : expr -> Gas.cost + + val serialized_cost : bytes -> Gas.cost + + val traversal_cost : node -> Gas.cost + + val int_node_cost : Z.t -> Gas.cost + + val int_node_cost_of_numbits : int -> Gas.cost + + val string_node_cost : string -> Gas.cost + + val string_node_cost_of_length : int -> Gas.cost + + val bytes_node_cost : bytes -> Gas.cost + + val bytes_node_cost_of_length : int -> Gas.cost + + val prim_node_cost_nonrec : expr list -> annot -> Gas.cost + + val seq_node_cost_nonrec : expr list -> Gas.cost + + val seq_node_cost_nonrec_of_length : int -> Gas.cost + + val minimal_deserialize_cost : lazy_expr -> Gas.cost + + val force_decode_in_context : + context -> lazy_expr -> (expr * context) tzresult + + val force_bytes_in_context : + context -> lazy_expr -> (bytes * context) tzresult + + val unit_parameter : lazy_expr + + val micheline_nodes : node -> int + + val strip_locations_cost : node -> Gas.cost +end + +module Constants : sig + (** Fixed constants *) + type fixed = { + proof_of_work_nonce_size : int; + nonce_length : int; + max_anon_ops_per_block : int; + max_operation_data_length : int; + max_proposals_per_delegate : int; + } + + val fixed_encoding : fixed Data_encoding.t + + val fixed : fixed + + val proof_of_work_nonce_size : int + + val nonce_length : int + + val max_anon_ops_per_block : int + + val max_operation_data_length : int + + val max_proposals_per_delegate : int + + (** Constants parameterized by context *) + type parametric = { + preserved_cycles : int; + blocks_per_cycle : int32; + blocks_per_commitment : int32; + blocks_per_roll_snapshot : int32; + blocks_per_voting_period : int32; + time_between_blocks : Period.t list; + endorsers_per_block : int; + hard_gas_limit_per_operation : Gas.Arith.integral; + hard_gas_limit_per_block : Gas.Arith.integral; + proof_of_work_threshold : int64; + tokens_per_roll : Tez.t; + michelson_maximum_type_size : int; + seed_nonce_revelation_tip : Tez.t; + origination_size : int; + block_security_deposit : Tez.t; + endorsement_security_deposit : Tez.t; + baking_reward_per_endorsement : Tez.t list; + endorsement_reward : Tez.t list; + cost_per_byte : Tez.t; + hard_storage_limit_per_operation : Z.t; + test_chain_duration : int64; + quorum_min : int32; + quorum_max : int32; + min_proposal_quorum : int32; + initial_endorsers : int; + delay_per_missing_endorsement : Period.t; + } + + val parametric_encoding : parametric Data_encoding.t + + val parametric : context -> parametric + + val preserved_cycles : context -> int + + val blocks_per_cycle : context -> int32 + + val blocks_per_commitment : context -> int32 + + val blocks_per_roll_snapshot : context -> int32 + + val blocks_per_voting_period : context -> int32 + + val time_between_blocks : context -> Period.t list + + val endorsers_per_block : context -> int + + val initial_endorsers : context -> int + + val delay_per_missing_endorsement : context -> Period.t + + val hard_gas_limit_per_operation : context -> Gas.Arith.integral + + val hard_gas_limit_per_block : context -> Gas.Arith.integral + + val cost_per_byte : context -> Tez.t + + val hard_storage_limit_per_operation : context -> Z.t + + val proof_of_work_threshold : context -> int64 + + val tokens_per_roll : context -> Tez.t + + val michelson_maximum_type_size : context -> int + + val baking_reward_per_endorsement : context -> Tez.t list + + val endorsement_reward : context -> Tez.t list + + val seed_nonce_revelation_tip : context -> Tez.t + + val origination_size : context -> int + + val block_security_deposit : context -> Tez.t + + val endorsement_security_deposit : context -> Tez.t + + val test_chain_duration : context -> int64 + + val quorum_min : context -> int32 + + val quorum_max : context -> int32 + + val min_proposal_quorum : context -> int32 + + (** All constants: fixed and parametric *) + type t = {fixed : fixed; parametric : parametric} + + val encoding : t Data_encoding.t +end + +module Level : sig + type t = private { + level : Raw_level.t; + level_position : int32; + cycle : Cycle.t; + cycle_position : int32; + expected_commitment : bool; + } + + include BASIC_DATA with type t := t + + val pp_full : Format.formatter -> t -> unit + + type level = t + + val root : context -> level + + val succ : context -> level -> level + + val pred : context -> level -> level option + + val from_raw : context -> ?offset:int32 -> Raw_level.t -> level + + val diff : level -> level -> int32 + + val current : context -> level + + val last_level_in_cycle : context -> Cycle.t -> level + + val levels_in_cycle : context -> Cycle.t -> level list + + val levels_in_current_cycle : context -> ?offset:int32 -> unit -> level list + + val last_allowed_fork_level : context -> Raw_level.t + + type compat_t = { + level : Raw_level.t; + level_position : int32; + cycle : Cycle.t; + cycle_position : int32; + voting_period : int32; + voting_period_position : int32; + expected_commitment : bool; + } + + val compat_encoding : compat_t Data_encoding.t + + val to_deprecated_type : + t -> voting_period_index:int32 -> voting_period_position:int32 -> compat_t +end + +module Fitness : sig + include module type of Fitness + + type fitness = t + + val increase : context -> context + + val current : context -> int64 + + val to_int64 : fitness -> int64 tzresult +end + +module Nonce : sig + type t + + type nonce = t + + val encoding : nonce Data_encoding.t + + type unrevealed = { + nonce_hash : Nonce_hash.t; + delegate : public_key_hash; + rewards : Tez.t; + fees : Tez.t; + } + + val record_hash : context -> unrevealed -> context tzresult Lwt.t + + val reveal : context -> Level.t -> nonce -> context tzresult Lwt.t + + type status = Unrevealed of unrevealed | Revealed of nonce + + val get : context -> Level.t -> status tzresult Lwt.t + + val of_bytes : bytes -> nonce tzresult + + val hash : nonce -> Nonce_hash.t + + val check_hash : nonce -> Nonce_hash.t -> bool +end + +module Seed : sig + type seed + + type error += + | Unknown of {oldest : Cycle.t; cycle : Cycle.t; latest : Cycle.t} + + val for_cycle : context -> Cycle.t -> seed tzresult Lwt.t + + val cycle_end : + context -> Cycle.t -> (context * Nonce.unrevealed list) tzresult Lwt.t + + val seed_encoding : seed Data_encoding.t +end + +module Big_map : sig + module Id : sig + type t + + val encoding : t Data_encoding.t + + val rpc_arg : t RPC_arg.arg + + (** In the protocol, to be used in parse_data only *) + val parse_z : Z.t -> t + + (** In the protocol, to be used in unparse_data only *) + val unparse_to_z : t -> Z.t + end + + val fresh : temporary:bool -> context -> (context * Id.t) tzresult Lwt.t + + val mem : + context -> Id.t -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t + + val get_opt : + context -> + Id.t -> + Script_expr_hash.t -> + (context * Script.expr option) tzresult Lwt.t + + val exists : + context -> + Id.t -> + (context * (Script.expr * Script.expr) option) tzresult Lwt.t + + type update = { + key : Script_repr.expr; + key_hash : Script_expr_hash.t; + value : Script_repr.expr option; + } + + type updates = update list + + type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr} +end + +module Sapling : sig + module Id : sig + type t + + val encoding : t Data_encoding.t + + val rpc_arg : t RPC_arg.arg + + val parse_z : Z.t -> t (* To be used in parse_data only *) + + val unparse_to_z : t -> Z.t (* To be used in unparse_data only *) + end + + val fresh : temporary:bool -> context -> (context * Id.t) tzresult Lwt.t + + type diff = private { + commitments_and_ciphertexts : + (Sapling.Commitment.t * Sapling.Ciphertext.t) list; + nullifiers : Sapling.Nullifier.t list; + } + + val diff_encoding : diff Data_encoding.t + + module Memo_size : sig + type t + + val encoding : t Data_encoding.t + + val equal : t -> t -> bool + + val parse_z : Z.t -> (t, string) result + + val unparse_to_z : t -> Z.t + end + + type state = private {id : Id.t option; diff : diff; memo_size : Memo_size.t} + + (** + Returns a [state] with fields filled accordingly. + [id] should only be used by [extract_lazy_storage_updates]. + *) + val empty_state : ?id:Id.t -> memo_size:Memo_size.t -> unit -> state + + type transaction = Sapling.UTXO.transaction + + val transaction_encoding : transaction Data_encoding.t + + val transaction_get_memo_size : transaction -> Memo_size.t option + + (** + Tries to fetch a state from the storage. + *) + val state_from_id : context -> Id.t -> (state * context) tzresult Lwt.t + + val rpc_arg : Id.t RPC_arg.t + + type root = Sapling.Hash.t + + val root_encoding : root Data_encoding.t + + (* Function exposed as RPC. Returns the root and a diff of a state starting + from an optional offset which is zero by default. *) + val get_diff : + context -> + Id.t -> + ?offset_commitment:Int64.t -> + ?offset_nullifier:Int64.t -> + unit -> + (root * diff) tzresult Lwt.t + + val verify_update : + context -> + state -> + transaction -> + string -> + (context * (Int64.t * state) option) tzresult Lwt.t + + type alloc = {memo_size : Memo_size.t} + + type updates = diff +end + +module Lazy_storage : sig + module Kind : sig + type ('id, 'alloc, 'updates) t = + | Big_map : (Big_map.Id.t, Big_map.alloc, Big_map.updates) t + | Sapling_state : (Sapling.Id.t, Sapling.alloc, Sapling.updates) t + end + + module IdSet : sig + type t + + type 'acc fold_f = { + f : 'i 'a 'u. ('i, 'a, 'u) Kind.t -> 'i -> 'acc -> 'acc; + } + + val empty : t + + val mem : ('i, 'a, 'u) Kind.t -> 'i -> t -> bool + + val add : ('i, 'a, 'u) Kind.t -> 'i -> t -> t + + val diff : t -> t -> t + + val fold : ('i, 'a, 'u) Kind.t -> ('i -> 'acc -> 'acc) -> t -> 'acc -> 'acc + + val fold_all : 'acc fold_f -> t -> 'acc -> 'acc + end + + type ('id, 'alloc) init = Existing | Copy of {src : 'id} | Alloc of 'alloc + + type ('id, 'alloc, 'updates) diff = + | Remove + | Update of {init : ('id, 'alloc) init; updates : 'updates} + + type diffs_item + + val make : ('i, 'a, 'u) Kind.t -> 'i -> ('i, 'a, 'u) diff -> diffs_item + + type diffs = diffs_item list + + val encoding : diffs Data_encoding.t + + val legacy_big_map_diff_encoding : diffs Data_encoding.t + + val cleanup_temporaries : context -> context Lwt.t + + val apply : t -> diffs -> (t * Z.t) tzresult Lwt.t +end + +module Contract : sig + include BASIC_DATA + + type contract = t + + val rpc_arg : contract RPC_arg.arg + + val to_b58check : contract -> string + + val of_b58check : string -> contract tzresult + + val implicit_contract : public_key_hash -> contract + + val is_implicit : contract -> public_key_hash option + + val exists : context -> contract -> bool tzresult Lwt.t + + val must_exist : context -> contract -> unit tzresult Lwt.t + + val allocated : context -> contract -> bool tzresult Lwt.t + + val must_be_allocated : context -> contract -> unit tzresult Lwt.t + + val list : context -> contract list Lwt.t + + val get_manager_key : context -> public_key_hash -> public_key tzresult Lwt.t + + val is_manager_key_revealed : + context -> public_key_hash -> bool tzresult Lwt.t + + val reveal_manager_key : + context -> public_key_hash -> public_key -> context tzresult Lwt.t + + val get_script_code : + context -> contract -> (context * Script.lazy_expr option) tzresult Lwt.t + + val get_script : + context -> contract -> (context * Script.t option) tzresult Lwt.t + + val get_storage : + context -> contract -> (context * Script.expr option) tzresult Lwt.t + + val get_counter : context -> public_key_hash -> Z.t tzresult Lwt.t + + val get_balance : context -> contract -> Tez.t tzresult Lwt.t + + val get_balance_carbonated : + context -> contract -> (context * Tez.t) tzresult Lwt.t + + val init_origination_nonce : context -> Operation_hash.t -> context + + val unset_origination_nonce : context -> context + + val fresh_contract_from_current_nonce : context -> (context * t) tzresult + + val originated_from_current_nonce : + since:context -> until:context -> contract list tzresult Lwt.t + + module Legacy_big_map_diff : sig + type item = private + | Update of { + big_map : Z.t; + diff_key : Script.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script.expr option; + } + | Clear of Z.t + | Copy of {src : Z.t; dst : Z.t} + | Alloc of { + big_map : Z.t; + key_type : Script.expr; + value_type : Script.expr; + } + + type t = private item list + + val of_lazy_storage_diff : Lazy_storage.diffs -> t + end + + val originate : + context -> + contract -> + balance:Tez.t -> + script:Script.t * Lazy_storage.diffs option -> + delegate:public_key_hash option -> + context tzresult Lwt.t + + type error += Balance_too_low of contract * Tez.t * Tez.t + + val spend : context -> contract -> Tez.t -> context tzresult Lwt.t + + val credit : context -> contract -> Tez.t -> context tzresult Lwt.t + + val update_script_storage : + context -> + contract -> + Script.expr -> + Lazy_storage.diffs option -> + context tzresult Lwt.t + + val used_storage_space : context -> t -> Z.t tzresult Lwt.t + + val increment_counter : context -> public_key_hash -> context tzresult Lwt.t + + val check_counter_increment : + context -> public_key_hash -> Z.t -> unit tzresult Lwt.t + + (**/**) + + (* Only for testing *) + type origination_nonce + + val initial_origination_nonce : Operation_hash.t -> origination_nonce + + val originated_contract : origination_nonce -> contract +end + +module Delegate : sig + type balance = + | Contract of Contract.t + | Rewards of Signature.Public_key_hash.t * Cycle.t + | Fees of Signature.Public_key_hash.t * Cycle.t + | Deposits of Signature.Public_key_hash.t * Cycle.t + + type balance_update = Debited of Tez.t | Credited of Tez.t + + type balance_updates = (balance * balance_update) list + + val balance_updates_encoding : balance_updates Data_encoding.t + + val cleanup_balance_updates : balance_updates -> balance_updates + + val get : context -> Contract.t -> public_key_hash option tzresult Lwt.t + + val set : + context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t + + val fold : + context -> init:'a -> f:(public_key_hash -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + val list : context -> public_key_hash list Lwt.t + + val freeze_deposit : + context -> public_key_hash -> Tez.t -> context tzresult Lwt.t + + val freeze_rewards : + context -> public_key_hash -> Tez.t -> context tzresult Lwt.t + + val freeze_fees : + context -> public_key_hash -> Tez.t -> context tzresult Lwt.t + + val cycle_end : + context -> + Cycle.t -> + Nonce.unrevealed list -> + (context * balance_updates * Signature.Public_key_hash.t list) tzresult + Lwt.t + + type frozen_balance = {deposit : Tez.t; fees : Tez.t; rewards : Tez.t} + + val punish : + context -> + public_key_hash -> + Cycle.t -> + (context * frozen_balance) tzresult Lwt.t + + val full_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t + + val has_frozen_balance : + context -> public_key_hash -> Cycle.t -> bool tzresult Lwt.t + + val frozen_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t + + val frozen_balance_encoding : frozen_balance Data_encoding.t + + val frozen_balance_by_cycle_encoding : + frozen_balance Cycle.Map.t Data_encoding.t + + val frozen_balance_by_cycle : + context -> Signature.Public_key_hash.t -> frozen_balance Cycle.Map.t Lwt.t + + val staking_balance : + context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t + + val delegated_contracts : + context -> Signature.Public_key_hash.t -> Contract_repr.t list Lwt.t + + val delegated_balance : + context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t + + val deactivated : + context -> Signature.Public_key_hash.t -> bool tzresult Lwt.t + + val grace_period : + context -> Signature.Public_key_hash.t -> Cycle.t tzresult Lwt.t +end + +module Voting_period : sig + type kind = Proposal | Testing_vote | Testing | Promotion_vote | Adoption + + val kind_encoding : kind Data_encoding.encoding + + val pp_kind : Format.formatter -> kind -> unit + + (* This type should be abstract *) + type voting_period = private { + index : int32; + kind : kind; + start_position : int32; + } + + type t = voting_period + + include BASIC_DATA with type t := t + + val encoding : voting_period Data_encoding.t + + val pp : Format.formatter -> voting_period -> unit + + val reset : context -> context tzresult Lwt.t + + val succ : context -> context tzresult Lwt.t + + val get_current : context -> voting_period tzresult Lwt.t + + val get_current_kind : context -> kind tzresult Lwt.t + + val is_last_block : context -> bool tzresult Lwt.t + + type info = {voting_period : t; position : int32; remaining : int32} + + val info_encoding : info Data_encoding.t + + val pp_info : Format.formatter -> info -> unit + + val get_current_info : context -> info tzresult Lwt.t + + val get_rpc_fixed_current_info : context -> info tzresult Lwt.t + + val get_rpc_fixed_succ_info : context -> info tzresult Lwt.t +end + +module Vote : sig + type proposal = Protocol_hash.t + + val record_proposal : + context -> Protocol_hash.t -> public_key_hash -> context tzresult Lwt.t + + val get_proposals : context -> int32 Protocol_hash.Map.t tzresult Lwt.t + + val clear_proposals : context -> context Lwt.t + + val recorded_proposal_count_for_delegate : + context -> public_key_hash -> int tzresult Lwt.t + + val listings_encoding : + (Signature.Public_key_hash.t * int32) list Data_encoding.t + + val update_listings : context -> context tzresult Lwt.t + + val listing_size : context -> int32 tzresult Lwt.t + + val in_listings : context -> public_key_hash -> bool Lwt.t + + val get_listings : context -> (public_key_hash * int32) list Lwt.t + + type ballot = Yay | Nay | Pass + + val get_voting_power_free : + context -> Signature.Public_key_hash.t -> int32 tzresult Lwt.t + + val get_voting_power : + context -> Signature.Public_key_hash.t -> (context * int32) tzresult Lwt.t + + val get_total_voting_power_free : context -> int32 tzresult Lwt.t + + val get_total_voting_power : context -> (context * int32) tzresult Lwt.t + + val ballot_encoding : ballot Data_encoding.t + + type ballots = {yay : int32; nay : int32; pass : int32} + + val ballots_encoding : ballots Data_encoding.t + + val has_recorded_ballot : context -> public_key_hash -> bool Lwt.t + + val record_ballot : + context -> public_key_hash -> ballot -> context tzresult Lwt.t + + val get_ballots : context -> ballots tzresult Lwt.t + + val get_ballot_list : + context -> (Signature.Public_key_hash.t * ballot) list Lwt.t + + val clear_ballots : context -> context Lwt.t + + val get_current_quorum : context -> int32 tzresult Lwt.t + + val get_participation_ema : context -> int32 tzresult Lwt.t + + val set_participation_ema : context -> int32 -> context tzresult Lwt.t + + val get_current_proposal : context -> proposal tzresult Lwt.t + + val init_current_proposal : context -> proposal -> context tzresult Lwt.t + + val clear_current_proposal : context -> context tzresult Lwt.t +end + +module Block_header : sig + type t = {shell : Block_header.shell_header; protocol_data : protocol_data} + + and protocol_data = {contents : contents; signature : Signature.t} + + and contents = { + priority : int; + seed_nonce_hash : Nonce_hash.t option; + proof_of_work_nonce : bytes; + } + + type block_header = t + + type raw = Block_header.t + + type shell_header = Block_header.shell_header + + val raw : block_header -> raw + + val hash : block_header -> Block_hash.t + + val hash_raw : raw -> Block_hash.t + + val encoding : block_header Data_encoding.encoding + + val raw_encoding : raw Data_encoding.t + + val contents_encoding : contents Data_encoding.t + + val unsigned_encoding : (shell_header * contents) Data_encoding.t + + val protocol_data_encoding : protocol_data Data_encoding.encoding + + val shell_header_encoding : shell_header Data_encoding.encoding + + (** The maximum size of block headers in bytes *) + val max_header_length : int +end + +module Kind : sig + type seed_nonce_revelation = Seed_nonce_revelation_kind + + type double_endorsement_evidence = Double_endorsement_evidence_kind + + type double_baking_evidence = Double_baking_evidence_kind + + type activate_account = Activate_account_kind + + type endorsement = Endorsement_kind + + type proposals = Proposals_kind + + type ballot = Ballot_kind + + type reveal = Reveal_kind + + type transaction = Transaction_kind + + type origination = Origination_kind + + type delegation = Delegation_kind + + type 'a manager = + | Reveal_manager_kind : reveal manager + | Transaction_manager_kind : transaction manager + | Origination_manager_kind : origination manager + | Delegation_manager_kind : delegation manager +end + +type 'kind operation = { + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; +} + +and 'kind protocol_data = { + contents : 'kind contents_list; + signature : Signature.t option; +} + +and _ contents_list = + | Single : 'kind contents -> 'kind contents_list + | Cons : + 'kind Kind.manager contents * 'rest Kind.manager contents_list + -> ('kind * 'rest) Kind.manager contents_list + +and _ contents = + | Endorsement : {level : Raw_level.t} -> Kind.endorsement contents + | Seed_nonce_revelation : { + level : Raw_level.t; + nonce : Nonce.t; + } + -> Kind.seed_nonce_revelation contents + | Double_endorsement_evidence : { + op1 : Kind.endorsement operation; + op2 : Kind.endorsement operation; + } + -> Kind.double_endorsement_evidence contents + | Double_baking_evidence : { + bh1 : Block_header.t; + bh2 : Block_header.t; + } + -> Kind.double_baking_evidence contents + | Activate_account : { + id : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + } + -> Kind.activate_account contents + | Proposals : { + source : Signature.Public_key_hash.t; + period : int32; + proposals : Protocol_hash.t list; + } + -> Kind.proposals contents + | Ballot : { + source : Signature.Public_key_hash.t; + period : int32; + proposal : Protocol_hash.t; + ballot : Vote.ballot; + } + -> Kind.ballot contents + | Manager_operation : { + source : Signature.Public_key_hash.t; + fee : Tez.tez; + counter : counter; + operation : 'kind manager_operation; + gas_limit : Gas.Arith.integral; + storage_limit : Z.t; + } + -> 'kind Kind.manager contents + +and _ manager_operation = + | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation + | Transaction : { + amount : Tez.tez; + parameters : Script.lazy_expr; + entrypoint : string; + destination : Contract.contract; + } + -> Kind.transaction manager_operation + | Origination : { + delegate : Signature.Public_key_hash.t option; + script : Script.t; + credit : Tez.tez; + preorigination : Contract.t option; + } + -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation + +and counter = Z.t + +type 'kind internal_operation = { + source : Contract.contract; + operation : 'kind manager_operation; + nonce : int; +} + +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation + +type packed_contents = Contents : 'kind contents -> packed_contents + +type packed_contents_list = + | Contents_list : 'kind contents_list -> packed_contents_list + +type packed_protocol_data = + | Operation_data : 'kind protocol_data -> packed_protocol_data + +type packed_operation = { + shell : Operation.shell_header; + protocol_data : packed_protocol_data; +} + +type packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation + +val manager_kind : 'kind manager_operation -> 'kind Kind.manager + +module Fees : sig + val origination_burn : context -> (context * Tez.t) tzresult + + val record_paid_storage_space : + context -> Contract.t -> (context * Z.t * Z.t * Tez.t) tzresult Lwt.t + + val start_counting_storage_fees : context -> context + + val burn_storage_fees : + context -> storage_limit:Z.t -> payer:Contract.t -> context tzresult Lwt.t + + type error += Cannot_pay_storage_fee (* `Temporary *) + + type error += Operation_quota_exceeded (* `Temporary *) + + type error += Storage_limit_too_high (* `Permanent *) + + val check_storage_limit : context -> storage_limit:Z.t -> unit tzresult +end + +module Operation : sig + type nonrec 'kind contents = 'kind contents + + type nonrec packed_contents = packed_contents + + val contents_encoding : packed_contents Data_encoding.t + + type nonrec 'kind protocol_data = 'kind protocol_data + + type nonrec packed_protocol_data = packed_protocol_data + + val protocol_data_encoding : packed_protocol_data Data_encoding.t + + val unsigned_encoding : + (Operation.shell_header * packed_contents_list) Data_encoding.t + + type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} + + val raw_encoding : raw Data_encoding.t + + val contents_list_encoding : packed_contents_list Data_encoding.t + + type 'kind t = 'kind operation = { + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; + } + + type nonrec packed = packed_operation + + val encoding : packed Data_encoding.t + + val raw : _ operation -> raw + + val hash : _ operation -> Operation_hash.t + + val hash_raw : raw -> Operation_hash.t + + val hash_packed : packed_operation -> Operation_hash.t + + val acceptable_passes : packed_operation -> int list + + type error += Missing_signature (* `Permanent *) + + type error += Invalid_signature (* `Permanent *) + + val check_signature : + public_key -> Chain_id.t -> _ operation -> unit tzresult + + val internal_operation_encoding : packed_internal_operation Data_encoding.t + + val pack : 'kind operation -> packed_operation + + type ('a, 'b) eq = Eq : ('a, 'a) eq + + val equal : 'a operation -> 'b operation -> ('a, 'b) eq option + + module Encoding : sig + type 'b case = + | Case : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : packed_contents -> 'b contents option; + proj : 'b contents -> 'a; + inj : 'a -> 'b contents; + } + -> 'b case + + val endorsement_case : Kind.endorsement case + + val seed_nonce_revelation_case : Kind.seed_nonce_revelation case + + val double_endorsement_evidence_case : + Kind.double_endorsement_evidence case + + val double_baking_evidence_case : Kind.double_baking_evidence case + + val activate_account_case : Kind.activate_account case + + val proposals_case : Kind.proposals case + + val ballot_case : Kind.ballot case + + val reveal_case : Kind.reveal Kind.manager case + + val transaction_case : Kind.transaction Kind.manager case + + val origination_case : Kind.origination Kind.manager case + + val delegation_case : Kind.delegation Kind.manager case + + module Manager_operations : sig + type 'b case = + | MCase : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : + packed_manager_operation -> 'kind manager_operation option; + proj : 'kind manager_operation -> 'a; + inj : 'a -> 'kind manager_operation; + } + -> 'kind case + + val reveal_case : Kind.reveal case + + val transaction_case : Kind.transaction case + + val origination_case : Kind.origination case + + val delegation_case : Kind.delegation case + end + end + + val of_list : packed_contents list -> packed_contents_list + + val to_list : packed_contents_list -> packed_contents list +end + +module Roll : sig + type t = private int32 + + type roll = t + + val encoding : roll Data_encoding.t + + val snapshot_rolls : context -> context tzresult Lwt.t + + val cycle_end : context -> Cycle.t -> context tzresult Lwt.t + + val baking_rights_owner : + context -> Level.t -> priority:int -> public_key tzresult Lwt.t + + val endorsement_rights_owner : + context -> Level.t -> slot:int -> public_key tzresult Lwt.t + + val delegate_pubkey : context -> public_key_hash -> public_key tzresult Lwt.t + + val get_rolls : + context -> Signature.Public_key_hash.t -> roll list tzresult Lwt.t + + val get_change : + context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t +end + +module Commitment : sig + type t = { + blinded_public_key_hash : Blinded_public_key_hash.t; + amount : Tez.tez; + } + + val get_opt : + context -> Blinded_public_key_hash.t -> Tez.t option tzresult Lwt.t + + val delete : context -> Blinded_public_key_hash.t -> context tzresult Lwt.t +end + +module Bootstrap : sig + val cycle_end : context -> Cycle.t -> context tzresult Lwt.t +end + +module Global : sig + val get_block_priority : context -> int tzresult Lwt.t + + val set_block_priority : context -> int -> context tzresult Lwt.t +end + +val prepare_first_block : + Context.t -> + typecheck:(context -> + Script.t -> + ((Script.t * Lazy_storage.diffs option) * context) tzresult Lwt.t) -> + level:Int32.t -> + timestamp:Time.t -> + fitness:Fitness.t -> + context tzresult Lwt.t + +val prepare : + Context.t -> + level:Int32.t -> + predecessor_timestamp:Time.t -> + timestamp:Time.t -> + fitness:Fitness.t -> + context tzresult Lwt.t + +val finalize : ?commit_message:string -> context -> Updater.validation_result + +val activate : context -> Protocol_hash.t -> context Lwt.t + +val fork_test_chain : context -> Protocol_hash.t -> Time.t -> context Lwt.t + +val record_endorsement : context -> Signature.Public_key_hash.t -> context + +val allowed_endorsements : + context -> + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t + +val init_endorsements : + context -> + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t -> + context + +val included_endorsements : context -> int + +val reset_internal_nonce : context -> context + +val fresh_internal_nonce : context -> (context * int) tzresult + +val record_internal_nonce : context -> int -> context + +val internal_nonce_already_recorded : context -> int -> bool + +val add_fees : context -> Tez.t -> context tzresult + +val add_rewards : context -> Tez.t -> context tzresult + +val add_deposit : + context -> Signature.Public_key_hash.t -> Tez.t -> context tzresult + +val get_fees : context -> Tez.t + +val get_rewards : context -> Tez.t + +val get_deposits : context -> Tez.t Signature.Public_key_hash.Map.t + +val description : context Storage_description.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/alpha_services.ml b/src/proto_008_PtEdo2Zk/lib_protocol/alpha_services.ml new file mode 100644 index 0000000000000000000000000000000000000000..c774f0c74215eb6258bf70b55daefafee125d3c6 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/alpha_services.ml @@ -0,0 +1,120 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +let custom_root = RPC_path.open_root + +module Seed = struct + module S = struct + open Data_encoding + + let seed = + RPC_service.post_service + ~description:"Seed of the cycle to which the block belongs." + ~query:RPC_query.empty + ~input:empty + ~output:Seed.seed_encoding + RPC_path.(custom_root / "context" / "seed") + end + + let () = + let open Services_registration in + register0 S.seed (fun ctxt () () -> + let l = Level.current ctxt in + Seed.for_cycle ctxt l.cycle) + + let get ctxt block = RPC_context.make_call0 S.seed ctxt block () () +end + +module Nonce = struct + type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten + + let info_encoding = + let open Data_encoding in + union + [ case + (Tag 0) + ~title:"Revealed" + (obj1 (req "nonce" Nonce.encoding)) + (function Revealed nonce -> Some nonce | _ -> None) + (fun nonce -> Revealed nonce); + case + (Tag 1) + ~title:"Missing" + (obj1 (req "hash" Nonce_hash.encoding)) + (function Missing nonce -> Some nonce | _ -> None) + (fun nonce -> Missing nonce); + case + (Tag 2) + ~title:"Forgotten" + empty + (function Forgotten -> Some () | _ -> None) + (fun () -> Forgotten) ] + + module S = struct + let get = + RPC_service.get_service + ~description:"Info about the nonce of a previous block." + ~query:RPC_query.empty + ~output:info_encoding + RPC_path.(custom_root / "context" / "nonces" /: Raw_level.rpc_arg) + end + + let register () = + let open Services_registration in + register1 S.get (fun ctxt raw_level () () -> + let level = Level.from_raw ctxt raw_level in + Nonce.get ctxt level + >|= function + | Ok (Revealed nonce) -> + ok (Revealed nonce) + | Ok (Unrevealed {nonce_hash; _}) -> + ok (Missing nonce_hash) + | Error _ -> + ok Forgotten) + + let get ctxt block level = + RPC_context.make_call1 S.get ctxt block level () () +end + +module Contract = Contract_services +module Constants = Constants_services +module Delegate = Delegate_services +module Helpers = Helpers_services +module Forge = Helpers_services.Forge +module Parse = Helpers_services.Parse +module Voting = Voting_services +module Sapling = Sapling_services + +let register () = + Contract.register () ; + Constants.register () ; + Delegate.register () ; + Helpers.register () ; + Nonce.register () ; + Voting.register () ; + Sapling.register () diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/alpha_services.mli b/src/proto_008_PtEdo2Zk/lib_protocol/alpha_services.mli new file mode 100644 index 0000000000000000000000000000000000000000..7c59bf7f2a18d08464deb75e028f8172dac37953 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/alpha_services.mli @@ -0,0 +1,49 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +module Seed : sig + val get : 'a #RPC_context.simple -> 'a -> Seed.seed shell_tzresult Lwt.t +end + +module Nonce : sig + type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten + + val get : + 'a #RPC_context.simple -> 'a -> Raw_level.t -> info shell_tzresult Lwt.t +end + +module Contract = Contract_services +module Constants = Constants_services +module Delegate = Delegate_services +module Helpers = Helpers_services +module Forge = Helpers_services.Forge +module Parse = Helpers_services.Parse +module Voting = Voting_services +module Sapling = Sapling_services + +val register : unit -> unit diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/amendment.ml b/src/proto_008_PtEdo2Zk/lib_protocol/amendment.ml new file mode 100644 index 0000000000000000000000000000000000000000..2395f3bc81327f5542bf1559c2a111f39ad536a7 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/amendment.ml @@ -0,0 +1,306 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +(** Returns the proposal submitted by the most delegates. + Returns None in case of a tie, if proposal quorum is below required + minimum or if there are no proposals. *) +let select_winning_proposal ctxt = + Vote.get_proposals ctxt + >>=? fun proposals -> + let merge proposal vote winners = + match winners with + | None -> + Some ([proposal], vote) + | Some (winners, winners_vote) as previous -> + if Compare.Int32.(vote = winners_vote) then + Some (proposal :: winners, winners_vote) + else if Compare.Int32.(vote > winners_vote) then Some ([proposal], vote) + else previous + in + match Protocol_hash.Map.fold merge proposals None with + | Some ([proposal], vote) -> + Vote.listing_size ctxt + >>=? fun max_vote -> + let min_proposal_quorum = Constants.min_proposal_quorum ctxt in + let min_vote_to_pass = + Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l + in + if Compare.Int32.(vote >= min_vote_to_pass) then return_some proposal + else return_none + | _ -> + return_none + +(* in case of a tie, let's do nothing. *) + +(** A proposal is approved if it has supermajority and the participation reaches + the current quorum. + Supermajority means the yays are more 8/10 of casted votes. + The participation is the ratio of all received votes, including passes, with + respect to the number of possible votes. + The participation EMA (exponential moving average) uses the last + participation EMA and the current participation./ + The expected quorum is calculated using the last participation EMA, capped + by the min/max quorum protocol constants. *) +let approval_and_participation_ema (ballots : Vote.ballots) ~maximum_vote + ~participation_ema ~expected_quorum = + (* Note overflows: considering a maximum of 8e8 tokens, with roll size as + small as 1e3, there is a maximum of 8e5 rolls and thus votes. + In 'participation' an Int64 is used because in the worst case 'all_votes is + 8e5 and after the multiplication is 8e9, making it potentially overflow a + signed Int32 which is 2e9. *) + let casted_votes = Int32.add ballots.yay ballots.nay in + let all_votes = Int32.add casted_votes ballots.pass in + let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in + let participation = + (* in centile of percentage *) + Int64.( + to_int32 (div (mul (of_int32 all_votes) 100_00L) (of_int32 maximum_vote))) + in + let approval = + Compare.Int32.( + participation >= expected_quorum && ballots.yay >= supermajority) + in + let new_participation_ema = + Int32.(div (add (mul 8l participation_ema) (mul 2l participation)) 10l) + in + (approval, new_participation_ema) + +let get_approval_and_update_participation_ema ctxt = + Vote.get_ballots ctxt + >>=? fun ballots -> + Vote.listing_size ctxt + >>=? fun maximum_vote -> + Vote.get_participation_ema ctxt + >>=? fun participation_ema -> + Vote.get_current_quorum ctxt + >>=? fun expected_quorum -> + Vote.clear_ballots ctxt + >>= fun ctxt -> + let (approval, new_participation_ema) = + approval_and_participation_ema + ballots + ~maximum_vote + ~participation_ema + ~expected_quorum + in + Vote.set_participation_ema ctxt new_participation_ema + >|=? fun ctxt -> (ctxt, approval) + +(** Implements the state machine of the amendment procedure. Note that + [update_listings], that computes the vote weight of each delegate, is run at + the end of each voting period. This state-machine prepare the voting_period + for the next block. *) +let start_new_voting_period ctxt = + Voting_period.get_current_kind ctxt + >>=? fun kind -> + ( match kind with + | Proposal -> ( + select_winning_proposal ctxt + >>=? fun proposal -> + Vote.clear_proposals ctxt + >>= fun ctxt -> + match proposal with + | None -> + Voting_period.reset ctxt + | Some proposal -> + Vote.init_current_proposal ctxt proposal >>=? Voting_period.succ ) + | Testing_vote -> + get_approval_and_update_participation_ema ctxt + >>=? fun (ctxt, approved) -> + if approved then + let expiration = + Time.add + (Timestamp.current ctxt) + (Constants.test_chain_duration ctxt) + in + Vote.get_current_proposal ctxt + >>=? fun proposal -> + fork_test_chain ctxt proposal expiration >>= Voting_period.succ + else + Vote.clear_current_proposal ctxt + >>=? fun ctxt -> Voting_period.reset ctxt + | Testing -> + Voting_period.succ ctxt + | Promotion_vote -> + get_approval_and_update_participation_ema ctxt + >>=? fun (ctxt, approved) -> + if approved then Voting_period.succ ctxt + else Vote.clear_current_proposal ctxt >>=? Voting_period.reset + | Adoption -> + Vote.get_current_proposal ctxt + >>=? fun proposal -> + activate ctxt proposal + >>= fun ctxt -> Vote.clear_current_proposal ctxt >>=? Voting_period.reset + ) + >>=? fun ctxt -> Vote.update_listings ctxt + +type error += + | (* `Branch *) + Invalid_proposal + | Unexpected_proposal + | Unauthorized_proposal + | Too_many_proposals + | Empty_proposal + | Unexpected_ballot + | Unauthorized_ballot + +let () = + let open Data_encoding in + (* Invalid proposal *) + register_error_kind + `Branch + ~id:"invalid_proposal" + ~title:"Invalid proposal" + ~description:"Ballot provided for a proposal that is not the current one." + ~pp:(fun ppf () -> Format.fprintf ppf "Invalid proposal") + empty + (function Invalid_proposal -> Some () | _ -> None) + (fun () -> Invalid_proposal) ; + (* Unexpected proposal *) + register_error_kind + `Branch + ~id:"unexpected_proposal" + ~title:"Unexpected proposal" + ~description:"Proposal recorded outside of a proposal period." + ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected proposal") + empty + (function Unexpected_proposal -> Some () | _ -> None) + (fun () -> Unexpected_proposal) ; + (* Unauthorized proposal *) + register_error_kind + `Branch + ~id:"unauthorized_proposal" + ~title:"Unauthorized proposal" + ~description: + "The delegate provided for the proposal is not in the voting listings." + ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized proposal") + empty + (function Unauthorized_proposal -> Some () | _ -> None) + (fun () -> Unauthorized_proposal) ; + (* Unexpected ballot *) + register_error_kind + `Branch + ~id:"unexpected_ballot" + ~title:"Unexpected ballot" + ~description:"Ballot recorded outside of a voting period." + ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected ballot") + empty + (function Unexpected_ballot -> Some () | _ -> None) + (fun () -> Unexpected_ballot) ; + (* Unauthorized ballot *) + register_error_kind + `Branch + ~id:"unauthorized_ballot" + ~title:"Unauthorized ballot" + ~description: + "The delegate provided for the ballot is not in the voting listings." + ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized ballot") + empty + (function Unauthorized_ballot -> Some () | _ -> None) + (fun () -> Unauthorized_ballot) ; + (* Too many proposals *) + register_error_kind + `Branch + ~id:"too_many_proposals" + ~title:"Too many proposals" + ~description: + "The delegate reached the maximum number of allowed proposals." + ~pp:(fun ppf () -> Format.fprintf ppf "Too many proposals") + empty + (function Too_many_proposals -> Some () | _ -> None) + (fun () -> Too_many_proposals) ; + (* Empty proposal *) + register_error_kind + `Branch + ~id:"empty_proposal" + ~title:"Empty proposal" + ~description:"Proposal lists cannot be empty." + ~pp:(fun ppf () -> Format.fprintf ppf "Empty proposal") + empty + (function Empty_proposal -> Some () | _ -> None) + (fun () -> Empty_proposal) + +(* @return [true] if [List.length l] > [n] w/o computing length *) +let rec longer_than l n = + if Compare.Int.(n < 0) then assert false + else + match l with + | [] -> + false + | _ :: rest -> + if Compare.Int.(n = 0) then true + else (* n > 0 *) + longer_than rest (n - 1) + +let record_proposals ctxt delegate proposals = + (match proposals with [] -> error Empty_proposal | _ :: _ -> ok_unit) + >>?= fun () -> + Voting_period.get_current_kind ctxt + >>=? function + | Proposal -> + Vote.in_listings ctxt delegate + >>= fun in_listings -> + if in_listings then + Vote.recorded_proposal_count_for_delegate ctxt delegate + >>=? fun count -> + error_when + (longer_than proposals (Constants.max_proposals_per_delegate - count)) + Too_many_proposals + >>?= fun () -> + fold_left_s + (fun ctxt proposal -> Vote.record_proposal ctxt proposal delegate) + ctxt + proposals + else fail Unauthorized_proposal + | Testing_vote | Testing | Promotion_vote | Adoption -> + fail Unexpected_proposal + +let record_ballot ctxt delegate proposal ballot = + Voting_period.get_current_kind ctxt + >>=? function + | Testing_vote | Promotion_vote -> + Vote.get_current_proposal ctxt + >>=? fun current_proposal -> + error_unless + (Protocol_hash.equal proposal current_proposal) + Invalid_proposal + >>?= fun () -> + Vote.has_recorded_ballot ctxt delegate + >>= fun has_ballot -> + error_when has_ballot Unauthorized_ballot + >>?= fun () -> + Vote.in_listings ctxt delegate + >>= fun in_listings -> + if in_listings then Vote.record_ballot ctxt delegate ballot + else fail Unauthorized_ballot + | Testing | Proposal | Adoption -> + fail Unexpected_ballot + +let may_start_new_voting_period ctxt = + Voting_period.is_last_block ctxt + >>=? fun is_last -> + if is_last then start_new_voting_period ctxt else return ctxt diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/amendment.mli b/src/proto_008_PtEdo2Zk/lib_protocol/amendment.mli new file mode 100644 index 0000000000000000000000000000000000000000..44de31f17c90cc5019c67aeab5ee51bcec2de81f --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/amendment.mli @@ -0,0 +1,77 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** + Only delegates with at least one roll take part in the amendment procedure. + It works as follows: + - Proposal period: delegates can submit protocol amendment proposals using + the proposal operation. At the end of a proposal period, the proposal with + most supporters is selected and we move to a testing_vote period. + If there are no proposals, or a tie between proposals, a new proposal + period starts. + - Testing_vote period: delegates can cast votes to test or not the winning + proposal using the ballot operation. + At the end of a testing_vote period if participation reaches the quorum + and the proposal has a supermajority in favor, we proceed to a testing + period. Otherwise we go back to a proposal period. + In any case, if there is enough participation the quorum is updated. + - Testing period: a test chain is forked for the length of the period. + At the end of a testing period we move to a promotion_vote period. + - Promotion_vote period: delegates can cast votes to promote or not the + tested proposal using the ballot operation. + At the end of a promotion_vote period if participation reaches the quorum + and the tested proposal has a supermajority in favor, we move to + an adoption period. Otherwise we go back to a proposal period. + In any case, if there is enough participation the quorum is updated. + - Adoption period: At the end of an adoption period, the proposal is activated + as the new protocol. +*) + +open Alpha_context + +(** If at the end of a voting period, moves to the next one following + the state machine of the amendment procedure. *) +val may_start_new_voting_period : context -> context tzresult Lwt.t + +type error += + | Unexpected_proposal + | Unauthorized_proposal + | Too_many_proposals + | Empty_proposal + +(** Records a list of proposals for a delegate. + @raise Unexpected_proposal if [ctxt] is not in a proposal period. + @raise Unauthorized_proposal if [delegate] is not in the listing. *) +val record_proposals : + context -> public_key_hash -> Protocol_hash.t list -> context tzresult Lwt.t + +type error += Invalid_proposal | Unexpected_ballot | Unauthorized_ballot + +val record_ballot : + context -> + public_key_hash -> + Protocol_hash.t -> + Vote.ballot -> + context tzresult Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/apply.ml b/src/proto_008_PtEdo2Zk/lib_protocol/apply.ml new file mode 100644 index 0000000000000000000000000000000000000000..ca28d5e16812ef732ed7e521fd03cbabd8242bf1 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/apply.ml @@ -0,0 +1,1538 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos Protocol Implementation - Main Entry Points *) + +open Alpha_context + +type error += Wrong_voting_period of int32 * int32 + +(* `Temporary *) + +type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t + +(* `Temporary *) + +type error += Duplicate_endorsement of Signature.Public_key_hash.t + +(* `Branch *) + +type error += Invalid_endorsement_level + +type error += Invalid_commitment of {expected : bool} + +type error += Internal_operation_replay of packed_internal_operation + +type error += Invalid_double_endorsement_evidence (* `Permanent *) + +type error += + | Inconsistent_double_endorsement_evidence of { + delegate1 : Signature.Public_key_hash.t; + delegate2 : Signature.Public_key_hash.t; + } + +(* `Permanent *) + +type error += Unrequired_double_endorsement_evidence (* `Branch*) + +type error += + | Too_early_double_endorsement_evidence of { + level : Raw_level.t; + current : Raw_level.t; + } + +(* `Temporary *) + +type error += + | Outdated_double_endorsement_evidence of { + level : Raw_level.t; + last : Raw_level.t; + } + +(* `Permanent *) + +type error += + | Invalid_double_baking_evidence of { + hash1 : Block_hash.t; + level1 : Int32.t; + hash2 : Block_hash.t; + level2 : Int32.t; + } + +(* `Permanent *) + +type error += + | Inconsistent_double_baking_evidence of { + delegate1 : Signature.Public_key_hash.t; + delegate2 : Signature.Public_key_hash.t; + } + +(* `Permanent *) + +type error += Unrequired_double_baking_evidence (* `Branch*) + +type error += + | Too_early_double_baking_evidence of { + level : Raw_level.t; + current : Raw_level.t; + } + +(* `Temporary *) + +type error += + | Outdated_double_baking_evidence of { + level : Raw_level.t; + last : Raw_level.t; + } + +(* `Permanent *) + +type error += Invalid_activation of {pkh : Ed25519.Public_key_hash.t} + +type error += Multiple_revelation + +type error += Gas_quota_exceeded_init_deserialize (* Permanent *) + +type error += (* `Permanent *) Inconsistent_sources + +type error += + | Not_enough_endorsements_for_priority of { + required : int; + priority : int; + endorsements : int; + timestamp : Time.t; + } + +let () = + register_error_kind + `Temporary + ~id:"operation.wrong_endorsement_predecessor" + ~title:"Wrong endorsement predecessor" + ~description: + "Trying to include an endorsement in a block that is not the successor \ + of the endorsed one" + ~pp:(fun ppf (e, p) -> + Format.fprintf + ppf + "Wrong predecessor %a, expected %a" + Block_hash.pp + p + Block_hash.pp + e) + Data_encoding.( + obj2 + (req "expected" Block_hash.encoding) + (req "provided" Block_hash.encoding)) + (function + | Wrong_endorsement_predecessor (e, p) -> Some (e, p) | _ -> None) + (fun (e, p) -> Wrong_endorsement_predecessor (e, p)) ; + register_error_kind + `Temporary + ~id:"operation.wrong_voting_period" + ~title:"Wrong voting period" + ~description: + "Trying to include a proposal or ballot meant for another voting period" + ~pp:(fun ppf (e, p) -> + Format.fprintf ppf "Wrong voting period %ld, current is %ld" p e) + Data_encoding.( + obj2 (req "current_index" int32) (req "provided_index" int32)) + (function Wrong_voting_period (e, p) -> Some (e, p) | _ -> None) + (fun (e, p) -> Wrong_voting_period (e, p)) ; + register_error_kind + `Branch + ~id:"operation.duplicate_endorsement" + ~title:"Duplicate endorsement" + ~description:"Two endorsements received from same delegate" + ~pp:(fun ppf k -> + Format.fprintf + ppf + "Duplicate endorsement from delegate %a (possible replay attack)." + Signature.Public_key_hash.pp_short + k) + Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding)) + (function Duplicate_endorsement k -> Some k | _ -> None) + (fun k -> Duplicate_endorsement k) ; + register_error_kind + `Temporary + ~id:"operation.invalid_endorsement_level" + ~title:"Unexpected level in endorsement" + ~description: + "The level of an endorsement is inconsistent with the provided block \ + hash." + ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected level in endorsement.") + Data_encoding.unit + (function Invalid_endorsement_level -> Some () | _ -> None) + (fun () -> Invalid_endorsement_level) ; + register_error_kind + `Permanent + ~id:"block.invalid_commitment" + ~title:"Invalid commitment in block header" + ~description:"The block header has invalid commitment." + ~pp:(fun ppf expected -> + if expected then + Format.fprintf ppf "Missing seed's nonce commitment in block header." + else + Format.fprintf + ppf + "Unexpected seed's nonce commitment in block header.") + Data_encoding.(obj1 (req "expected" bool)) + (function Invalid_commitment {expected} -> Some expected | _ -> None) + (fun expected -> Invalid_commitment {expected}) ; + register_error_kind + `Permanent + ~id:"internal_operation_replay" + ~title:"Internal operation replay" + ~description:"An internal operation was emitted twice by a script" + ~pp:(fun ppf (Internal_operation {nonce; _}) -> + Format.fprintf + ppf + "Internal operation %d was emitted twice by a script" + nonce) + Operation.internal_operation_encoding + (function Internal_operation_replay op -> Some op | _ -> None) + (fun op -> Internal_operation_replay op) ; + register_error_kind + `Permanent + ~id:"block.invalid_double_endorsement_evidence" + ~title:"Invalid double endorsement evidence" + ~description:"A double-endorsement evidence is malformed" + ~pp:(fun ppf () -> + Format.fprintf ppf "Malformed double-endorsement evidence") + Data_encoding.empty + (function Invalid_double_endorsement_evidence -> Some () | _ -> None) + (fun () -> Invalid_double_endorsement_evidence) ; + register_error_kind + `Permanent + ~id:"block.inconsistent_double_endorsement_evidence" + ~title:"Inconsistent double endorsement evidence" + ~description: + "A double-endorsement evidence is inconsistent (two distinct delegates)" + ~pp:(fun ppf (delegate1, delegate2) -> + Format.fprintf + ppf + "Inconsistent double-endorsement evidence (distinct delegate: %a and \ + %a)" + Signature.Public_key_hash.pp_short + delegate1 + Signature.Public_key_hash.pp_short + delegate2) + Data_encoding.( + obj2 + (req "delegate1" Signature.Public_key_hash.encoding) + (req "delegate2" Signature.Public_key_hash.encoding)) + (function + | Inconsistent_double_endorsement_evidence {delegate1; delegate2} -> + Some (delegate1, delegate2) + | _ -> + None) + (fun (delegate1, delegate2) -> + Inconsistent_double_endorsement_evidence {delegate1; delegate2}) ; + register_error_kind + `Branch + ~id:"block.unrequired_double_endorsement_evidence" + ~title:"Unrequired double endorsement evidence" + ~description:"A double-endorsement evidence is unrequired" + ~pp:(fun ppf () -> + Format.fprintf + ppf + "A valid double-endorsement operation cannot be applied: the \ + associated delegate has previously been denounced in this cycle.") + Data_encoding.empty + (function Unrequired_double_endorsement_evidence -> Some () | _ -> None) + (fun () -> Unrequired_double_endorsement_evidence) ; + register_error_kind + `Temporary + ~id:"block.too_early_double_endorsement_evidence" + ~title:"Too early double endorsement evidence" + ~description:"A double-endorsement evidence is in the future" + ~pp:(fun ppf (level, current) -> + Format.fprintf + ppf + "A double-endorsement evidence is in the future (current level: %a, \ + endorsement level: %a)" + Raw_level.pp + current + Raw_level.pp + level) + Data_encoding.( + obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding)) + (function + | Too_early_double_endorsement_evidence {level; current} -> + Some (level, current) + | _ -> + None) + (fun (level, current) -> + Too_early_double_endorsement_evidence {level; current}) ; + register_error_kind + `Permanent + ~id:"block.outdated_double_endorsement_evidence" + ~title:"Outdated double endorsement evidence" + ~description:"A double-endorsement evidence is outdated." + ~pp:(fun ppf (level, last) -> + Format.fprintf + ppf + "A double-endorsement evidence is outdated (last acceptable level: \ + %a, endorsement level: %a)" + Raw_level.pp + last + Raw_level.pp + level) + Data_encoding.( + obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding)) + (function + | Outdated_double_endorsement_evidence {level; last} -> + Some (level, last) + | _ -> + None) + (fun (level, last) -> Outdated_double_endorsement_evidence {level; last}) ; + register_error_kind + `Permanent + ~id:"block.invalid_double_baking_evidence" + ~title:"Invalid double baking evidence" + ~description: + "A double-baking evidence is inconsistent (two distinct level)" + ~pp:(fun ppf (hash1, level1, hash2, level2) -> + Format.fprintf + ppf + "Invalid double-baking evidence (hash: %a and %a, levels: %ld and %ld)" + Block_hash.pp + hash1 + Block_hash.pp + hash2 + level1 + level2) + Data_encoding.( + obj4 + (req "hash1" Block_hash.encoding) + (req "level1" int32) + (req "hash2" Block_hash.encoding) + (req "level2" int32)) + (function + | Invalid_double_baking_evidence {hash1; level1; hash2; level2} -> + Some (hash1, level1, hash2, level2) + | _ -> + None) + (fun (hash1, level1, hash2, level2) -> + Invalid_double_baking_evidence {hash1; level1; hash2; level2}) ; + register_error_kind + `Permanent + ~id:"block.inconsistent_double_baking_evidence" + ~title:"Inconsistent double baking evidence" + ~description: + "A double-baking evidence is inconsistent (two distinct delegates)" + ~pp:(fun ppf (delegate1, delegate2) -> + Format.fprintf + ppf + "Inconsistent double-baking evidence (distinct delegate: %a and %a)" + Signature.Public_key_hash.pp_short + delegate1 + Signature.Public_key_hash.pp_short + delegate2) + Data_encoding.( + obj2 + (req "delegate1" Signature.Public_key_hash.encoding) + (req "delegate2" Signature.Public_key_hash.encoding)) + (function + | Inconsistent_double_baking_evidence {delegate1; delegate2} -> + Some (delegate1, delegate2) + | _ -> + None) + (fun (delegate1, delegate2) -> + Inconsistent_double_baking_evidence {delegate1; delegate2}) ; + register_error_kind + `Branch + ~id:"block.unrequired_double_baking_evidence" + ~title:"Unrequired double baking evidence" + ~description:"A double-baking evidence is unrequired" + ~pp:(fun ppf () -> + Format.fprintf + ppf + "A valid double-baking operation cannot be applied: the associated \ + delegate has previously been denounced in this cycle.") + Data_encoding.empty + (function Unrequired_double_baking_evidence -> Some () | _ -> None) + (fun () -> Unrequired_double_baking_evidence) ; + register_error_kind + `Temporary + ~id:"block.too_early_double_baking_evidence" + ~title:"Too early double baking evidence" + ~description:"A double-baking evidence is in the future" + ~pp:(fun ppf (level, current) -> + Format.fprintf + ppf + "A double-baking evidence is in the future (current level: %a, \ + baking level: %a)" + Raw_level.pp + current + Raw_level.pp + level) + Data_encoding.( + obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding)) + (function + | Too_early_double_baking_evidence {level; current} -> + Some (level, current) + | _ -> + None) + (fun (level, current) -> Too_early_double_baking_evidence {level; current}) ; + register_error_kind + `Permanent + ~id:"block.outdated_double_baking_evidence" + ~title:"Outdated double baking evidence" + ~description:"A double-baking evidence is outdated." + ~pp:(fun ppf (level, last) -> + Format.fprintf + ppf + "A double-baking evidence is outdated (last acceptable level: %a, \ + baking level: %a)" + Raw_level.pp + last + Raw_level.pp + level) + Data_encoding.( + obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding)) + (function + | Outdated_double_baking_evidence {level; last} -> + Some (level, last) + | _ -> + None) + (fun (level, last) -> Outdated_double_baking_evidence {level; last}) ; + register_error_kind + `Permanent + ~id:"operation.invalid_activation" + ~title:"Invalid activation" + ~description: + "The given key and secret do not correspond to any existing \ + preallocated contract" + ~pp:(fun ppf pkh -> + Format.fprintf + ppf + "Invalid activation. The public key %a does not match any commitment." + Ed25519.Public_key_hash.pp + pkh) + Data_encoding.(obj1 (req "pkh" Ed25519.Public_key_hash.encoding)) + (function Invalid_activation {pkh} -> Some pkh | _ -> None) + (fun pkh -> Invalid_activation {pkh}) ; + register_error_kind + `Permanent + ~id:"block.multiple_revelation" + ~title:"Multiple revelations were included in a manager operation" + ~description: + "A manager operation should not contain more than one revelation" + ~pp:(fun ppf () -> + Format.fprintf + ppf + "Multiple revelations were included in a manager operation") + Data_encoding.empty + (function Multiple_revelation -> Some () | _ -> None) + (fun () -> Multiple_revelation) ; + register_error_kind + `Permanent + ~id:"gas_exhausted.init_deserialize" + ~title:"Not enough gas for initial deserialization of script expressions" + ~description: + "Gas limit was not high enough to deserialize the transaction \ + parameters or origination script code or initial storage, making the \ + operation impossible to parse within the provided gas bounds." + Data_encoding.empty + (function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None) + (fun () -> Gas_quota_exceeded_init_deserialize) ; + register_error_kind + `Permanent + ~id:"operation.inconsistent_sources" + ~title:"Inconsistent sources in operation pack" + ~description: + "The operation pack includes operations from different sources." + ~pp:(fun ppf () -> + Format.pp_print_string + ppf + "The operation pack includes operations from different sources.") + Data_encoding.empty + (function Inconsistent_sources -> Some () | _ -> None) + (fun () -> Inconsistent_sources) ; + register_error_kind + `Permanent + ~id:"operation.not_enough_endorsements_for_priority" + ~title:"Not enough endorsements for priority" + ~description: + "The block being validated does not include the required minimum number \ + of endorsements for this priority." + ~pp:(fun ppf (required, endorsements, priority, timestamp) -> + Format.fprintf + ppf + "Wrong number of endorsements (%i) for priority (%i), %i are expected \ + at %a" + endorsements + priority + required + Time.pp_hum + timestamp) + Data_encoding.( + obj4 + (req "required" int31) + (req "endorsements" int31) + (req "priority" int31) + (req "timestamp" Time.encoding)) + (function + | Not_enough_endorsements_for_priority + {required; endorsements; priority; timestamp} -> + Some (required, endorsements, priority, timestamp) + | _ -> + None) + (fun (required, endorsements, priority, timestamp) -> + Not_enough_endorsements_for_priority + {required; endorsements; priority; timestamp}) + +open Apply_results + +let apply_manager_operation_content : + type kind. + Alpha_context.t -> + Script_ir_translator.unparsing_mode -> + payer:Contract.t -> + source:Contract.t -> + chain_id:Chain_id.t -> + internal:bool -> + kind manager_operation -> + ( context + * kind successful_manager_operation_result + * packed_internal_operation list ) + tzresult + Lwt.t = + fun ctxt mode ~payer ~source ~chain_id ~internal operation -> + let before_operation = + (* This context is not used for backtracking. Only to compute + gas consumption and originations for the operation result. *) + ctxt + in + Contract.must_exist ctxt source + >>=? fun () -> + Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation + >>?= fun ctxt -> + match operation with + | Reveal _ -> + return + (* No-op: action already performed by `precheck_manager_contents`. *) + ( ctxt, + ( Reveal_result + {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt} + : kind successful_manager_operation_result ), + [] ) + | Transaction {amount; parameters; destination; entrypoint} -> ( + Contract.spend ctxt source amount + >>=? fun ctxt -> + ( match Contract.is_implicit destination with + | None -> + return (ctxt, [], false) + | Some _ -> ( + Contract.allocated ctxt destination + >>=? function + | true -> + return (ctxt, [], false) + | false -> + Lwt.return + ( Fees.origination_burn ctxt + >|? fun (ctxt, origination_burn) -> + ( ctxt, + [(Delegate.Contract payer, Delegate.Debited origination_burn)], + true ) ) ) ) + >>=? fun (ctxt, maybe_burn_balance_update, allocated_destination_contract) + -> + Contract.credit ctxt destination amount + >>=? fun ctxt -> + Contract.get_script ctxt destination + >>=? fun (ctxt, script) -> + match script with + | None -> + Lwt.return + ( ( match entrypoint with + | "default" -> + ok_unit + | entrypoint -> + error (Script_tc_errors.No_such_entrypoint entrypoint) ) + >>? (fun () -> + Script.force_decode_in_context ctxt parameters + >>? fun (arg, ctxt) -> + (* see [note] *) + (* [note]: for toplevel ops, cost is nil since the + lazy value has already been forced at precheck, so + we compute and consume the full cost again *) + let cost_arg = Script.deserialized_cost arg in + Gas.consume ctxt cost_arg + >>? fun ctxt -> + match Micheline.root arg with + | Prim (_, D_Unit, [], _) -> + (* Allow [Unit] parameter to non-scripted contracts. *) + ok ctxt + | _ -> + error + (Script_interpreter.Bad_contract_parameter destination)) + >|? fun ctxt -> + let result = + Transaction_result + { + storage = None; + lazy_storage_diff = None; + balance_updates = + Delegate.cleanup_balance_updates + ( [ (Delegate.Contract source, Delegate.Debited amount); + (Contract destination, Credited amount) ] + @ maybe_burn_balance_update ); + originated_contracts = []; + consumed_gas = + Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = Z.zero; + paid_storage_size_diff = Z.zero; + allocated_destination_contract; + } + in + (ctxt, result, []) ) + | Some script -> + Script.force_decode_in_context ctxt parameters + >>?= fun (parameter, ctxt) -> + (* see [note] *) + let cost_parameter = Script.deserialized_cost parameter in + Gas.consume ctxt cost_parameter + >>?= fun ctxt -> + let step_constants = + let open Script_interpreter in + {source; payer; self = destination; amount; chain_id} + in + Script_interpreter.execute + ctxt + mode + step_constants + ~script + ~parameter + ~entrypoint + ~internal + >>=? fun {ctxt; storage; lazy_storage_diff; operations} -> + Contract.update_script_storage + ctxt + destination + storage + lazy_storage_diff + >>=? fun ctxt -> + Fees.record_paid_storage_space ctxt destination + >>=? fun (ctxt, new_size, paid_storage_size_diff, fees) -> + Contract.originated_from_current_nonce + ~since:before_operation + ~until:ctxt + >|=? fun originated_contracts -> + let result = + Transaction_result + { + storage = Some storage; + lazy_storage_diff; + balance_updates = + Delegate.cleanup_balance_updates + [ (Contract payer, Debited fees); + (Contract source, Debited amount); + (Contract destination, Credited amount) ]; + originated_contracts; + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = new_size; + paid_storage_size_diff; + allocated_destination_contract; + } + in + (ctxt, result, operations) ) + | Origination {delegate; script; preorigination; credit} -> + Script.force_decode_in_context ctxt script.storage + >>?= fun (unparsed_storage, ctxt) -> + (* see [note] *) + Gas.consume ctxt (Script.deserialized_cost unparsed_storage) + >>?= fun ctxt -> + Script.force_decode_in_context ctxt script.code + >>?= fun (unparsed_code, ctxt) -> + (* see [note] *) + Gas.consume ctxt (Script.deserialized_cost unparsed_code) + >>?= fun ctxt -> + Script_ir_translator.parse_script + ctxt + ~legacy:false + ~allow_forged_in_storage:internal + script + >>=? fun (Ex_script parsed_script, ctxt) -> + Script_ir_translator.collect_lazy_storage + ctxt + parsed_script.storage_type + parsed_script.storage + >>?= fun (to_duplicate, ctxt) -> + let to_update = Script_ir_translator.no_lazy_storage_id in + Script_ir_translator.extract_lazy_storage_diff + ctxt + Optimized + parsed_script.storage_type + parsed_script.storage + ~to_duplicate + ~to_update + ~temporary:false + >>=? fun (storage, lazy_storage_diff, ctxt) -> + Script_ir_translator.unparse_data + ctxt + Optimized + parsed_script.storage_type + storage + >>=? fun (storage, ctxt) -> + let storage = Script.lazy_expr (Micheline.strip_locations storage) in + let script = {script with storage} in + Contract.spend ctxt source credit + >>=? fun ctxt -> + ( match preorigination with + | Some contract -> + assert internal ; + (* The preorigination field is only used to early return + the address of an originated contract in Michelson. + It cannot come from the outside. *) + ok (ctxt, contract) + | None -> + Contract.fresh_contract_from_current_nonce ctxt ) + >>?= fun (ctxt, contract) -> + Contract.originate + ctxt + contract + ~delegate + ~balance:credit + ~script:(script, lazy_storage_diff) + >>=? fun ctxt -> + Fees.origination_burn ctxt + >>?= fun (ctxt, origination_burn) -> + Fees.record_paid_storage_space ctxt contract + >|=? fun (ctxt, size, paid_storage_size_diff, fees) -> + let result = + Origination_result + { + lazy_storage_diff; + balance_updates = + Delegate.cleanup_balance_updates + [ (Contract payer, Debited fees); + (Contract payer, Debited origination_burn); + (Contract source, Debited credit); + (Contract contract, Credited credit) ]; + originated_contracts = [contract]; + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = size; + paid_storage_size_diff; + } + in + (ctxt, result, []) + | Delegation delegate -> + Delegate.set ctxt source delegate + >|=? fun ctxt -> + ( ctxt, + Delegation_result + {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}, + [] ) + +type success_or_failure = Success of context | Failure + +let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = + let rec apply ctxt applied worklist = + match worklist with + | [] -> + Lwt.return (Success ctxt, List.rev applied) + | Internal_operation ({source; operation; nonce} as op) :: rest -> ( + ( if internal_nonce_already_recorded ctxt nonce then + fail (Internal_operation_replay (Internal_operation op)) + else + let ctxt = record_internal_nonce ctxt nonce in + apply_manager_operation_content + ctxt + mode + ~source + ~payer + ~chain_id + ~internal:true + operation ) + >>= function + | Error errors -> + let result = + Internal_operation_result + (op, Failed (manager_kind op.operation, errors)) + in + let skipped = + List.rev_map + (fun (Internal_operation op) -> + Internal_operation_result + (op, Skipped (manager_kind op.operation))) + rest + in + Lwt.return (Failure, List.rev (skipped @ (result :: applied))) + | Ok (ctxt, result, emitted) -> + apply + ctxt + (Internal_operation_result (op, Applied result) :: applied) + (rest @ emitted) ) + in + apply ctxt [] ops + +let precheck_manager_contents (type kind) ctxt + (op : kind Kind.manager contents) : context tzresult Lwt.t = + let (Manager_operation + {source; fee; counter; operation; gas_limit; storage_limit}) = + op + in + Gas.check_limit ctxt gas_limit + >>?= fun () -> + let ctxt = Gas.set_limit ctxt gas_limit in + Fees.check_storage_limit ctxt storage_limit + >>?= fun () -> + Contract.must_be_allocated ctxt (Contract.implicit_contract source) + >>=? fun () -> + Contract.check_counter_increment ctxt source counter + >>=? fun () -> + ( match operation with + | Reveal pk -> + Contract.reveal_manager_key ctxt source pk + | Transaction {parameters; _} -> + Lwt.return + (* Fail quickly if not enough gas for minimal deserialization cost *) + @@ record_trace Gas_quota_exceeded_init_deserialize + @@ ( Gas.check_enough ctxt (Script.minimal_deserialize_cost parameters) + >>? fun () -> + (* Fail if not enough gas for complete deserialization cost *) + Script.force_decode_in_context ctxt parameters + >|? fun (_arg, ctxt) -> ctxt ) + | Origination {script; _} -> + Lwt.return + @@ record_trace Gas_quota_exceeded_init_deserialize + @@ (* Fail quickly if not enough gas for minimal deserialization cost *) + ( Gas.( + check_enough + ctxt + ( Script.minimal_deserialize_cost script.code + +@ Script.minimal_deserialize_cost script.storage )) + >>? fun () -> + (* Fail if not enough gas for complete deserialization cost *) + Script.force_decode_in_context ctxt script.code + >>? fun (_code, ctxt) -> + Script.force_decode_in_context ctxt script.storage + >|? fun (_storage, ctxt) -> ctxt ) + | _ -> + return ctxt ) + >>=? fun ctxt -> + Contract.increment_counter ctxt source + >>=? fun ctxt -> + Contract.spend ctxt (Contract.implicit_contract source) fee + >>=? fun ctxt -> Lwt.return (add_fees ctxt fee) + +let apply_manager_contents (type kind) ctxt mode chain_id + (op : kind Kind.manager contents) : + ( success_or_failure + * kind manager_operation_result + * packed_internal_operation_result list ) + Lwt.t = + let (Manager_operation {source; operation; gas_limit; storage_limit}) = op in + (* We do not expose the internal scaling to the users. Instead, we multiply + the specified gas limit by the internal scaling. *) + let ctxt = Gas.set_limit ctxt gas_limit in + let ctxt = Fees.start_counting_storage_fees ctxt in + let source = Contract.implicit_contract source in + apply_manager_operation_content + ctxt + mode + ~source + ~payer:source + ~internal:false + ~chain_id + operation + >>= function + | Ok (ctxt, operation_results, internal_operations) -> ( + apply_internal_manager_operations + ctxt + mode + ~payer:source + ~chain_id + internal_operations + >>= function + | (Success ctxt, internal_operations_results) -> ( + Fees.burn_storage_fees ctxt ~storage_limit ~payer:source + >|= function + | Ok ctxt -> + ( Success ctxt, + Applied operation_results, + internal_operations_results ) + | Error errors -> + ( Failure, + Backtracked (operation_results, Some errors), + internal_operations_results ) ) + | (Failure, internal_operations_results) -> + Lwt.return + (Failure, Applied operation_results, internal_operations_results) ) + | Error errors -> + Lwt.return (Failure, Failed (manager_kind operation, errors), []) + +let skipped_operation_result : + type kind. kind manager_operation -> kind manager_operation_result = + function + | operation -> ( + match operation with + | Reveal _ -> + Applied + ( Reveal_result {consumed_gas = Gas.Arith.zero} + : kind successful_manager_operation_result ) + | _ -> + Skipped (manager_kind operation) ) + +let rec mark_skipped : + type kind. + baker:Signature.Public_key_hash.t -> + Level.t -> + kind Kind.manager contents_list -> + kind Kind.manager contents_result_list = + fun ~baker level -> function + | Single (Manager_operation {source; fee; operation}) -> + let source = Contract.implicit_contract source in + Single_result + (Manager_operation_result + { + balance_updates = + Delegate.cleanup_balance_updates + [ (Contract source, Debited fee); + (Fees (baker, level.cycle), Credited fee) ]; + operation_result = skipped_operation_result operation; + internal_operation_results = []; + }) + | Cons (Manager_operation {source; fee; operation}, rest) -> + let source = Contract.implicit_contract source in + Cons_result + ( Manager_operation_result + { + balance_updates = + Delegate.cleanup_balance_updates + [ (Contract source, Debited fee); + (Fees (baker, level.cycle), Credited fee) ]; + operation_result = skipped_operation_result operation; + internal_operation_results = []; + }, + mark_skipped ~baker level rest ) + +let rec precheck_manager_contents_list : + type kind. + Alpha_context.t -> + kind Kind.manager contents_list -> + context tzresult Lwt.t = + fun ctxt contents_list -> + match contents_list with + | Single (Manager_operation _ as op) -> + precheck_manager_contents ctxt op + | Cons ((Manager_operation _ as op), rest) -> + precheck_manager_contents ctxt op + >>=? fun ctxt -> precheck_manager_contents_list ctxt rest + +let check_manager_signature ctxt chain_id (op : _ Kind.manager contents_list) + raw_operation = + (* Currently, the [op] only contains one signature, so + all operations are required to be from the same manager. This may + change in the future, allowing several managers to group-sign a + sequence of transactions. *) + let check_same_manager (source, source_key) manager = + match manager with + | None -> + (* Consistency already checked by + [reveal_manager_key] in [precheck_manager_contents]. *) + ok (source, source_key) + | Some (manager, manager_key) -> + if Signature.Public_key_hash.equal source manager then + ok (source, Option.first_some manager_key source_key) + else error Inconsistent_sources + in + let rec find_source : + type kind. + kind Kind.manager contents_list -> + (Signature.public_key_hash * Signature.public_key option) option -> + (Signature.public_key_hash * Signature.public_key option) tzresult = + fun contents_list manager -> + let source (type kind) = function + | (Manager_operation {source; operation = Reveal key; _} : + kind Kind.manager contents) -> + (source, Some key) + | Manager_operation {source; _} -> + (source, None) + in + match contents_list with + | Single op -> + check_same_manager (source op) manager + | Cons (op, rest) -> + check_same_manager (source op) manager + >>? fun manager -> find_source rest (Some manager) + in + find_source op None + >>?= fun (source, source_key) -> + ( match source_key with + | Some key -> + return key + | None -> + Contract.get_manager_key ctxt source ) + >>=? fun public_key -> + Lwt.return (Operation.check_signature public_key chain_id raw_operation) + +let rec apply_manager_contents_list_rec : + type kind. + Alpha_context.t -> + Script_ir_translator.unparsing_mode -> + public_key_hash -> + Chain_id.t -> + kind Kind.manager contents_list -> + (success_or_failure * kind Kind.manager contents_result_list) Lwt.t = + fun ctxt mode baker chain_id contents_list -> + let level = Level.current ctxt in + match contents_list with + | Single (Manager_operation {source; fee; _} as op) -> + let source = Contract.implicit_contract source in + apply_manager_contents ctxt mode chain_id op + >|= fun (ctxt_result, operation_result, internal_operation_results) -> + let result = + Manager_operation_result + { + balance_updates = + Delegate.cleanup_balance_updates + [ (Contract source, Debited fee); + (Fees (baker, level.cycle), Credited fee) ]; + operation_result; + internal_operation_results; + } + in + (ctxt_result, Single_result result) + | Cons ((Manager_operation {source; fee; _} as op), rest) -> ( + let source = Contract.implicit_contract source in + apply_manager_contents ctxt mode chain_id op + >>= function + | (Failure, operation_result, internal_operation_results) -> + let result = + Manager_operation_result + { + balance_updates = + Delegate.cleanup_balance_updates + [ (Contract source, Debited fee); + (Fees (baker, level.cycle), Credited fee) ]; + operation_result; + internal_operation_results; + } + in + Lwt.return + (Failure, Cons_result (result, mark_skipped ~baker level rest)) + | (Success ctxt, operation_result, internal_operation_results) -> + let result = + Manager_operation_result + { + balance_updates = + Delegate.cleanup_balance_updates + [ (Contract source, Debited fee); + (Fees (baker, level.cycle), Credited fee) ]; + operation_result; + internal_operation_results; + } + in + apply_manager_contents_list_rec ctxt mode baker chain_id rest + >|= fun (ctxt_result, results) -> + (ctxt_result, Cons_result (result, results)) ) + +let mark_backtracked results = + let rec mark_contents_list : + type kind. + kind Kind.manager contents_result_list -> + kind Kind.manager contents_result_list = function + | Single_result (Manager_operation_result op) -> + Single_result + (Manager_operation_result + { + balance_updates = op.balance_updates; + operation_result = + mark_manager_operation_result op.operation_result; + internal_operation_results = + List.map + mark_internal_operation_results + op.internal_operation_results; + }) + | Cons_result (Manager_operation_result op, rest) -> + Cons_result + ( Manager_operation_result + { + balance_updates = op.balance_updates; + operation_result = + mark_manager_operation_result op.operation_result; + internal_operation_results = + List.map + mark_internal_operation_results + op.internal_operation_results; + }, + mark_contents_list rest ) + and mark_internal_operation_results + (Internal_operation_result (kind, result)) = + Internal_operation_result (kind, mark_manager_operation_result result) + and mark_manager_operation_result : + type kind. kind manager_operation_result -> kind manager_operation_result + = function + | (Failed _ | Skipped _ | Backtracked _) as result -> + result + | Applied (Reveal_result _) as result -> + result + | Applied result -> + Backtracked (result, None) + in + mark_contents_list results + [@@coq_axiom "non-top-level mutual recursion"] + +let apply_manager_contents_list ctxt mode baker chain_id contents_list = + apply_manager_contents_list_rec ctxt mode baker chain_id contents_list + >>= fun (ctxt_result, results) -> + match ctxt_result with + | Failure -> + Lwt.return (ctxt (* backtracked *), mark_backtracked results) + | Success ctxt -> + Lazy_storage.cleanup_temporaries ctxt >|= fun ctxt -> (ctxt, results) + +let apply_contents_list (type kind) ctxt chain_id mode pred_block baker + (operation : kind operation) (contents_list : kind contents_list) : + (context * kind contents_result_list) tzresult Lwt.t = + match contents_list with + | Single (Endorsement {level}) -> + let block = operation.shell.branch in + error_unless + (Block_hash.equal block pred_block) + (Wrong_endorsement_predecessor (pred_block, block)) + >>?= fun () -> + let current_level = (Level.current ctxt).level in + error_unless + Raw_level.(succ level = current_level) + Invalid_endorsement_level + >>?= fun () -> + Baking.check_endorsement_rights ctxt chain_id operation + >>=? fun (delegate, slots, used) -> + if used then fail (Duplicate_endorsement delegate) + else + let ctxt = record_endorsement ctxt delegate in + let gap = List.length slots in + Tez.(Constants.endorsement_security_deposit ctxt *? Int64.of_int gap) + >>?= fun deposit -> + Delegate.freeze_deposit ctxt delegate deposit + >>=? fun ctxt -> + Global.get_block_priority ctxt + >>=? fun block_priority -> + Baking.endorsing_reward ctxt ~block_priority gap + >>?= fun reward -> + Delegate.freeze_rewards ctxt delegate reward + >|=? fun ctxt -> + let level = Level.from_raw ctxt level in + ( ctxt, + Single_result + (Endorsement_result + { + balance_updates = + Delegate.cleanup_balance_updates + [ ( Contract (Contract.implicit_contract delegate), + Debited deposit ); + (Deposits (delegate, level.cycle), Credited deposit); + (Rewards (delegate, level.cycle), Credited reward) ]; + delegate; + slots; + }) ) + | Single (Seed_nonce_revelation {level; nonce}) -> + let level = Level.from_raw ctxt level in + Nonce.reveal ctxt level nonce + >>=? fun ctxt -> + let seed_nonce_revelation_tip = + Constants.seed_nonce_revelation_tip ctxt + in + Lwt.return + ( add_rewards ctxt seed_nonce_revelation_tip + >|? fun ctxt -> + ( ctxt, + Single_result + (Seed_nonce_revelation_result + [ ( Rewards (baker, level.cycle), + Credited seed_nonce_revelation_tip ) ]) ) ) + | Single (Double_endorsement_evidence {op1; op2}) -> ( + match (op1.protocol_data.contents, op2.protocol_data.contents) with + | (Single (Endorsement e1), Single (Endorsement e2)) + when Raw_level.(e1.level = e2.level) + && not (Block_hash.equal op1.shell.branch op2.shell.branch) -> + let level = Level.from_raw ctxt e1.level in + let oldest_level = Level.last_allowed_fork_level ctxt in + fail_unless + Level.(level < Level.current ctxt) + (Too_early_double_endorsement_evidence + {level = level.level; current = (Level.current ctxt).level}) + >>=? fun () -> + fail_unless + Raw_level.(oldest_level <= level.level) + (Outdated_double_endorsement_evidence + {level = level.level; last = oldest_level}) + >>=? fun () -> + Baking.check_endorsement_rights ctxt chain_id op1 + >>=? fun (delegate1, _, _) -> + Baking.check_endorsement_rights ctxt chain_id op2 + >>=? fun (delegate2, _, _) -> + fail_unless + (Signature.Public_key_hash.equal delegate1 delegate2) + (Inconsistent_double_endorsement_evidence {delegate1; delegate2}) + >>=? fun () -> + Delegate.has_frozen_balance ctxt delegate1 level.cycle + >>=? fun valid -> + fail_unless valid Unrequired_double_endorsement_evidence + >>=? fun () -> + Delegate.punish ctxt delegate1 level.cycle + >>=? fun (ctxt, balance) -> + Lwt.return Tez.(balance.deposit +? balance.fees) + >>=? fun burned -> + let reward = + match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero + in + add_rewards ctxt reward + >>?= fun ctxt -> + let current_cycle = (Level.current ctxt).cycle in + return + ( ctxt, + Single_result + (Double_endorsement_evidence_result + (Delegate.cleanup_balance_updates + [ ( Deposits (delegate1, level.cycle), + Debited balance.deposit ); + (Fees (delegate1, level.cycle), Debited balance.fees); + ( Rewards (delegate1, level.cycle), + Debited balance.rewards ); + (Rewards (baker, current_cycle), Credited reward) ])) ) + | (_, _) -> + fail Invalid_double_endorsement_evidence ) + | Single (Double_baking_evidence {bh1; bh2}) -> + let hash1 = Block_header.hash bh1 in + let hash2 = Block_header.hash bh2 in + fail_unless + ( Compare.Int32.(bh1.shell.level = bh2.shell.level) + && not (Block_hash.equal hash1 hash2) ) + (Invalid_double_baking_evidence + {hash1; level1 = bh1.shell.level; hash2; level2 = bh2.shell.level}) + >>=? fun () -> + Lwt.return (Raw_level.of_int32 bh1.shell.level) + >>=? fun raw_level -> + let oldest_level = Level.last_allowed_fork_level ctxt in + fail_unless + Raw_level.(raw_level < (Level.current ctxt).level) + (Too_early_double_baking_evidence + {level = raw_level; current = (Level.current ctxt).level}) + >>=? fun () -> + fail_unless + Raw_level.(oldest_level <= raw_level) + (Outdated_double_baking_evidence + {level = raw_level; last = oldest_level}) + >>=? fun () -> + let level = Level.from_raw ctxt raw_level in + Roll.baking_rights_owner + ctxt + level + ~priority:bh1.protocol_data.contents.priority + >>=? fun delegate1 -> + Baking.check_signature bh1 chain_id delegate1 + >>=? fun () -> + Roll.baking_rights_owner + ctxt + level + ~priority:bh2.protocol_data.contents.priority + >>=? fun delegate2 -> + Baking.check_signature bh2 chain_id delegate2 + >>=? fun () -> + fail_unless + (Signature.Public_key.equal delegate1 delegate2) + (Inconsistent_double_baking_evidence + { + delegate1 = Signature.Public_key.hash delegate1; + delegate2 = Signature.Public_key.hash delegate2; + }) + >>=? fun () -> + let delegate = Signature.Public_key.hash delegate1 in + Delegate.has_frozen_balance ctxt delegate level.cycle + >>=? fun valid -> + fail_unless valid Unrequired_double_baking_evidence + >>=? fun () -> + Delegate.punish ctxt delegate level.cycle + >>=? fun (ctxt, balance) -> + Tez.(balance.deposit +? balance.fees) + >>?= fun burned -> + let reward = + match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero + in + Lwt.return + ( add_rewards ctxt reward + >|? fun ctxt -> + let current_cycle = (Level.current ctxt).cycle in + ( ctxt, + Single_result + (Double_baking_evidence_result + (Delegate.cleanup_balance_updates + [ (Deposits (delegate, level.cycle), Debited balance.deposit); + (Fees (delegate, level.cycle), Debited balance.fees); + (Rewards (delegate, level.cycle), Debited balance.rewards); + (Rewards (baker, current_cycle), Credited reward) ])) ) ) + | Single (Activate_account {id = pkh; activation_code}) -> ( + let blinded_pkh = + Blinded_public_key_hash.of_ed25519_pkh activation_code pkh + in + Commitment.get_opt ctxt blinded_pkh + >>=? function + | None -> + fail (Invalid_activation {pkh}) + | Some amount -> + Commitment.delete ctxt blinded_pkh + >>=? fun ctxt -> + let contract = Contract.implicit_contract (Signature.Ed25519 pkh) in + Contract.(credit ctxt contract amount) + >|=? fun ctxt -> + ( ctxt, + Single_result + (Activate_account_result [(Contract contract, Credited amount)]) + ) ) + | Single (Proposals {source; period; proposals}) -> + Roll.delegate_pubkey ctxt source + >>=? fun delegate -> + Operation.check_signature delegate chain_id operation + >>?= fun () -> + Voting_period.get_current ctxt + >>=? fun {index = current_period; _} -> + error_unless + Compare.Int32.(current_period = period) + (Wrong_voting_period (current_period, period)) + >>?= fun () -> + Amendment.record_proposals ctxt source proposals + >|=? fun ctxt -> (ctxt, Single_result Proposals_result) + | Single (Ballot {source; period; proposal; ballot}) -> + Roll.delegate_pubkey ctxt source + >>=? fun delegate -> + Operation.check_signature delegate chain_id operation + >>?= fun () -> + Voting_period.get_current ctxt + >>=? fun {index = current_period; _} -> + error_unless + Compare.Int32.(current_period = period) + (Wrong_voting_period (current_period, period)) + >>?= fun () -> + Amendment.record_ballot ctxt source proposal ballot + >|=? fun ctxt -> (ctxt, Single_result Ballot_result) + | Single (Manager_operation _) as op -> + precheck_manager_contents_list ctxt op + >>=? fun ctxt -> + check_manager_signature ctxt chain_id op operation + >>=? fun () -> + apply_manager_contents_list ctxt mode baker chain_id op >|= ok + | Cons (Manager_operation _, _) as op -> + precheck_manager_contents_list ctxt op + >>=? fun ctxt -> + check_manager_signature ctxt chain_id op operation + >>=? fun () -> + apply_manager_contents_list ctxt mode baker chain_id op >|= ok + +let apply_operation ctxt chain_id mode pred_block baker hash operation = + let ctxt = Contract.init_origination_nonce ctxt hash in + apply_contents_list + ctxt + chain_id + mode + pred_block + baker + operation + operation.protocol_data.contents + >|=? fun (ctxt, result) -> + let ctxt = Gas.set_unlimited ctxt in + let ctxt = Contract.unset_origination_nonce ctxt in + (ctxt, {contents = result}) + +let may_snapshot_roll ctxt = + let level = Alpha_context.Level.current ctxt in + let blocks_per_roll_snapshot = Constants.blocks_per_roll_snapshot ctxt in + if + Compare.Int32.equal + (Int32.rem level.cycle_position blocks_per_roll_snapshot) + (Int32.pred blocks_per_roll_snapshot) + then Alpha_context.Roll.snapshot_rolls ctxt + else return ctxt + +let may_start_new_cycle ctxt = + match Baking.dawn_of_a_new_cycle ctxt with + | None -> + return (ctxt, [], []) + | Some last_cycle -> + Seed.cycle_end ctxt last_cycle + >>=? fun (ctxt, unrevealed) -> + Roll.cycle_end ctxt last_cycle + >>=? fun ctxt -> + Delegate.cycle_end ctxt last_cycle unrevealed + >>=? fun (ctxt, update_balances, deactivated) -> + Bootstrap.cycle_end ctxt last_cycle + >|=? fun ctxt -> (ctxt, update_balances, deactivated) + +let endorsement_rights_of_pred_level ctxt = + match Level.pred ctxt (Level.current ctxt) with + | None -> + assert false (* genesis *) + | Some pred_level -> + Baking.endorsement_rights ctxt pred_level + +let begin_full_construction ctxt pred_timestamp protocol_data = + Alpha_context.Global.set_block_priority + ctxt + protocol_data.Block_header.priority + >>=? fun ctxt -> + Baking.check_baking_rights ctxt protocol_data pred_timestamp + >>=? fun (delegate_pk, block_delay) -> + let ctxt = Fitness.increase ctxt in + endorsement_rights_of_pred_level ctxt + >|=? fun rights -> + let ctxt = init_endorsements ctxt rights in + (ctxt, protocol_data, delegate_pk, block_delay) + +let begin_partial_construction ctxt = + let ctxt = Fitness.increase ctxt in + endorsement_rights_of_pred_level ctxt + >|=? fun rights -> init_endorsements ctxt rights + +let begin_application ctxt chain_id block_header pred_timestamp = + Alpha_context.Global.set_block_priority + ctxt + block_header.Block_header.protocol_data.contents.priority + >>=? fun ctxt -> + let current_level = Alpha_context.Level.current ctxt in + Baking.check_proof_of_work_stamp ctxt block_header + >>?= fun () -> + Baking.check_fitness_gap ctxt block_header + >>?= fun () -> + Baking.check_baking_rights + ctxt + block_header.protocol_data.contents + pred_timestamp + >>=? fun (delegate_pk, block_delay) -> + Baking.check_signature block_header chain_id delegate_pk + >>=? fun () -> + let has_commitment = + Option.is_some block_header.protocol_data.contents.seed_nonce_hash + in + error_unless + Compare.Bool.(has_commitment = current_level.expected_commitment) + (Invalid_commitment {expected = current_level.expected_commitment}) + >>?= fun () -> + let ctxt = Fitness.increase ctxt in + endorsement_rights_of_pred_level ctxt + >|=? fun rights -> + let ctxt = init_endorsements ctxt rights in + (ctxt, delegate_pk, block_delay) + +let check_minimum_endorsements ctxt protocol_data block_delay + included_endorsements = + let minimum = Baking.minimum_allowed_endorsements ctxt ~block_delay in + let timestamp = Timestamp.current ctxt in + error_unless + Compare.Int.(included_endorsements >= minimum) + (Not_enough_endorsements_for_priority + { + required = minimum; + priority = protocol_data.Block_header.priority; + endorsements = included_endorsements; + timestamp; + }) + +let finalize_application ctxt protocol_data delegate ~block_delay = + let included_endorsements = included_endorsements ctxt in + check_minimum_endorsements + ctxt + protocol_data + block_delay + included_endorsements + >>?= fun () -> + let deposit = Constants.block_security_deposit ctxt in + add_deposit ctxt delegate deposit + >>?= fun ctxt -> + Baking.baking_reward + ctxt + ~block_priority:protocol_data.priority + ~included_endorsements + >>?= fun reward -> + add_rewards ctxt reward + >>?= fun ctxt -> + Signature.Public_key_hash.Map.fold + (fun delegate deposit ctxt -> + ctxt >>=? fun ctxt -> Delegate.freeze_deposit ctxt delegate deposit) + (get_deposits ctxt) + (return ctxt) + >>=? fun ctxt -> + (* end of level (from this point nothing should fail) *) + let fees = Alpha_context.get_fees ctxt in + Delegate.freeze_fees ctxt delegate fees + >>=? fun ctxt -> + let rewards = Alpha_context.get_rewards ctxt in + Delegate.freeze_rewards ctxt delegate rewards + >>=? fun ctxt -> + ( match protocol_data.Block_header.seed_nonce_hash with + | None -> + return ctxt + | Some nonce_hash -> + Nonce.record_hash ctxt {nonce_hash; delegate; rewards; fees} ) + >>=? fun ctxt -> + (* end of cycle *) + may_snapshot_roll ctxt + >>=? fun ctxt -> + may_start_new_cycle ctxt + >>=? fun (ctxt, balance_updates, deactivated) -> + Amendment.may_start_new_voting_period ctxt + >>=? fun ctxt -> + let cycle = (Level.current ctxt).cycle in + let balance_updates = + Delegate.( + cleanup_balance_updates + ( [ (Contract (Contract.implicit_contract delegate), Debited deposit); + (Deposits (delegate, cycle), Credited deposit); + (Rewards (delegate, cycle), Credited reward) ] + @ balance_updates )) + in + let consumed_gas = + Gas.Arith.sub + (Gas.Arith.fp @@ Constants.hard_gas_limit_per_block ctxt) + (Alpha_context.Gas.block_level ctxt) + in + (* This value is different than the new [voting_period_info] below for + compatibility reasons, the field [voting_period_kind] is deprecated and will + be removed in a future version. *) + Alpha_context.Voting_period.get_current_info ctxt + >>=? fun {voting_period = {kind; _}; _} -> + Alpha_context.Voting_period.get_rpc_fixed_current_info ctxt + >|=? fun ({voting_period; position; _} as voting_period_info) -> + let level_info = Alpha_context.Level.current ctxt in + let receipt = + Apply_results. + { + baker = delegate; + level = + Level.to_deprecated_type + level_info + ~voting_period_index:voting_period.index + ~voting_period_position:position; + level_info; + voting_period_info; + voting_period_kind = kind; + nonce_hash = protocol_data.seed_nonce_hash; + consumed_gas; + deactivated; + balance_updates; + } + in + (ctxt, receipt) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/apply_results.ml b/src/proto_008_PtEdo2Zk/lib_protocol/apply_results.ml new file mode 100644 index 0000000000000000000000000000000000000000..2967c9723c18186cbcebcab9c298ff0a81ed07c7 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/apply_results.ml @@ -0,0 +1,1252 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Data_encoding + +let error_encoding = + def + "error" + ~description: + "The full list of RPC errors would be too long to include.\n\ + It is available at RPC `/errors` (GET).\n\ + Errors specific to protocol Alpha have an id that starts with \ + `proto.alpha`." + @@ splitted + ~json: + (conv + (fun err -> + Data_encoding.Json.construct Error_monad.error_encoding err) + (fun json -> + Data_encoding.Json.destruct Error_monad.error_encoding json) + json) + ~binary:Error_monad.error_encoding + +type _ successful_manager_operation_result = + | Reveal_result : { + consumed_gas : Gas.Arith.fp; + } + -> Kind.reveal successful_manager_operation_result + | Transaction_result : { + storage : Script.expr option; + lazy_storage_diff : Lazy_storage.diffs option; + balance_updates : Delegate.balance_updates; + originated_contracts : Contract.t list; + consumed_gas : Gas.Arith.fp; + storage_size : Z.t; + paid_storage_size_diff : Z.t; + allocated_destination_contract : bool; + } + -> Kind.transaction successful_manager_operation_result + | Origination_result : { + lazy_storage_diff : Lazy_storage.diffs option; + balance_updates : Delegate.balance_updates; + originated_contracts : Contract.t list; + consumed_gas : Gas.Arith.fp; + storage_size : Z.t; + paid_storage_size_diff : Z.t; + } + -> Kind.origination successful_manager_operation_result + | Delegation_result : { + consumed_gas : Gas.Arith.fp; + } + -> Kind.delegation successful_manager_operation_result + +type packed_successful_manager_operation_result = + | Successful_manager_result : + 'kind successful_manager_operation_result + -> packed_successful_manager_operation_result + +type 'kind manager_operation_result = + | Applied of 'kind successful_manager_operation_result + | Backtracked of + 'kind successful_manager_operation_result * error list option + | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result + | Skipped : 'kind Kind.manager -> 'kind manager_operation_result + +type packed_internal_operation_result = + | Internal_operation_result : + 'kind internal_operation * 'kind manager_operation_result + -> packed_internal_operation_result + +module Manager_result = struct + type 'kind case = + | MCase : { + op_case : 'kind Operation.Encoding.Manager_operations.case; + encoding : 'a Data_encoding.t; + kind : 'kind Kind.manager; + iselect : + packed_internal_operation_result -> + ('kind internal_operation * 'kind manager_operation_result) option; + select : + packed_successful_manager_operation_result -> + 'kind successful_manager_operation_result option; + proj : 'kind successful_manager_operation_result -> 'a; + inj : 'a -> 'kind successful_manager_operation_result; + t : 'kind manager_operation_result Data_encoding.t; + } + -> 'kind case + + let make ~op_case ~encoding ~kind ~iselect ~select ~proj ~inj = + let (Operation.Encoding.Manager_operations.MCase {name; _}) = op_case in + let t = + def (Format.asprintf "operation.alpha.operation_result.%s" name) + @@ union + ~tag_size:`Uint8 + [ case + (Tag 0) + ~title:"Applied" + (merge_objs (obj1 (req "status" (constant "applied"))) encoding) + (fun o -> + match o with + | Skipped _ | Failed _ | Backtracked _ -> + None + | Applied o -> ( + match select (Successful_manager_result o) with + | None -> + None + | Some o -> + Some ((), proj o) )) + (fun ((), x) -> Applied (inj x)); + case + (Tag 1) + ~title:"Failed" + (obj2 + (req "status" (constant "failed")) + (req "errors" (list error_encoding))) + (function Failed (_, errs) -> Some ((), errs) | _ -> None) + (fun ((), errs) -> Failed (kind, errs)); + case + (Tag 2) + ~title:"Skipped" + (obj1 (req "status" (constant "skipped"))) + (function Skipped _ -> Some () | _ -> None) + (fun () -> Skipped kind); + case + (Tag 3) + ~title:"Backtracked" + (merge_objs + (obj2 + (req "status" (constant "backtracked")) + (opt "errors" (list error_encoding))) + encoding) + (fun o -> + match o with + | Skipped _ | Failed _ | Applied _ -> + None + | Backtracked (o, errs) -> ( + match select (Successful_manager_result o) with + | None -> + None + | Some o -> + Some (((), errs), proj o) )) + (fun (((), errs), x) -> Backtracked (inj x, errs)) ] + in + MCase {op_case; encoding; kind; iselect; select; proj; inj; t} + + let reveal_case = + make + ~op_case:Operation.Encoding.Manager_operations.reveal_case + ~encoding: + Data_encoding.( + obj2 + (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) + (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) + ~iselect:(function + | Internal_operation_result (({operation = Reveal _; _} as op), res) -> + Some (op, res) + | _ -> + None) + ~select:(function + | Successful_manager_result (Reveal_result _ as op) -> + Some op + | _ -> + None) + ~kind:Kind.Reveal_manager_kind + ~proj:(function + | Reveal_result {consumed_gas} -> + (Gas.Arith.ceil consumed_gas, consumed_gas)) + ~inj:(fun (consumed_gas, consumed_milligas) -> + assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; + Reveal_result {consumed_gas = consumed_milligas}) + + let transaction_case = + make + ~op_case:Operation.Encoding.Manager_operations.transaction_case + ~encoding: + (obj10 + (opt "storage" Script.expr_encoding) + (opt + (* The field [big_map_diff] is deprecated since 008, use [lazy_storage_diff] instead. + Is it kept here for a transition period, for tool like indexers to update. + TODO(009): remove it. *) + "big_map_diff" + Lazy_storage.legacy_big_map_diff_encoding) + (dft "balance_updates" Delegate.balance_updates_encoding []) + (dft "originated_contracts" (list Contract.encoding) []) + (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) + (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) + (dft "storage_size" z Z.zero) + (dft "paid_storage_size_diff" z Z.zero) + (dft "allocated_destination_contract" bool false) + (opt "lazy_storage_diff" Lazy_storage.encoding)) + ~iselect:(function + | Internal_operation_result + (({operation = Transaction _; _} as op), res) -> + Some (op, res) + | _ -> + None) + ~select:(function + | Successful_manager_result (Transaction_result _ as op) -> + Some op + | _ -> + None) + ~kind:Kind.Transaction_manager_kind + ~proj:(function + | Transaction_result + { storage; + lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff; + allocated_destination_contract } -> + ( storage, + lazy_storage_diff, + balance_updates, + originated_contracts, + Gas.Arith.ceil consumed_gas, + consumed_gas, + storage_size, + paid_storage_size_diff, + allocated_destination_contract, + lazy_storage_diff )) + ~inj: + (fun ( storage, + legacy_lazy_storage_diff, + balance_updates, + originated_contracts, + consumed_gas, + consumed_milligas, + storage_size, + paid_storage_size_diff, + allocated_destination_contract, + lazy_storage_diff ) -> + assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; + let lazy_storage_diff = + Option.first_some lazy_storage_diff legacy_lazy_storage_diff + in + Transaction_result + { + storage; + lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas = consumed_milligas; + storage_size; + paid_storage_size_diff; + allocated_destination_contract; + }) + + let origination_case = + make + ~op_case:Operation.Encoding.Manager_operations.origination_case + ~encoding: + (obj8 + (opt + (* The field [big_map_diff] is deprecated since 008, use [lazy_storage_diff] instead. + Is it kept here for a transition period, for tool like indexers to update. + TODO(009): remove it. *) + "big_map_diff" + Lazy_storage.legacy_big_map_diff_encoding) + (dft "balance_updates" Delegate.balance_updates_encoding []) + (dft "originated_contracts" (list Contract.encoding) []) + (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) + (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) + (dft "storage_size" z Z.zero) + (dft "paid_storage_size_diff" z Z.zero) + (opt "lazy_storage_diff" Lazy_storage.encoding)) + ~iselect:(function + | Internal_operation_result + (({operation = Origination _; _} as op), res) -> + Some (op, res) + | _ -> + None) + ~select:(function + | Successful_manager_result (Origination_result _ as op) -> + Some op + | _ -> + None) + ~proj:(function + | Origination_result + { lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff } -> + ( lazy_storage_diff, + balance_updates, + originated_contracts, + Gas.Arith.ceil consumed_gas, + consumed_gas, + storage_size, + paid_storage_size_diff, + lazy_storage_diff )) + ~kind:Kind.Origination_manager_kind + ~inj: + (fun ( legacy_lazy_storage_diff, + balance_updates, + originated_contracts, + consumed_gas, + consumed_milligas, + storage_size, + paid_storage_size_diff, + lazy_storage_diff ) -> + assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; + let lazy_storage_diff = + Option.first_some lazy_storage_diff legacy_lazy_storage_diff + in + Origination_result + { + lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas = consumed_milligas; + storage_size; + paid_storage_size_diff; + }) + + let delegation_case = + make + ~op_case:Operation.Encoding.Manager_operations.delegation_case + ~encoding: + Data_encoding.( + obj2 + (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) + (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) + ~iselect:(function + | Internal_operation_result (({operation = Delegation _; _} as op), res) + -> + Some (op, res) + | _ -> + None) + ~select:(function + | Successful_manager_result (Delegation_result _ as op) -> + Some op + | _ -> + None) + ~kind:Kind.Delegation_manager_kind + ~proj:(function + | Delegation_result {consumed_gas} -> + (Gas.Arith.ceil consumed_gas, consumed_gas)) + ~inj:(fun (consumed_gas, consumed_milligas) -> + assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; + Delegation_result {consumed_gas = consumed_milligas}) +end + +let internal_operation_result_encoding : + packed_internal_operation_result Data_encoding.t = + let make (type kind) + (Manager_result.MCase res_case : kind Manager_result.case) = + let (Operation.Encoding.Manager_operations.MCase op_case) = + res_case.op_case + in + case + (Tag op_case.tag) + ~title:op_case.name + (merge_objs + (obj3 + (req "kind" (constant op_case.name)) + (req "source" Contract.encoding) + (req "nonce" uint16)) + (merge_objs op_case.encoding (obj1 (req "result" res_case.t)))) + (fun op -> + match res_case.iselect op with + | Some (op, res) -> + Some (((), op.source, op.nonce), (op_case.proj op.operation, res)) + | None -> + None) + (fun (((), source, nonce), (op, res)) -> + let op = {source; operation = op_case.inj op; nonce} in + Internal_operation_result (op, res)) + in + def "operation.alpha.internal_operation_result" + @@ union + [ make Manager_result.reveal_case; + make Manager_result.transaction_case; + make Manager_result.origination_case; + make Manager_result.delegation_case ] + +type 'kind contents_result = + | Endorsement_result : { + balance_updates : Delegate.balance_updates; + delegate : Signature.Public_key_hash.t; + slots : int list; + } + -> Kind.endorsement contents_result + | Seed_nonce_revelation_result : + Delegate.balance_updates + -> Kind.seed_nonce_revelation contents_result + | Double_endorsement_evidence_result : + Delegate.balance_updates + -> Kind.double_endorsement_evidence contents_result + | Double_baking_evidence_result : + Delegate.balance_updates + -> Kind.double_baking_evidence contents_result + | Activate_account_result : + Delegate.balance_updates + -> Kind.activate_account contents_result + | Proposals_result : Kind.proposals contents_result + | Ballot_result : Kind.ballot contents_result + | Manager_operation_result : { + balance_updates : Delegate.balance_updates; + operation_result : 'kind manager_operation_result; + internal_operation_results : packed_internal_operation_result list; + } + -> 'kind Kind.manager contents_result + +type packed_contents_result = + | Contents_result : 'kind contents_result -> packed_contents_result + +type packed_contents_and_result = + | Contents_and_result : + 'kind Operation.contents * 'kind contents_result + -> packed_contents_and_result + +type ('a, 'b) eq = Eq : ('a, 'a) eq + +let equal_manager_kind : + type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option = + fun ka kb -> + match (ka, kb) with + | (Kind.Reveal_manager_kind, Kind.Reveal_manager_kind) -> + Some Eq + | (Kind.Reveal_manager_kind, _) -> + None + | (Kind.Transaction_manager_kind, Kind.Transaction_manager_kind) -> + Some Eq + | (Kind.Transaction_manager_kind, _) -> + None + | (Kind.Origination_manager_kind, Kind.Origination_manager_kind) -> + Some Eq + | (Kind.Origination_manager_kind, _) -> + None + | (Kind.Delegation_manager_kind, Kind.Delegation_manager_kind) -> + Some Eq + | (Kind.Delegation_manager_kind, _) -> + None + +module Encoding = struct + type 'kind case = + | Case : { + op_case : 'kind Operation.Encoding.case; + encoding : 'a Data_encoding.t; + select : packed_contents_result -> 'kind contents_result option; + mselect : + packed_contents_and_result -> + ('kind contents * 'kind contents_result) option; + proj : 'kind contents_result -> 'a; + inj : 'a -> 'kind contents_result; + } + -> 'kind case + + let tagged_case tag name args proj inj = + let open Data_encoding in + case + tag + ~title:(String.capitalize_ascii name) + (merge_objs (obj1 (req "kind" (constant name))) args) + (fun x -> match proj x with None -> None | Some x -> Some ((), x)) + (fun ((), x) -> inj x) + + let endorsement_case = + Case + { + op_case = Operation.Encoding.endorsement_case; + encoding = + obj3 + (req "balance_updates" Delegate.balance_updates_encoding) + (req "delegate" Signature.Public_key_hash.encoding) + (req "slots" (list uint8)); + select = + (function + | Contents_result (Endorsement_result _ as op) -> Some op | _ -> None); + mselect = + (function + | Contents_and_result ((Endorsement _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = + (function + | Endorsement_result {balance_updates; delegate; slots} -> + (balance_updates, delegate, slots)); + inj = + (fun (balance_updates, delegate, slots) -> + Endorsement_result {balance_updates; delegate; slots}); + } + + let seed_nonce_revelation_case = + Case + { + op_case = Operation.Encoding.seed_nonce_revelation_case; + encoding = + obj1 (req "balance_updates" Delegate.balance_updates_encoding); + select = + (function + | Contents_result (Seed_nonce_revelation_result _ as op) -> + Some op + | _ -> + None); + mselect = + (function + | Contents_and_result ((Seed_nonce_revelation _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun (Seed_nonce_revelation_result bus) -> bus); + inj = (fun bus -> Seed_nonce_revelation_result bus); + } + + let double_endorsement_evidence_case = + Case + { + op_case = Operation.Encoding.double_endorsement_evidence_case; + encoding = + obj1 (req "balance_updates" Delegate.balance_updates_encoding); + select = + (function + | Contents_result (Double_endorsement_evidence_result _ as op) -> + Some op + | _ -> + None); + mselect = + (function + | Contents_and_result ((Double_endorsement_evidence _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun (Double_endorsement_evidence_result bus) -> bus); + inj = (fun bus -> Double_endorsement_evidence_result bus); + } + + let double_baking_evidence_case = + Case + { + op_case = Operation.Encoding.double_baking_evidence_case; + encoding = + obj1 (req "balance_updates" Delegate.balance_updates_encoding); + select = + (function + | Contents_result (Double_baking_evidence_result _ as op) -> + Some op + | _ -> + None); + mselect = + (function + | Contents_and_result ((Double_baking_evidence _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun (Double_baking_evidence_result bus) -> bus); + inj = (fun bus -> Double_baking_evidence_result bus); + } + + let activate_account_case = + Case + { + op_case = Operation.Encoding.activate_account_case; + encoding = + obj1 (req "balance_updates" Delegate.balance_updates_encoding); + select = + (function + | Contents_result (Activate_account_result _ as op) -> + Some op + | _ -> + None); + mselect = + (function + | Contents_and_result ((Activate_account _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun (Activate_account_result bus) -> bus); + inj = (fun bus -> Activate_account_result bus); + } + + let proposals_case = + Case + { + op_case = Operation.Encoding.proposals_case; + encoding = Data_encoding.empty; + select = + (function + | Contents_result (Proposals_result as op) -> Some op | _ -> None); + mselect = + (function + | Contents_and_result ((Proposals _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun Proposals_result -> ()); + inj = (fun () -> Proposals_result); + } + + let ballot_case = + Case + { + op_case = Operation.Encoding.ballot_case; + encoding = Data_encoding.empty; + select = + (function + | Contents_result (Ballot_result as op) -> Some op | _ -> None); + mselect = + (function + | Contents_and_result ((Ballot _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun Ballot_result -> ()); + inj = (fun () -> Ballot_result); + } + + let make_manager_case (type kind) + (Operation.Encoding.Case op_case : + kind Kind.manager Operation.Encoding.case) + (Manager_result.MCase res_case : kind Manager_result.case) mselect = + Case + { + op_case = Operation.Encoding.Case op_case; + encoding = + obj3 + (req "balance_updates" Delegate.balance_updates_encoding) + (req "operation_result" res_case.t) + (dft + "internal_operation_results" + (list internal_operation_result_encoding) + []); + select = + (function + | Contents_result + (Manager_operation_result + ({operation_result = Applied res; _} as op)) -> ( + match res_case.select (Successful_manager_result res) with + | Some res -> + Some + (Manager_operation_result + {op with operation_result = Applied res}) + | None -> + None ) + | Contents_result + (Manager_operation_result + ({operation_result = Backtracked (res, errs); _} as op)) -> ( + match res_case.select (Successful_manager_result res) with + | Some res -> + Some + (Manager_operation_result + {op with operation_result = Backtracked (res, errs)}) + | None -> + None ) + | Contents_result + (Manager_operation_result + ({operation_result = Skipped kind; _} as op)) -> ( + match equal_manager_kind kind res_case.kind with + | None -> + None + | Some Eq -> + Some + (Manager_operation_result + {op with operation_result = Skipped kind}) ) + | Contents_result + (Manager_operation_result + ({operation_result = Failed (kind, errs); _} as op)) -> ( + match equal_manager_kind kind res_case.kind with + | None -> + None + | Some Eq -> + Some + (Manager_operation_result + {op with operation_result = Failed (kind, errs)}) ) + | Contents_result Ballot_result -> + None + | Contents_result (Endorsement_result _) -> + None + | Contents_result (Seed_nonce_revelation_result _) -> + None + | Contents_result (Double_endorsement_evidence_result _) -> + None + | Contents_result (Double_baking_evidence_result _) -> + None + | Contents_result (Activate_account_result _) -> + None + | Contents_result Proposals_result -> + None); + mselect; + proj = + (fun (Manager_operation_result + { balance_updates = bus; + operation_result = r; + internal_operation_results = rs }) -> + (bus, r, rs)); + inj = + (fun (bus, r, rs) -> + Manager_operation_result + { + balance_updates = bus; + operation_result = r; + internal_operation_results = rs; + }); + } + + let reveal_case = + make_manager_case + Operation.Encoding.reveal_case + Manager_result.reveal_case + (function + | Contents_and_result + ((Manager_operation {operation = Reveal _; _} as op), res) -> + Some (op, res) + | _ -> + None) + + let transaction_case = + make_manager_case + Operation.Encoding.transaction_case + Manager_result.transaction_case + (function + | Contents_and_result + ((Manager_operation {operation = Transaction _; _} as op), res) -> + Some (op, res) + | _ -> + None) + + let origination_case = + make_manager_case + Operation.Encoding.origination_case + Manager_result.origination_case + (function + | Contents_and_result + ((Manager_operation {operation = Origination _; _} as op), res) -> + Some (op, res) + | _ -> + None) + + let delegation_case = + make_manager_case + Operation.Encoding.delegation_case + Manager_result.delegation_case + (function + | Contents_and_result + ((Manager_operation {operation = Delegation _; _} as op), res) -> + Some (op, res) + | _ -> + None) +end + +let contents_result_encoding = + let open Encoding in + let make + (Case + { op_case = Operation.Encoding.Case {tag; name; _}; + encoding; + mselect = _; + select; + proj; + inj }) = + let proj x = + match select x with None -> None | Some x -> Some (proj x) + in + let inj x = Contents_result (inj x) in + tagged_case (Tag tag) name encoding proj inj + in + def "operation.alpha.contents_result" + @@ union + [ make endorsement_case; + make seed_nonce_revelation_case; + make double_endorsement_evidence_case; + make double_baking_evidence_case; + make activate_account_case; + make proposals_case; + make ballot_case; + make reveal_case; + make transaction_case; + make origination_case; + make delegation_case ] + +let contents_and_result_encoding = + let open Encoding in + let make + (Case + { op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _}; + mselect; + encoding = meta_encoding; + proj = meta_proj; + inj = meta_inj; + _ }) = + let proj c = + match mselect c with + | Some (op, res) -> + Some (proj op, meta_proj res) + | _ -> + None + in + let inj (op, res) = Contents_and_result (inj op, meta_inj res) in + let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in + tagged_case (Tag tag) name encoding proj inj + in + def "operation.alpha.operation_contents_and_result" + @@ union + [ make endorsement_case; + make seed_nonce_revelation_case; + make double_endorsement_evidence_case; + make double_baking_evidence_case; + make activate_account_case; + make proposals_case; + make ballot_case; + make reveal_case; + make transaction_case; + make origination_case; + make delegation_case ] + +type 'kind contents_result_list = + | Single_result : 'kind contents_result -> 'kind contents_result_list + | Cons_result : + 'kind Kind.manager contents_result + * 'rest Kind.manager contents_result_list + -> ('kind * 'rest) Kind.manager contents_result_list + +type packed_contents_result_list = + | Contents_result_list : + 'kind contents_result_list + -> packed_contents_result_list + +let contents_result_list_encoding = + let rec to_list = function + | Contents_result_list (Single_result o) -> + [Contents_result o] + | Contents_result_list (Cons_result (o, os)) -> + Contents_result o :: to_list (Contents_result_list os) + in + let rec of_list = function + | [] -> + Pervasives.failwith "cannot decode empty operation result" + | [Contents_result o] -> + Contents_result_list (Single_result o) + | Contents_result o :: os -> ( + let (Contents_result_list os) = of_list os in + match (o, os) with + | ( Manager_operation_result _, + Single_result (Manager_operation_result _) ) -> + Contents_result_list (Cons_result (o, os)) + | (Manager_operation_result _, Cons_result _) -> + Contents_result_list (Cons_result (o, os)) + | _ -> + Pervasives.failwith "cannot decode ill-formed operation result" ) + in + def "operation.alpha.contents_list_result" + @@ conv to_list of_list (list contents_result_encoding) + +type 'kind contents_and_result_list = + | Single_and_result : + 'kind Alpha_context.contents * 'kind contents_result + -> 'kind contents_and_result_list + | Cons_and_result : + 'kind Kind.manager Alpha_context.contents + * 'kind Kind.manager contents_result + * 'rest Kind.manager contents_and_result_list + -> ('kind * 'rest) Kind.manager contents_and_result_list + +type packed_contents_and_result_list = + | Contents_and_result_list : + 'kind contents_and_result_list + -> packed_contents_and_result_list + +let contents_and_result_list_encoding = + let rec to_list = function + | Contents_and_result_list (Single_and_result (op, res)) -> + [Contents_and_result (op, res)] + | Contents_and_result_list (Cons_and_result (op, res, rest)) -> + Contents_and_result (op, res) + :: to_list (Contents_and_result_list rest) + in + let rec of_list = function + | [] -> + Pervasives.failwith "cannot decode empty combined operation result" + | [Contents_and_result (op, res)] -> + Contents_and_result_list (Single_and_result (op, res)) + | Contents_and_result (op, res) :: rest -> ( + let (Contents_and_result_list rest) = of_list rest in + match (op, rest) with + | (Manager_operation _, Single_and_result (Manager_operation _, _)) -> + Contents_and_result_list (Cons_and_result (op, res, rest)) + | (Manager_operation _, Cons_and_result (_, _, _)) -> + Contents_and_result_list (Cons_and_result (op, res, rest)) + | _ -> + Pervasives.failwith + "cannot decode ill-formed combined operation result" ) + in + conv to_list of_list (Variable.list contents_and_result_encoding) + +type 'kind operation_metadata = {contents : 'kind contents_result_list} + +type packed_operation_metadata = + | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata + | No_operation_metadata : packed_operation_metadata + +let operation_metadata_encoding = + def "operation.alpha.result" + @@ union + [ case + (Tag 0) + ~title:"Operation_metadata" + contents_result_list_encoding + (function + | Operation_metadata {contents} -> + Some (Contents_result_list contents) + | _ -> + None) + (fun (Contents_result_list contents) -> + Operation_metadata {contents}); + case + (Tag 1) + ~title:"No_operation_metadata" + empty + (function No_operation_metadata -> Some () | _ -> None) + (fun () -> No_operation_metadata) ] + +let kind_equal : + type kind kind2. + kind contents -> kind2 contents_result -> (kind, kind2) eq option = + fun op res -> + match (op, res) with + | (Endorsement _, Endorsement_result _) -> + Some Eq + | (Endorsement _, _) -> + None + | (Seed_nonce_revelation _, Seed_nonce_revelation_result _) -> + Some Eq + | (Seed_nonce_revelation _, _) -> + None + | (Double_endorsement_evidence _, Double_endorsement_evidence_result _) -> + Some Eq + | (Double_endorsement_evidence _, _) -> + None + | (Double_baking_evidence _, Double_baking_evidence_result _) -> + Some Eq + | (Double_baking_evidence _, _) -> + None + | (Activate_account _, Activate_account_result _) -> + Some Eq + | (Activate_account _, _) -> + None + | (Proposals _, Proposals_result) -> + Some Eq + | (Proposals _, _) -> + None + | (Ballot _, Ballot_result) -> + Some Eq + | (Ballot _, _) -> + None + | ( Manager_operation {operation = Reveal _; _}, + Manager_operation_result {operation_result = Applied (Reveal_result _); _} + ) -> + Some Eq + | ( Manager_operation {operation = Reveal _; _}, + Manager_operation_result + {operation_result = Backtracked (Reveal_result _, _); _} ) -> + Some Eq + | ( Manager_operation {operation = Reveal _; _}, + Manager_operation_result + { operation_result = Failed (Alpha_context.Kind.Reveal_manager_kind, _); + _ } ) -> + Some Eq + | ( Manager_operation {operation = Reveal _; _}, + Manager_operation_result + {operation_result = Skipped Alpha_context.Kind.Reveal_manager_kind; _} + ) -> + Some Eq + | (Manager_operation {operation = Reveal _; _}, _) -> + None + | ( Manager_operation {operation = Transaction _; _}, + Manager_operation_result + {operation_result = Applied (Transaction_result _); _} ) -> + Some Eq + | ( Manager_operation {operation = Transaction _; _}, + Manager_operation_result + {operation_result = Backtracked (Transaction_result _, _); _} ) -> + Some Eq + | ( Manager_operation {operation = Transaction _; _}, + Manager_operation_result + { operation_result = + Failed (Alpha_context.Kind.Transaction_manager_kind, _); + _ } ) -> + Some Eq + | ( Manager_operation {operation = Transaction _; _}, + Manager_operation_result + { operation_result = Skipped Alpha_context.Kind.Transaction_manager_kind; + _ } ) -> + Some Eq + | (Manager_operation {operation = Transaction _; _}, _) -> + None + | ( Manager_operation {operation = Origination _; _}, + Manager_operation_result + {operation_result = Applied (Origination_result _); _} ) -> + Some Eq + | ( Manager_operation {operation = Origination _; _}, + Manager_operation_result + {operation_result = Backtracked (Origination_result _, _); _} ) -> + Some Eq + | ( Manager_operation {operation = Origination _; _}, + Manager_operation_result + { operation_result = + Failed (Alpha_context.Kind.Origination_manager_kind, _); + _ } ) -> + Some Eq + | ( Manager_operation {operation = Origination _; _}, + Manager_operation_result + { operation_result = Skipped Alpha_context.Kind.Origination_manager_kind; + _ } ) -> + Some Eq + | (Manager_operation {operation = Origination _; _}, _) -> + None + | ( Manager_operation {operation = Delegation _; _}, + Manager_operation_result + {operation_result = Applied (Delegation_result _); _} ) -> + Some Eq + | ( Manager_operation {operation = Delegation _; _}, + Manager_operation_result + {operation_result = Backtracked (Delegation_result _, _); _} ) -> + Some Eq + | ( Manager_operation {operation = Delegation _; _}, + Manager_operation_result + { operation_result = + Failed (Alpha_context.Kind.Delegation_manager_kind, _); + _ } ) -> + Some Eq + | ( Manager_operation {operation = Delegation _; _}, + Manager_operation_result + { operation_result = Skipped Alpha_context.Kind.Delegation_manager_kind; + _ } ) -> + Some Eq + | (Manager_operation {operation = Delegation _; _}, _) -> + None + +let rec kind_equal_list : + type kind kind2. + kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option + = + fun contents res -> + match (contents, res) with + | (Single op, Single_result res) -> ( + match kind_equal op res with None -> None | Some Eq -> Some Eq ) + | (Cons (op, ops), Cons_result (res, ress)) -> ( + match kind_equal op res with + | None -> + None + | Some Eq -> ( + match kind_equal_list ops ress with None -> None | Some Eq -> Some Eq ) ) + | _ -> + None + +let rec pack_contents_list : + type kind. + kind contents_list -> + kind contents_result_list -> + kind contents_and_result_list = + fun contents res -> + match (contents, res) with + | (Single op, Single_result res) -> + Single_and_result (op, res) + | (Cons (op, ops), Cons_result (res, ress)) -> + Cons_and_result (op, res, pack_contents_list ops ress) + | ( Single (Manager_operation _), + Cons_result (Manager_operation_result _, Single_result _) ) -> + . + | ( Cons (_, _), + Single_result (Manager_operation_result {operation_result = Failed _; _}) + ) -> + . + | ( Cons (_, _), + Single_result + (Manager_operation_result {operation_result = Skipped _; _}) ) -> + . + | ( Cons (_, _), + Single_result + (Manager_operation_result {operation_result = Applied _; _}) ) -> + . + | ( Cons (_, _), + Single_result + (Manager_operation_result {operation_result = Backtracked _; _}) ) -> + . + | (Single _, Cons_result _) -> + . + +let rec unpack_contents_list : + type kind. + kind contents_and_result_list -> + kind contents_list * kind contents_result_list = function + | Single_and_result (op, res) -> + (Single op, Single_result res) + | Cons_and_result (op, res, rest) -> + let (ops, ress) = unpack_contents_list rest in + (Cons (op, ops), Cons_result (res, ress)) + +let rec to_list = function + | Contents_result_list (Single_result o) -> + [Contents_result o] + | Contents_result_list (Cons_result (o, os)) -> + Contents_result o :: to_list (Contents_result_list os) + +let rec of_list = function + | [] -> + assert false + | [Contents_result o] -> + Contents_result_list (Single_result o) + | Contents_result o :: os -> ( + let (Contents_result_list os) = of_list os in + match (o, os) with + | (Manager_operation_result _, Single_result (Manager_operation_result _)) + -> + Contents_result_list (Cons_result (o, os)) + | (Manager_operation_result _, Cons_result _) -> + Contents_result_list (Cons_result (o, os)) + | _ -> + Pervasives.failwith + "Operation result list of length > 1 should only contains manager \ + operations result." ) + +let operation_data_and_metadata_encoding = + def "operation.alpha.operation_with_metadata" + @@ union + [ case + (Tag 0) + ~title:"Operation_with_metadata" + (obj2 + (req "contents" (dynamic_size contents_and_result_list_encoding)) + (opt "signature" Signature.encoding)) + (function + | (Operation_data _, No_operation_metadata) -> + None + | (Operation_data op, Operation_metadata res) -> ( + match kind_equal_list op.contents res.contents with + | None -> + Pervasives.failwith + "cannot decode inconsistent combined operation result" + | Some Eq -> + Some + ( Contents_and_result_list + (pack_contents_list op.contents res.contents), + op.signature ) )) + (fun (Contents_and_result_list contents, signature) -> + let (op_contents, res_contents) = unpack_contents_list contents in + ( Operation_data {contents = op_contents; signature}, + Operation_metadata {contents = res_contents} )); + case + (Tag 1) + ~title:"Operation_without_metadata" + (obj2 + (req "contents" (dynamic_size Operation.contents_list_encoding)) + (opt "signature" Signature.encoding)) + (function + | (Operation_data op, No_operation_metadata) -> + Some (Contents_list op.contents, op.signature) + | (Operation_data _, Operation_metadata _) -> + None) + (fun (Contents_list contents, signature) -> + (Operation_data {contents; signature}, No_operation_metadata)) ] + +type block_metadata = { + baker : Signature.Public_key_hash.t; + level : Level.compat_t; + level_info : Level.t; + voting_period_kind : Voting_period.kind; + voting_period_info : Voting_period.info; + nonce_hash : Nonce_hash.t option; + consumed_gas : Gas.Arith.fp; + deactivated : Signature.Public_key_hash.t list; + balance_updates : Delegate.balance_updates; +} + +let block_metadata_encoding = + let open Data_encoding in + def "block_header.alpha.metadata" + @@ conv + (fun { baker; + level; + level_info; + voting_period_kind; + voting_period_info; + nonce_hash; + consumed_gas; + deactivated; + balance_updates } -> + ( baker, + level, + level_info, + voting_period_kind, + voting_period_info, + nonce_hash, + consumed_gas, + deactivated, + balance_updates )) + (fun ( baker, + level, + level_info, + voting_period_kind, + voting_period_info, + nonce_hash, + consumed_gas, + deactivated, + balance_updates ) -> + { + baker; + level; + level_info; + voting_period_kind; + voting_period_info; + nonce_hash; + consumed_gas; + deactivated; + balance_updates; + }) + (obj9 + (req "baker" Signature.Public_key_hash.encoding) + (req + ~description:"This field is DEPRECATED: use level_info instead" + "level" + Level.compat_encoding) + (req "level_info" Level.encoding) + (req + ~description: + "This field is DEPRECATED: use voting_period_info instead" + "voting_period_kind" + Voting_period.kind_encoding) + (req "voting_period_info" Voting_period.info_encoding) + (req "nonce_hash" (option Nonce_hash.encoding)) + (req "consumed_gas" Gas.Arith.n_fp_encoding) + (req "deactivated" (list Signature.Public_key_hash.encoding)) + (req "balance_updates" Delegate.balance_updates_encoding)) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/apply_results.mli b/src/proto_008_PtEdo2Zk/lib_protocol/apply_results.mli new file mode 100644 index 0000000000000000000000000000000000000000..9a68bbba80ff02413a46d2866f3ecd3a38ebae8e --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/apply_results.mli @@ -0,0 +1,192 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Result of applying an operation, can be used for experimenting + with protocol updates, by clients to print out a summary of the + operation at pre-injection simulation and at confirmation time, + and by block explorers. *) + +open Alpha_context + +(** Result of applying a {!Operation.t}. Follows the same structure. *) +type 'kind operation_metadata = {contents : 'kind contents_result_list} + +and packed_operation_metadata = + | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata + | No_operation_metadata : packed_operation_metadata + +(** Result of applying a {!Operation.contents_list}. Follows the same structure. *) +and 'kind contents_result_list = + | Single_result : 'kind contents_result -> 'kind contents_result_list + | Cons_result : + 'kind Kind.manager contents_result + * 'rest Kind.manager contents_result_list + -> ('kind * 'rest) Kind.manager contents_result_list + +and packed_contents_result_list = + | Contents_result_list : + 'kind contents_result_list + -> packed_contents_result_list + +(** Result of applying an {!Operation.contents}. Follows the same structure. *) +and 'kind contents_result = + | Endorsement_result : { + balance_updates : Delegate.balance_updates; + delegate : Signature.Public_key_hash.t; + slots : int list; + } + -> Kind.endorsement contents_result + | Seed_nonce_revelation_result : + Delegate.balance_updates + -> Kind.seed_nonce_revelation contents_result + | Double_endorsement_evidence_result : + Delegate.balance_updates + -> Kind.double_endorsement_evidence contents_result + | Double_baking_evidence_result : + Delegate.balance_updates + -> Kind.double_baking_evidence contents_result + | Activate_account_result : + Delegate.balance_updates + -> Kind.activate_account contents_result + | Proposals_result : Kind.proposals contents_result + | Ballot_result : Kind.ballot contents_result + | Manager_operation_result : { + balance_updates : Delegate.balance_updates; + operation_result : 'kind manager_operation_result; + internal_operation_results : packed_internal_operation_result list; + } + -> 'kind Kind.manager contents_result + +and packed_contents_result = + | Contents_result : 'kind contents_result -> packed_contents_result + +(** The result of an operation in the queue. [Skipped] ones should + always be at the tail, and after a single [Failed]. *) +and 'kind manager_operation_result = + | Applied of 'kind successful_manager_operation_result + | Backtracked of + 'kind successful_manager_operation_result * error list option + | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result + | Skipped : 'kind Kind.manager -> 'kind manager_operation_result + +(** Result of applying a {!manager_operation_content}, either internal + or external. *) +and _ successful_manager_operation_result = + | Reveal_result : { + consumed_gas : Gas.Arith.fp; + } + -> Kind.reveal successful_manager_operation_result + | Transaction_result : { + storage : Script.expr option; + lazy_storage_diff : Lazy_storage.diffs option; + balance_updates : Delegate.balance_updates; + originated_contracts : Contract.t list; + consumed_gas : Gas.Arith.fp; + storage_size : Z.t; + paid_storage_size_diff : Z.t; + allocated_destination_contract : bool; + } + -> Kind.transaction successful_manager_operation_result + | Origination_result : { + lazy_storage_diff : Lazy_storage.diffs option; + balance_updates : Delegate.balance_updates; + originated_contracts : Contract.t list; + consumed_gas : Gas.Arith.fp; + storage_size : Z.t; + paid_storage_size_diff : Z.t; + } + -> Kind.origination successful_manager_operation_result + | Delegation_result : { + consumed_gas : Gas.Arith.fp; + } + -> Kind.delegation successful_manager_operation_result + +and packed_successful_manager_operation_result = + | Successful_manager_result : + 'kind successful_manager_operation_result + -> packed_successful_manager_operation_result + +and packed_internal_operation_result = + | Internal_operation_result : + 'kind internal_operation * 'kind manager_operation_result + -> packed_internal_operation_result + +(** Serializer for {!packed_operation_result}. *) +val operation_metadata_encoding : packed_operation_metadata Data_encoding.t + +val operation_data_and_metadata_encoding : + (Operation.packed_protocol_data * packed_operation_metadata) Data_encoding.t + +type 'kind contents_and_result_list = + | Single_and_result : + 'kind Alpha_context.contents * 'kind contents_result + -> 'kind contents_and_result_list + | Cons_and_result : + 'kind Kind.manager Alpha_context.contents + * 'kind Kind.manager contents_result + * 'rest Kind.manager contents_and_result_list + -> ('kind * 'rest) Kind.manager contents_and_result_list + +type packed_contents_and_result_list = + | Contents_and_result_list : + 'kind contents_and_result_list + -> packed_contents_and_result_list + +val contents_and_result_list_encoding : + packed_contents_and_result_list Data_encoding.t + +val pack_contents_list : + 'kind contents_list -> + 'kind contents_result_list -> + 'kind contents_and_result_list + +val unpack_contents_list : + 'kind contents_and_result_list -> + 'kind contents_list * 'kind contents_result_list + +val to_list : packed_contents_result_list -> packed_contents_result list + +val of_list : packed_contents_result list -> packed_contents_result_list + +type ('a, 'b) eq = Eq : ('a, 'a) eq + +val kind_equal_list : + 'kind contents_list -> + 'kind2 contents_result_list -> + ('kind, 'kind2) eq option + +type block_metadata = { + baker : Signature.Public_key_hash.t; + level : Level.compat_t; + level_info : Level.t; + voting_period_kind : Voting_period.kind; + voting_period_info : Voting_period.info; + nonce_hash : Nonce_hash.t option; + consumed_gas : Gas.Arith.fp; + deactivated : Signature.Public_key_hash.t list; + balance_updates : Delegate.balance_updates; +} + +val block_metadata_encoding : block_metadata Data_encoding.encoding diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/baking.ml b/src/proto_008_PtEdo2Zk/lib_protocol/baking.ml new file mode 100644 index 0000000000000000000000000000000000000000..371c27212a40f2393a5932ab643e1851aaa8ef85 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/baking.ml @@ -0,0 +1,397 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Misc + +type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *) + +type error += Timestamp_too_early of Timestamp.t * Timestamp.t + +(* `Permanent *) + +type error += Unexpected_endorsement (* `Permanent *) + +type error += + | Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t + +(* `Permanent *) + +type error += Invalid_signature (* `Permanent *) + +type error += Invalid_stamp (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"baking.timestamp_too_early" + ~title:"Block forged too early" + ~description: + "The block timestamp is before the first slot for this baker at this \ + level" + ~pp:(fun ppf (r, p) -> + Format.fprintf + ppf + "Block forged too early (%a is before %a)" + Time.pp_hum + p + Time.pp_hum + r) + Data_encoding.( + obj2 (req "minimum" Time.encoding) (req "provided" Time.encoding)) + (function Timestamp_too_early (r, p) -> Some (r, p) | _ -> None) + (fun (r, p) -> Timestamp_too_early (r, p)) ; + register_error_kind + `Permanent + ~id:"baking.invalid_fitness_gap" + ~title:"Invalid fitness gap" + ~description:"The gap of fitness is out of bounds" + ~pp:(fun ppf (m, g) -> + Format.fprintf ppf "The gap of fitness %Ld is not between 0 and %Ld" g m) + Data_encoding.(obj2 (req "maximum" int64) (req "provided" int64)) + (function Invalid_fitness_gap (m, g) -> Some (m, g) | _ -> None) + (fun (m, g) -> Invalid_fitness_gap (m, g)) ; + register_error_kind + `Permanent + ~id:"baking.invalid_block_signature" + ~title:"Invalid block signature" + ~description:"A block was not signed with the expected private key." + ~pp:(fun ppf (block, pkh) -> + Format.fprintf + ppf + "Invalid signature for block %a. Expected: %a." + Block_hash.pp_short + block + Signature.Public_key_hash.pp_short + pkh) + Data_encoding.( + obj2 + (req "block" Block_hash.encoding) + (req "expected" Signature.Public_key_hash.encoding)) + (function + | Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None) + (fun (block, pkh) -> Invalid_block_signature (block, pkh)) ; + register_error_kind + `Permanent + ~id:"baking.invalid_signature" + ~title:"Invalid block signature" + ~description:"The block's signature is invalid" + ~pp:(fun ppf () -> Format.fprintf ppf "Invalid block signature") + Data_encoding.empty + (function Invalid_signature -> Some () | _ -> None) + (fun () -> Invalid_signature) ; + register_error_kind + `Permanent + ~id:"baking.insufficient_proof_of_work" + ~title:"Insufficient block proof-of-work stamp" + ~description:"The block's proof-of-work stamp is insufficient" + ~pp:(fun ppf () -> Format.fprintf ppf "Insufficient proof-of-work stamp") + Data_encoding.empty + (function Invalid_stamp -> Some () | _ -> None) + (fun () -> Invalid_stamp) ; + register_error_kind + `Permanent + ~id:"baking.unexpected_endorsement" + ~title:"Endorsement from unexpected delegate" + ~description: + "The operation is signed by a delegate without endorsement rights." + ~pp:(fun ppf () -> + Format.fprintf + ppf + "The endorsement is signed by a delegate without endorsement rights.") + Data_encoding.unit + (function Unexpected_endorsement -> Some () | _ -> None) + (fun () -> Unexpected_endorsement) + +let minimal_time c priority pred_timestamp = + let priority = Int32.of_int priority in + let rec cumsum_time_between_blocks acc durations p = + if Compare.Int32.( <= ) p 0l then ok acc + else + match durations with + | [] -> + cumsum_time_between_blocks acc [Period.one_minute] p + | [last] -> + Period.mult p last >>? fun period -> Timestamp.(acc +? period) + | first :: durations -> + Timestamp.(acc +? first) + >>? fun acc -> + let p = Int32.pred p in + cumsum_time_between_blocks acc durations p + in + cumsum_time_between_blocks + pred_timestamp + (Constants.time_between_blocks c) + (Int32.succ priority) + +let earlier_predecessor_timestamp ctxt level = + let current = Level.current ctxt in + let current_timestamp = Timestamp.current ctxt in + let gap = Level.diff level current in + let step = List.hd (Constants.time_between_blocks ctxt) in + if Compare.Int32.(gap < 1l) then + failwith "Baking.earlier_block_timestamp: past block." + else + Period.mult (Int32.pred gap) step + >>? fun delay -> Timestamp.(current_timestamp +? delay) + +let check_timestamp c priority pred_timestamp = + minimal_time c priority pred_timestamp + >>? fun minimal_time -> + let timestamp = Alpha_context.Timestamp.current c in + record_trace + (Timestamp_too_early (minimal_time, timestamp)) + Timestamp.(timestamp -? minimal_time) + +let check_baking_rights c {Block_header.priority; _} pred_timestamp = + let level = Level.current c in + Roll.baking_rights_owner c level ~priority + >>=? fun delegate -> + Lwt.return + ( check_timestamp c priority pred_timestamp + >|? fun block_delay -> (delegate, block_delay) ) + +type error += Incorrect_priority (* `Permanent *) + +type error += Incorrect_number_of_endorsements (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"incorrect_priority" + ~title:"Incorrect priority" + ~description:"Block priority must be non-negative." + ~pp:(fun ppf () -> + Format.fprintf ppf "The block priority must be non-negative.") + Data_encoding.unit + (function Incorrect_priority -> Some () | _ -> None) + (fun () -> Incorrect_priority) + +let () = + let description = + "The number of endorsements must be non-negative and at most the \ + endorsers_per_block constant." + in + register_error_kind + `Permanent + ~id:"incorrect_number_of_endorsements" + ~title:"Incorrect number of endorsements" + ~description + ~pp:(fun ppf () -> Format.fprintf ppf "%s" description) + Data_encoding.unit + (function Incorrect_number_of_endorsements -> Some () | _ -> None) + (fun () -> Incorrect_number_of_endorsements) + +let rec reward_for_priority reward_per_prio prio = + match reward_per_prio with + | [] -> + (* Empty reward list in parameters means no rewards *) + Tez.zero + | [last] -> + last + | first :: rest -> + if Compare.Int.(prio <= 0) then first + else reward_for_priority rest (pred prio) + +let baking_reward ctxt ~block_priority ~included_endorsements = + error_unless Compare.Int.(block_priority >= 0) Incorrect_priority + >>? fun () -> + error_unless + Compare.Int.( + included_endorsements >= 0 + && included_endorsements <= Constants.endorsers_per_block ctxt) + Incorrect_number_of_endorsements + >>? fun () -> + let reward_per_endorsement = + reward_for_priority + (Constants.baking_reward_per_endorsement ctxt) + block_priority + in + Tez.(reward_per_endorsement *? Int64.of_int included_endorsements) + +let endorsing_reward ctxt ~block_priority num_slots = + error_unless Compare.Int.(block_priority >= 0) Incorrect_priority + >>? fun () -> + let reward_per_endorsement = + reward_for_priority (Constants.endorsement_reward ctxt) block_priority + in + Tez.(reward_per_endorsement *? Int64.of_int num_slots) + +let baking_priorities c level = + let rec f priority = + Roll.baking_rights_owner c level ~priority + >|=? fun delegate -> LCons (delegate, fun () -> f (succ priority)) + in + f 0 + +let endorsement_rights ctxt level = + fold_left_s + (fun acc slot -> + Roll.endorsement_rights_owner ctxt level ~slot + >|=? fun pk -> + let pkh = Signature.Public_key.hash pk in + let right = + match Signature.Public_key_hash.Map.find_opt pkh acc with + | None -> + (pk, [slot], false) + | Some (pk, slots, used) -> + (pk, slot :: slots, used) + in + Signature.Public_key_hash.Map.add pkh right acc) + Signature.Public_key_hash.Map.empty + (0 --> (Constants.endorsers_per_block ctxt - 1)) + +let check_endorsement_rights ctxt chain_id (op : Kind.endorsement Operation.t) + = + let current_level = Level.current ctxt in + let (Single (Endorsement {level; _})) = op.protocol_data.contents in + ( if Raw_level.(succ level = current_level.level) then + return (Alpha_context.allowed_endorsements ctxt) + else endorsement_rights ctxt (Level.from_raw ctxt level) ) + >>=? fun endorsements -> + match + Signature.Public_key_hash.Map.fold (* no find_first *) + (fun pkh (pk, slots, used) acc -> + match Operation.check_signature pk chain_id op with + | Error _ -> + acc + | Ok () -> + Some (pkh, slots, used)) + endorsements + None + with + | None -> + fail Unexpected_endorsement + | Some v -> + return v + +let select_delegate delegate delegate_list max_priority = + let rec loop acc l n = + if Compare.Int.(n >= max_priority) then return (List.rev acc) + else + let (LCons (pk, t)) = l in + let acc = + if + Signature.Public_key_hash.equal + delegate + (Signature.Public_key.hash pk) + then n :: acc + else acc + in + t () >>=? fun t -> loop acc t (succ n) + in + loop [] delegate_list 0 + +let first_baking_priorities ctxt ?(max_priority = 32) delegate level = + baking_priorities ctxt level + >>=? fun delegate_list -> select_delegate delegate delegate_list max_priority + +let check_hash hash stamp_threshold = + let bytes = Block_hash.to_bytes hash in + let word = TzEndian.get_int64 bytes 0 in + Compare.Uint64.(word <= stamp_threshold) + +let check_header_proof_of_work_stamp shell contents stamp_threshold = + let hash = + Block_header.hash + {shell; protocol_data = {contents; signature = Signature.zero}} + in + check_hash hash stamp_threshold + +let check_proof_of_work_stamp ctxt block = + let proof_of_work_threshold = Constants.proof_of_work_threshold ctxt in + if + check_header_proof_of_work_stamp + block.Block_header.shell + block.protocol_data.contents + proof_of_work_threshold + then ok_unit + else error Invalid_stamp + +let check_signature block chain_id key = + let check_signature key + {Block_header.shell; protocol_data = {contents; signature}} = + let unsigned_header = + Data_encoding.Binary.to_bytes_exn + Block_header.unsigned_encoding + (shell, contents) + in + Signature.check + ~watermark:(Block_header chain_id) + key + signature + unsigned_header + in + if check_signature key block then return_unit + else + fail + (Invalid_block_signature + (Block_header.hash block, Signature.Public_key.hash key)) + +let max_fitness_gap _ctxt = 1L + +let check_fitness_gap ctxt (block : Block_header.t) = + let current_fitness = Fitness.current ctxt in + Fitness.to_int64 block.shell.fitness + >>? fun announced_fitness -> + let gap = Int64.sub announced_fitness current_fitness in + if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then + error (Invalid_fitness_gap (max_fitness_gap ctxt, gap)) + else ok_unit + +let last_of_a_cycle ctxt (l : Level.t) = + Compare.Int32.( + Int32.succ l.Level.cycle_position = Constants.blocks_per_cycle ctxt) + +let dawn_of_a_new_cycle ctxt = + let level = Level.current ctxt in + if last_of_a_cycle ctxt level then Some level.cycle else None + +let minimum_allowed_endorsements ctxt ~block_delay = + let minimum = Constants.initial_endorsers ctxt in + let delay_per_missing_endorsement = + Period.to_seconds (Constants.delay_per_missing_endorsement ctxt) + in + let reduced_time_constraint = + let delay = Period.to_seconds block_delay in + if Compare.Int64.(delay_per_missing_endorsement = 0L) then delay + else Int64.div delay delay_per_missing_endorsement + in + if Compare.Int64.(Int64.of_int minimum < reduced_time_constraint) then 0 + else minimum - Int64.to_int reduced_time_constraint + +let minimal_valid_time ctxt ~priority ~endorsing_power = + let predecessor_timestamp = Timestamp.current ctxt in + minimal_time ctxt priority predecessor_timestamp + >>? fun minimal_time -> + let minimal_required_endorsements = Constants.initial_endorsers ctxt in + let delay_per_missing_endorsement = + Constants.delay_per_missing_endorsement ctxt + in + let missing_endorsements = + Compare.Int.max 0 (minimal_required_endorsements - endorsing_power) + in + Period.mult (Int32.of_int missing_endorsements) delay_per_missing_endorsement + >|? fun delay -> Time.add minimal_time (Period.to_seconds delay) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/baking.mli b/src/proto_008_PtEdo2Zk/lib_protocol/baking.mli new file mode 100644 index 0000000000000000000000000000000000000000..e4d1bbb851c052b9a9973bba91eac27902b560b7 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/baking.mli @@ -0,0 +1,157 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Misc + +type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *) + +type error += Timestamp_too_early of Timestamp.t * Timestamp.t + +(* `Permanent *) + +type error += + | Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t + +(* `Permanent *) + +type error += Unexpected_endorsement + +type error += Invalid_signature (* `Permanent *) + +type error += Invalid_stamp (* `Permanent *) + +(** [minimal_time ctxt priority pred_block_time] returns the minimal + time, given the predecessor block timestamp [pred_block_time], + after which a baker with priority [priority] is allowed to + bake. Fail with [Invalid_time_between_blocks_constant] if the minimal + time cannot be computed. *) +val minimal_time : context -> int -> Time.t -> Time.t tzresult + +(** [check_baking_rights ctxt block pred_timestamp] verifies that: + * the contract that owned the roll at cycle start has the block signer as delegate. + * the timestamp is coherent with the announced slot. +*) +val check_baking_rights : + context -> + Block_header.contents -> + Time.t -> + (public_key * Period.t) tzresult Lwt.t + +(** For a given level computes who has the right to + include an endorsement in the next block. + The result can be stored in Alpha_context.allowed_endorsements *) +val endorsement_rights : + context -> + Level.t -> + (public_key * int list * bool) Signature.Public_key_hash.Map.t tzresult Lwt.t + +(** Check that the operation was signed by a delegate allowed + to endorse at the level specified by the endorsement. *) +val check_endorsement_rights : + context -> + Chain_id.t -> + Kind.endorsement Operation.t -> + (public_key_hash * int list * bool) tzresult Lwt.t + +(** Returns the baking reward calculated w.r.t a given priority [p] and a + number [e] of included endorsements *) +val baking_reward : + context -> block_priority:int -> included_endorsements:int -> Tez.t tzresult + +(** Returns the endorsing reward calculated w.r.t a given priority. *) +val endorsing_reward : context -> block_priority:int -> int -> Tez.t tzresult + +(** [baking_priorities ctxt level] is the lazy list of contract's + public key hashes that are allowed to bake for [level]. *) +val baking_priorities : context -> Level.t -> public_key lazy_list + +(** [first_baking_priorities ctxt ?max_priority contract_hash level] + is a list of priorities of max [?max_priority] elements, where the + delegate of [contract_hash] is allowed to bake for [level]. If + [?max_priority] is [None], a sensible number of priorities is + returned. *) +val first_baking_priorities : + context -> + ?max_priority:int -> + public_key_hash -> + Level.t -> + int list tzresult Lwt.t + +(** [check_signature ctxt chain_id block id] check if the block is + signed with the given key, and belongs to the given [chain_id] *) +val check_signature : + Block_header.t -> Chain_id.t -> public_key -> unit tzresult Lwt.t + +(** Checks if the header that would be built from the given components + is valid for the given difficulty. The signature is not passed as it + is does not impact the proof-of-work stamp. The stamp is checked on + the hash of a block header whose signature has been zeroed-out. *) +val check_header_proof_of_work_stamp : + Block_header.shell_header -> Block_header.contents -> int64 -> bool + +(** verify if the proof of work stamp is valid *) +val check_proof_of_work_stamp : context -> Block_header.t -> unit tzresult + +(** check if the gap between the fitness of the current context + and the given block is within the protocol parameters *) +val check_fitness_gap : context -> Block_header.t -> unit tzresult + +val dawn_of_a_new_cycle : context -> Cycle.t option + +val earlier_predecessor_timestamp : context -> Level.t -> Timestamp.t tzresult + +(** Since Emmy+ + + A block is valid only if its timestamp has a minimal delay with + respect to the previous block's timestamp, and this minimal delay + depends not only on the block's priority but also on the number of + endorsement operations included in the block. + + In Emmy+, blocks' fitness increases by one unit with each level. + + In this way, Emmy+ simplifies the optimal baking strategy: The + bakers used to have to choose whether to wait for more endorsements + to include in their block, or to publish the block immediately, + without waiting. The incentive for including more endorsements was + to increase the fitness and win against unknown blocks. However, + when a block was produced too late in the priority period, there + was the risk that the block did not reach endorsers before the + block of next priority. In Emmy+, the baker does not need to take + such a decision, because the baker cannot publish a block too + early. *) + +(** Given a delay of a block's timestamp with respect to the minimum + time to bake at the block's priority (as returned by + `minimum_time`), it returns the minimum number of endorsements that + the block has to contain *) +val minimum_allowed_endorsements : context -> block_delay:Period.t -> int + +(** This is the somehow the dual of the previous function. Given a + block priority and a number of endorsement slots (given by the + `endorsing_power` argument), it returns the minimum time at which + the next block can be baked. *) +val minimal_valid_time : + context -> priority:int -> endorsing_power:int -> Time.t tzresult diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/blinded_public_key_hash.ml b/src/proto_008_PtEdo2Zk/lib_protocol/blinded_public_key_hash.ml new file mode 100644 index 0000000000000000000000000000000000000000..f171500e402f0eb0db17ac62357d1dcbd70e1cdb --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/blinded_public_key_hash.ml @@ -0,0 +1,57 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module H = + Blake2B.Make + (Base58) + (struct + let name = "Blinded public key hash" + + let title = "A blinded public key hash" + + let b58check_prefix = "\001\002\049\223" + + let size = Some Ed25519.Public_key_hash.size + end) + +include H + +let () = Base58.check_encoded_prefix b58check_encoding "btz1" 37 + +let of_ed25519_pkh activation_code pkh = + hash_bytes ~key:activation_code [Ed25519.Public_key_hash.to_bytes pkh] + +type activation_code = bytes + +let activation_code_size = Ed25519.Public_key_hash.size + +let activation_code_encoding = Data_encoding.Fixed.bytes activation_code_size + +let activation_code_of_hex h = + if Compare.Int.(String.length h <> activation_code_size * 2) then + invalid_arg "Blinded_public_key_hash.activation_code_of_hex" ; + Hex.to_bytes (`Hex h) + +module Index = H diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/blinded_public_key_hash.mli b/src/proto_008_PtEdo2Zk/lib_protocol/blinded_public_key_hash.mli new file mode 100644 index 0000000000000000000000000000000000000000..6d9ccfc2d1ee536ff9de8fb8a99072e769e05cd3 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/blinded_public_key_hash.mli @@ -0,0 +1,36 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include S.HASH + +type activation_code + +val activation_code_encoding : activation_code Data_encoding.t + +val of_ed25519_pkh : activation_code -> Ed25519.Public_key_hash.t -> t + +val activation_code_of_hex : string -> activation_code + +module Index : Storage_description.INDEX with type t = t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/block_header_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/block_header_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..5d70cfea566a347cdae56a7f68ef8699a5b48639 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/block_header_repr.ml @@ -0,0 +1,130 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Block header *) + +type t = {shell : Block_header.shell_header; protocol_data : protocol_data} + +and protocol_data = {contents : contents; signature : Signature.t} + +and contents = { + priority : int; + seed_nonce_hash : Nonce_hash.t option; + proof_of_work_nonce : bytes; +} + +type block_header = t + +type raw = Block_header.t + +type shell_header = Block_header.shell_header + +let raw_encoding = Block_header.encoding + +let shell_header_encoding = Block_header.shell_header_encoding + +let contents_encoding = + let open Data_encoding in + def "block_header.alpha.unsigned_contents" + @@ conv + (fun {priority; seed_nonce_hash; proof_of_work_nonce} -> + (priority, proof_of_work_nonce, seed_nonce_hash)) + (fun (priority, proof_of_work_nonce, seed_nonce_hash) -> + {priority; seed_nonce_hash; proof_of_work_nonce}) + (obj3 + (req "priority" uint16) + (req + "proof_of_work_nonce" + (Fixed.bytes Constants_repr.proof_of_work_nonce_size)) + (opt "seed_nonce_hash" Nonce_hash.encoding)) + +let protocol_data_encoding = + let open Data_encoding in + def "block_header.alpha.signed_contents" + @@ conv + (fun {contents; signature} -> (contents, signature)) + (fun (contents, signature) -> {contents; signature}) + (merge_objs + contents_encoding + (obj1 (req "signature" Signature.encoding))) + +let raw {shell; protocol_data} = + let protocol_data = + Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data + in + {Block_header.shell; protocol_data} + +let unsigned_encoding = + let open Data_encoding in + merge_objs Block_header.shell_header_encoding contents_encoding + +let encoding = + let open Data_encoding in + def "block_header.alpha.full_header" + @@ conv + (fun {shell; protocol_data} -> (shell, protocol_data)) + (fun (shell, protocol_data) -> {shell; protocol_data}) + (merge_objs Block_header.shell_header_encoding protocol_data_encoding) + +(** Constants *) + +let max_header_length = + let fake_shell = + { + Block_header.level = 0l; + proto_level = 0; + predecessor = Block_hash.zero; + timestamp = Time.of_seconds 0L; + validation_passes = 0; + operations_hash = Operation_list_list_hash.zero; + fitness = Fitness_repr.from_int64 0L; + context = Context_hash.zero; + } + and fake_contents = + { + priority = 0; + proof_of_work_nonce = + Bytes.make Constants_repr.proof_of_work_nonce_size '0'; + seed_nonce_hash = Some Nonce_hash.zero; + } + in + Data_encoding.Binary.length + encoding + { + shell = fake_shell; + protocol_data = {contents = fake_contents; signature = Signature.zero}; + } + +(** Header parsing entry point *) + +let hash_raw = Block_header.hash + +let hash {shell; protocol_data} = + Block_header.hash + { + shell; + protocol_data = + Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data; + } diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/block_header_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/block_header_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..3f3ddd0092705a0602af630ceeb979cd95664f8a --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/block_header_repr.mli @@ -0,0 +1,61 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = {shell : Block_header.shell_header; protocol_data : protocol_data} + +and protocol_data = {contents : contents; signature : Signature.t} + +and contents = { + priority : int; + seed_nonce_hash : Nonce_hash.t option; + proof_of_work_nonce : bytes; +} + +type block_header = t + +type raw = Block_header.t + +type shell_header = Block_header.shell_header + +val raw : block_header -> raw + +val encoding : block_header Data_encoding.encoding + +val raw_encoding : raw Data_encoding.t + +val contents_encoding : contents Data_encoding.t + +val unsigned_encoding : (Block_header.shell_header * contents) Data_encoding.t + +val protocol_data_encoding : protocol_data Data_encoding.encoding + +val shell_header_encoding : shell_header Data_encoding.encoding + +(** The maximum size of block headers in bytes *) +val max_header_length : int + +val hash : block_header -> Block_hash.t + +val hash_raw : raw -> Block_hash.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/bootstrap_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/bootstrap_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..f8c9e388470adcece8e6f486a1d381db26b8544b --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/bootstrap_storage.ml @@ -0,0 +1,147 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Misc + +let init_account ctxt + ({public_key_hash; public_key; amount} : Parameters_repr.bootstrap_account) + = + let contract = Contract_repr.implicit_contract public_key_hash in + Contract_storage.credit ctxt contract amount + >>=? fun ctxt -> + match public_key with + | Some public_key -> + Contract_storage.reveal_manager_key ctxt public_key_hash public_key + >>=? fun ctxt -> + Delegate_storage.set ctxt contract (Some public_key_hash) + | None -> + return ctxt + +let init_contract ~typecheck ctxt + ({delegate; amount; script} : Parameters_repr.bootstrap_contract) = + Contract_storage.fresh_contract_from_current_nonce ctxt + >>?= fun (ctxt, contract) -> + typecheck ctxt script + >>=? fun (script, ctxt) -> + Contract_storage.raw_originate + ctxt + contract + ~balance:amount + ~prepaid_bootstrap_storage:true + ~script + ~delegate:(Some delegate) + +let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts = + let nonce = + Operation_hash.hash_bytes [Bytes.of_string "Un festival de GADT."] + in + let ctxt = Raw_context.init_origination_nonce ctxt nonce in + fold_left_s init_account ctxt accounts + >>=? fun ctxt -> + fold_left_s (init_contract ~typecheck) ctxt contracts + >>=? fun ctxt -> + ( match no_reward_cycles with + | None -> + return ctxt + | Some cycles -> + (* Store pending ramp ups. *) + let constants = Raw_context.constants ctxt in + (* Start without rewards *) + Raw_context.patch_constants ctxt (fun c -> + { + c with + baking_reward_per_endorsement = [Tez_repr.zero]; + endorsement_reward = [Tez_repr.zero]; + }) + >>= fun ctxt -> + (* Store the final reward. *) + Storage.Ramp_up.Rewards.init + ctxt + (Cycle_repr.of_int32_exn (Int32.of_int cycles)) + (constants.baking_reward_per_endorsement, constants.endorsement_reward) + ) + >>=? fun ctxt -> + match ramp_up_cycles with + | None -> + return ctxt + | Some cycles -> + (* Store pending ramp ups. *) + let constants = Raw_context.constants ctxt in + Tez_repr.(constants.block_security_deposit /? Int64.of_int cycles) + >>?= fun block_step -> + Tez_repr.(constants.endorsement_security_deposit /? Int64.of_int cycles) + >>?= fun endorsement_step -> + (* Start without security_deposit *) + Raw_context.patch_constants ctxt (fun c -> + { + c with + block_security_deposit = Tez_repr.zero; + endorsement_security_deposit = Tez_repr.zero; + }) + >>= fun ctxt -> + fold_left_s + (fun ctxt cycle -> + Tez_repr.(block_step *? Int64.of_int cycle) + >>?= fun block_security_deposit -> + Tez_repr.(endorsement_step *? Int64.of_int cycle) + >>?= fun endorsement_security_deposit -> + let cycle = Cycle_repr.of_int32_exn (Int32.of_int cycle) in + Storage.Ramp_up.Security_deposits.init + ctxt + cycle + (block_security_deposit, endorsement_security_deposit)) + ctxt + (1 --> (cycles - 1)) + >>=? fun ctxt -> + (* Store the final security deposits. *) + Storage.Ramp_up.Security_deposits.init + ctxt + (Cycle_repr.of_int32_exn (Int32.of_int cycles)) + ( constants.block_security_deposit, + constants.endorsement_security_deposit ) + +let cycle_end ctxt last_cycle = + let next_cycle = Cycle_repr.succ last_cycle in + Storage.Ramp_up.Rewards.get_option ctxt next_cycle + >>=? (function + | None -> + return ctxt + | Some (baking_reward_per_endorsement, endorsement_reward) -> + Storage.Ramp_up.Rewards.delete ctxt next_cycle + >>=? fun ctxt -> + Raw_context.patch_constants ctxt (fun c -> + {c with baking_reward_per_endorsement; endorsement_reward}) + >|= ok) + >>=? fun ctxt -> + Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle + >>=? function + | None -> + return ctxt + | Some (block_security_deposit, endorsement_security_deposit) -> + Storage.Ramp_up.Security_deposits.delete ctxt next_cycle + >>=? fun ctxt -> + Raw_context.patch_constants ctxt (fun c -> + {c with block_security_deposit; endorsement_security_deposit}) + >|= ok diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/bootstrap_storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/bootstrap_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..0fb7b720b6a53d3118a86dbf6035222fefe606ef --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/bootstrap_storage.mli @@ -0,0 +1,39 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +val init : + Raw_context.t -> + typecheck:(Raw_context.t -> + Script_repr.t -> + ((Script_repr.t * Lazy_storage_diff.diffs option) * Raw_context.t) + tzresult + Lwt.t) -> + ?ramp_up_cycles:int -> + ?no_reward_cycles:int -> + Parameters_repr.bootstrap_account list -> + Parameters_repr.bootstrap_contract list -> + Raw_context.t tzresult Lwt.t + +val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/commitment_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/commitment_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..e64be9c0114ecc0a41358ffe9a2974ec9b040014 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/commitment_repr.ml @@ -0,0 +1,38 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = { + blinded_public_key_hash : Blinded_public_key_hash.t; + amount : Tez_repr.t; +} + +let encoding = + let open Data_encoding in + conv + (fun {blinded_public_key_hash; amount} -> + (blinded_public_key_hash, amount)) + (fun (blinded_public_key_hash, amount) -> + {blinded_public_key_hash; amount}) + (tup2 Blinded_public_key_hash.encoding Tez_repr.encoding) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/commitment_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/commitment_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..edca4134d844a163dfbdf9708af1797acfcfa46a --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/commitment_repr.mli @@ -0,0 +1,31 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = { + blinded_public_key_hash : Blinded_public_key_hash.t; + amount : Tez_repr.t; +} + +val encoding : t Data_encoding.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/commitment_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/commitment_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..bad319b671f8d1dc8562c3ccdf1fa223a21f0322 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/commitment_storage.ml @@ -0,0 +1,34 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let get_opt = Storage.Commitments.get_option + +let delete = Storage.Commitments.delete + +let init ctxt commitments = + let init_commitment ctxt Commitment_repr.{blinded_public_key_hash; amount} = + Storage.Commitments.init ctxt blinded_public_key_hash amount + in + fold_left_s init_commitment ctxt commitments diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/commitment_storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/commitment_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..1591cbebb1ea2e4c00781f4af9d3b282fd7885d8 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/commitment_storage.mli @@ -0,0 +1,35 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +val init : + Raw_context.t -> Commitment_repr.t list -> Raw_context.t tzresult Lwt.t + +val get_opt : + Raw_context.t -> + Blinded_public_key_hash.t -> + Tez_repr.t option tzresult Lwt.t + +val delete : + Raw_context.t -> Blinded_public_key_hash.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/constants_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/constants_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..9159bab6e48fc1661c41650df4f8f08a03562175 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/constants_repr.ml @@ -0,0 +1,242 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let version_number_004 = "\000" + +let version_number = "\001" + +let proof_of_work_nonce_size = 8 + +let nonce_length = 32 + +let max_anon_ops_per_block = 132 + +let max_proposals_per_delegate = 20 + +let max_operation_data_length = 16 * 1024 (* 16kB *) + +type fixed = { + proof_of_work_nonce_size : int; + nonce_length : int; + max_anon_ops_per_block : int; + max_operation_data_length : int; + max_proposals_per_delegate : int; +} + +let fixed_encoding = + let open Data_encoding in + conv + (fun c -> + ( c.proof_of_work_nonce_size, + c.nonce_length, + c.max_anon_ops_per_block, + c.max_operation_data_length, + c.max_proposals_per_delegate )) + (fun ( proof_of_work_nonce_size, + nonce_length, + max_anon_ops_per_block, + max_operation_data_length, + max_proposals_per_delegate ) -> + { + proof_of_work_nonce_size; + nonce_length; + max_anon_ops_per_block; + max_operation_data_length; + max_proposals_per_delegate; + }) + (obj5 + (req "proof_of_work_nonce_size" uint8) + (req "nonce_length" uint8) + (req "max_anon_ops_per_block" uint8) + (req "max_operation_data_length" int31) + (req "max_proposals_per_delegate" uint8)) + +let fixed = + { + proof_of_work_nonce_size; + nonce_length; + max_anon_ops_per_block; + max_operation_data_length; + max_proposals_per_delegate; + } + +type parametric = { + preserved_cycles : int; + blocks_per_cycle : int32; + blocks_per_commitment : int32; + blocks_per_roll_snapshot : int32; + blocks_per_voting_period : int32; + time_between_blocks : Period_repr.t list; + endorsers_per_block : int; + hard_gas_limit_per_operation : Gas_limit_repr.Arith.integral; + hard_gas_limit_per_block : Gas_limit_repr.Arith.integral; + proof_of_work_threshold : int64; + tokens_per_roll : Tez_repr.t; + michelson_maximum_type_size : int; + seed_nonce_revelation_tip : Tez_repr.t; + origination_size : int; + block_security_deposit : Tez_repr.t; + endorsement_security_deposit : Tez_repr.t; + baking_reward_per_endorsement : Tez_repr.t list; + endorsement_reward : Tez_repr.t list; + cost_per_byte : Tez_repr.t; + hard_storage_limit_per_operation : Z.t; + test_chain_duration : int64; + (* in seconds *) + quorum_min : int32; + quorum_max : int32; + min_proposal_quorum : int32; + initial_endorsers : int; + delay_per_missing_endorsement : Period_repr.t; +} + +let parametric_encoding = + let open Data_encoding in + conv + (fun c -> + ( ( c.preserved_cycles, + c.blocks_per_cycle, + c.blocks_per_commitment, + c.blocks_per_roll_snapshot, + c.blocks_per_voting_period, + c.time_between_blocks, + c.endorsers_per_block, + c.hard_gas_limit_per_operation, + c.hard_gas_limit_per_block ), + ( ( c.proof_of_work_threshold, + c.tokens_per_roll, + c.michelson_maximum_type_size, + c.seed_nonce_revelation_tip, + c.origination_size, + c.block_security_deposit, + c.endorsement_security_deposit, + c.baking_reward_per_endorsement ), + ( c.endorsement_reward, + c.cost_per_byte, + c.hard_storage_limit_per_operation, + c.test_chain_duration, + c.quorum_min, + c.quorum_max, + c.min_proposal_quorum, + c.initial_endorsers, + c.delay_per_missing_endorsement ) ) )) + (fun ( ( preserved_cycles, + blocks_per_cycle, + blocks_per_commitment, + blocks_per_roll_snapshot, + blocks_per_voting_period, + time_between_blocks, + endorsers_per_block, + hard_gas_limit_per_operation, + hard_gas_limit_per_block ), + ( ( proof_of_work_threshold, + tokens_per_roll, + michelson_maximum_type_size, + seed_nonce_revelation_tip, + origination_size, + block_security_deposit, + endorsement_security_deposit, + baking_reward_per_endorsement ), + ( endorsement_reward, + cost_per_byte, + hard_storage_limit_per_operation, + test_chain_duration, + quorum_min, + quorum_max, + min_proposal_quorum, + initial_endorsers, + delay_per_missing_endorsement ) ) ) -> + { + preserved_cycles; + blocks_per_cycle; + blocks_per_commitment; + blocks_per_roll_snapshot; + blocks_per_voting_period; + time_between_blocks; + endorsers_per_block; + hard_gas_limit_per_operation; + hard_gas_limit_per_block; + proof_of_work_threshold; + tokens_per_roll; + michelson_maximum_type_size; + seed_nonce_revelation_tip; + origination_size; + block_security_deposit; + endorsement_security_deposit; + baking_reward_per_endorsement; + endorsement_reward; + cost_per_byte; + hard_storage_limit_per_operation; + test_chain_duration; + quorum_min; + quorum_max; + min_proposal_quorum; + initial_endorsers; + delay_per_missing_endorsement; + }) + (merge_objs + (obj9 + (req "preserved_cycles" uint8) + (req "blocks_per_cycle" int32) + (req "blocks_per_commitment" int32) + (req "blocks_per_roll_snapshot" int32) + (req "blocks_per_voting_period" int32) + (req "time_between_blocks" (list Period_repr.encoding)) + (req "endorsers_per_block" uint16) + (req + "hard_gas_limit_per_operation" + Gas_limit_repr.Arith.z_integral_encoding) + (req + "hard_gas_limit_per_block" + Gas_limit_repr.Arith.z_integral_encoding)) + (merge_objs + (obj8 + (req "proof_of_work_threshold" int64) + (req "tokens_per_roll" Tez_repr.encoding) + (req "michelson_maximum_type_size" uint16) + (req "seed_nonce_revelation_tip" Tez_repr.encoding) + (req "origination_size" int31) + (req "block_security_deposit" Tez_repr.encoding) + (req "endorsement_security_deposit" Tez_repr.encoding) + (req "baking_reward_per_endorsement" (list Tez_repr.encoding))) + (obj9 + (req "endorsement_reward" (list Tez_repr.encoding)) + (req "cost_per_byte" Tez_repr.encoding) + (req "hard_storage_limit_per_operation" z) + (req "test_chain_duration" int64) + (req "quorum_min" int32) + (req "quorum_max" int32) + (req "min_proposal_quorum" int32) + (req "initial_endorsers" uint16) + (req "delay_per_missing_endorsement" Period_repr.encoding)))) + +type t = {fixed : fixed; parametric : parametric} + +let encoding = + let open Data_encoding in + conv + (fun {fixed; parametric} -> (fixed, parametric)) + (fun (fixed, parametric) -> {fixed; parametric}) + (merge_objs fixed_encoding parametric_encoding) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/constants_services.ml b/src/proto_008_PtEdo2Zk/lib_protocol/constants_services.ml new file mode 100644 index 0000000000000000000000000000000000000000..f2b92f91c18d3c1de6f40df91b1856caaccbae78 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/constants_services.ml @@ -0,0 +1,60 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +let custom_root = + ( RPC_path.(open_root / "context" / "constants") + : RPC_context.t RPC_path.context ) + +module S = struct + open Data_encoding + + let errors = + RPC_service.get_service + ~description:"Schema for all the RPC errors from this protocol version" + ~query:RPC_query.empty + ~output:json_schema + RPC_path.(custom_root / "errors") + + let all = + RPC_service.get_service + ~description:"All constants" + ~query:RPC_query.empty + ~output:Alpha_context.Constants.encoding + custom_root +end + +let register () = + let open Services_registration in + register0_noctxt S.errors (fun () () -> + return Data_encoding.Json.(schema error_encoding)) ; + register0 S.all (fun ctxt () () -> + let open Constants in + return {fixed; parametric = parametric ctxt}) + +let errors ctxt block = RPC_context.make_call0 S.errors ctxt block () () + +let all ctxt block = RPC_context.make_call0 S.all ctxt block () () diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/constants_services.mli b/src/proto_008_PtEdo2Zk/lib_protocol/constants_services.mli new file mode 100644 index 0000000000000000000000000000000000000000..243adcb1d384affd169f19ce3a897f19daac8ce8 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/constants_services.mli @@ -0,0 +1,36 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +val errors : + 'a #RPC_context.simple -> + 'a -> + Data_encoding.json_schema shell_tzresult Lwt.t + +(** Returns all the constants of the protocol *) +val all : 'a #RPC_context.simple -> 'a -> Constants.t shell_tzresult Lwt.t + +val register : unit -> unit diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/constants_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/constants_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..65a1cc81dc620d94a039e81b416f85178b1afa0b --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/constants_storage.ml @@ -0,0 +1,130 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let preserved_cycles c = + let constants = Raw_context.constants c in + constants.preserved_cycles + +let blocks_per_cycle c = + let constants = Raw_context.constants c in + constants.blocks_per_cycle + +let blocks_per_commitment c = + let constants = Raw_context.constants c in + constants.blocks_per_commitment + +let blocks_per_roll_snapshot c = + let constants = Raw_context.constants c in + constants.blocks_per_roll_snapshot + +let blocks_per_voting_period c = + let constants = Raw_context.constants c in + constants.blocks_per_voting_period + +let time_between_blocks c = + let constants = Raw_context.constants c in + constants.time_between_blocks + +let endorsers_per_block c = + let constants = Raw_context.constants c in + constants.endorsers_per_block + +let initial_endorsers c = + let constants = Raw_context.constants c in + constants.initial_endorsers + +let delay_per_missing_endorsement c = + let constants = Raw_context.constants c in + constants.delay_per_missing_endorsement + +let hard_gas_limit_per_operation c = + let constants = Raw_context.constants c in + constants.hard_gas_limit_per_operation + +let hard_gas_limit_per_block c = + let constants = Raw_context.constants c in + constants.hard_gas_limit_per_block + +let cost_per_byte c = + let constants = Raw_context.constants c in + constants.cost_per_byte + +let hard_storage_limit_per_operation c = + let constants = Raw_context.constants c in + constants.hard_storage_limit_per_operation + +let proof_of_work_threshold c = + let constants = Raw_context.constants c in + constants.proof_of_work_threshold + +let tokens_per_roll c = + let constants = Raw_context.constants c in + constants.tokens_per_roll + +let michelson_maximum_type_size c = + let constants = Raw_context.constants c in + constants.michelson_maximum_type_size + +let seed_nonce_revelation_tip c = + let constants = Raw_context.constants c in + constants.seed_nonce_revelation_tip + +let origination_size c = + let constants = Raw_context.constants c in + constants.origination_size + +let block_security_deposit c = + let constants = Raw_context.constants c in + constants.block_security_deposit + +let endorsement_security_deposit c = + let constants = Raw_context.constants c in + constants.endorsement_security_deposit + +let baking_reward_per_endorsement c = + let constants = Raw_context.constants c in + constants.baking_reward_per_endorsement + +let endorsement_reward c = + let constants = Raw_context.constants c in + constants.endorsement_reward + +let test_chain_duration c = + let constants = Raw_context.constants c in + constants.test_chain_duration + +let quorum_min c = + let constants = Raw_context.constants c in + constants.quorum_min + +let quorum_max c = + let constants = Raw_context.constants c in + constants.quorum_max + +let min_proposal_quorum c = + let constants = Raw_context.constants c in + constants.min_proposal_quorum + +let parametric c = Raw_context.constants c diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/contract_hash.ml b/src/proto_008_PtEdo2Zk/lib_protocol/contract_hash.ml new file mode 100644 index 0000000000000000000000000000000000000000..40d94808d628f0f52fc9a83a4f77a566b841fc0f --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/contract_hash.ml @@ -0,0 +1,41 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* 20 *) +let contract_hash = "\002\090\121" (* KT1(36) *) + +include Blake2B.Make + (Base58) + (struct + let name = "Contract_hash" + + let title = "A contract ID" + + let b58check_prefix = contract_hash + + let size = Some 20 + end) + +let () = Base58.check_encoded_prefix b58check_encoding "KT1" 36 diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/contract_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/contract_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..1fd9d0c5d43ccceab5c24cb927979eff35435dbb --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/contract_repr.ml @@ -0,0 +1,230 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = + | Implicit of Signature.Public_key_hash.t + | Originated of Contract_hash.t + +include Compare.Make (struct + type nonrec t = t + + let compare l1 l2 = + match (l1, l2) with + | (Implicit pkh1, Implicit pkh2) -> + Signature.Public_key_hash.compare pkh1 pkh2 + | (Originated h1, Originated h2) -> + Contract_hash.compare h1 h2 + | (Implicit _, Originated _) -> + -1 + | (Originated _, Implicit _) -> + 1 +end) + +type contract = t + +type error += Invalid_contract_notation of string (* `Permanent *) + +let to_b58check = function + | Implicit pbk -> + Signature.Public_key_hash.to_b58check pbk + | Originated h -> + Contract_hash.to_b58check h + +let of_b58check s = + match Base58.decode s with + | Some (Ed25519.Public_key_hash.Data h) -> + ok (Implicit (Signature.Ed25519 h)) + | Some (Secp256k1.Public_key_hash.Data h) -> + ok (Implicit (Signature.Secp256k1 h)) + | Some (P256.Public_key_hash.Data h) -> + ok (Implicit (Signature.P256 h)) + | Some (Contract_hash.Data h) -> + ok (Originated h) + | _ -> + error (Invalid_contract_notation s) + +let pp ppf = function + | Implicit pbk -> + Signature.Public_key_hash.pp ppf pbk + | Originated h -> + Contract_hash.pp ppf h + +let pp_short ppf = function + | Implicit pbk -> + Signature.Public_key_hash.pp_short ppf pbk + | Originated h -> + Contract_hash.pp_short ppf h + +let encoding = + let open Data_encoding in + def + "contract_id" + ~title:"A contract handle" + ~description: + "A contract notation as given to an RPC or inside scripts. Can be a \ + base58 implicit contract hash or a base58 originated contract hash." + @@ splitted + ~binary: + (union + ~tag_size:`Uint8 + [ case + (Tag 0) + ~title:"Implicit" + Signature.Public_key_hash.encoding + (function Implicit k -> Some k | _ -> None) + (fun k -> Implicit k); + case + (Tag 1) + (Fixed.add_padding Contract_hash.encoding 1) + ~title:"Originated" + (function Originated k -> Some k | _ -> None) + (fun k -> Originated k) ]) + ~json: + (conv + to_b58check + (fun s -> + match of_b58check s with + | Ok s -> + s + | Error _ -> + Json.cannot_destruct "Invalid contract notation.") + string) + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"contract.invalid_contract_notation" + ~title:"Invalid contract notation" + ~pp:(fun ppf x -> Format.fprintf ppf "Invalid contract notation %S" x) + ~description: + "A malformed contract notation was given to an RPC or in a script." + (obj1 (req "notation" string)) + (function Invalid_contract_notation loc -> Some loc | _ -> None) + (fun loc -> Invalid_contract_notation loc) + +let implicit_contract id = Implicit id + +let is_implicit = function Implicit m -> Some m | Originated _ -> None + +let is_originated = function Implicit _ -> None | Originated h -> Some h + +type origination_nonce = { + operation_hash : Operation_hash.t; + origination_index : int32; +} + +let origination_nonce_encoding = + let open Data_encoding in + conv + (fun {operation_hash; origination_index} -> + (operation_hash, origination_index)) + (fun (operation_hash, origination_index) -> + {operation_hash; origination_index}) + @@ obj2 (req "operation" Operation_hash.encoding) (dft "index" int32 0l) + +let originated_contract nonce = + let data = + Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce + in + Originated (Contract_hash.hash_bytes [data]) + +let originated_contracts + ~since:{origination_index = first; operation_hash = first_hash} + ~until:( {origination_index = last; operation_hash = last_hash} as + origination_nonce ) = + assert (Operation_hash.equal first_hash last_hash) ; + let rec contracts acc origination_index = + if Compare.Int32.(origination_index < first) then acc + else + let origination_nonce = {origination_nonce with origination_index} in + let acc = originated_contract origination_nonce :: acc in + contracts acc (Int32.pred origination_index) + in + contracts [] (Int32.pred last) + +let initial_origination_nonce operation_hash = + {operation_hash; origination_index = 0l} + +let incr_origination_nonce nonce = + let origination_index = Int32.succ nonce.origination_index in + {nonce with origination_index} + +let rpc_arg = + let construct = to_b58check in + let destruct hash = + match of_b58check hash with + | Error _ -> + Error "Cannot parse contract id" + | Ok contract -> + Ok contract + in + RPC_arg.make + ~descr:"A contract identifier encoded in b58check." + ~name:"contract_id" + ~construct + ~destruct + () + +module Index = struct + type t = contract + + let path_length = 7 + + let to_path c l = + let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in + let (`Hex key) = Hex.of_bytes raw_key in + let (`Hex index_key) = Hex.of_bytes (Raw_hashes.blake2b raw_key) in + String.sub index_key 0 2 :: String.sub index_key 2 2 + :: String.sub index_key 4 2 :: String.sub index_key 6 2 + :: String.sub index_key 8 2 :: String.sub index_key 10 2 :: key :: l + + let of_path = function + | [] + | [_] + | [_; _] + | [_; _; _] + | [_; _; _; _] + | [_; _; _; _; _] + | [_; _; _; _; _; _] + | _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ -> + None + | [index1; index2; index3; index4; index5; index6; key] -> + let raw_key = Hex.to_bytes (`Hex key) in + let (`Hex index_key) = Hex.of_bytes (Raw_hashes.blake2b raw_key) in + assert (Compare.String.(String.sub index_key 0 2 = index1)) ; + assert (Compare.String.(String.sub index_key 2 2 = index2)) ; + assert (Compare.String.(String.sub index_key 4 2 = index3)) ; + assert (Compare.String.(String.sub index_key 6 2 = index4)) ; + assert (Compare.String.(String.sub index_key 8 2 = index5)) ; + assert (Compare.String.(String.sub index_key 10 2 = index6)) ; + Data_encoding.Binary.of_bytes encoding raw_key + + let rpc_arg = rpc_arg + + let encoding = encoding + + let compare = compare +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/contract_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/contract_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..53935e460bbb6e57453a45d5b8593319c4d4de0c --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/contract_repr.mli @@ -0,0 +1,80 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = private + | Implicit of Signature.Public_key_hash.t + | Originated of Contract_hash.t + +type contract = t + +include Compare.S with type t := contract + +(** {2 Implicit contracts} *) + +val implicit_contract : Signature.Public_key_hash.t -> contract + +val is_implicit : contract -> Signature.Public_key_hash.t option + +(** {2 Originated contracts} *) + +(** Originated contracts handles are crafted from the hash of the + operation that triggered their origination (and nothing else). + As a single operation can trigger several originations, the + corresponding handles are forged from a deterministic sequence of + nonces, initialized with the hash of the operation. *) +type origination_nonce + +val originated_contract : origination_nonce -> contract + +val originated_contracts : + since:origination_nonce -> until:origination_nonce -> contract list + +val initial_origination_nonce : Operation_hash.t -> origination_nonce + +val incr_origination_nonce : origination_nonce -> origination_nonce + +val is_originated : contract -> Contract_hash.t option + +(** {2 Human readable notation} *) + +type error += Invalid_contract_notation of string (* `Permanent *) + +val to_b58check : contract -> string + +val of_b58check : string -> contract tzresult + +val pp : Format.formatter -> contract -> unit + +val pp_short : Format.formatter -> contract -> unit + +(** {2 Serializers} *) + +val encoding : contract Data_encoding.t + +val origination_nonce_encoding : origination_nonce Data_encoding.t + +val rpc_arg : contract RPC_arg.arg + +module Index : Storage_description.INDEX with type t = t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/contract_services.ml b/src/proto_008_PtEdo2Zk/lib_protocol/contract_services.ml new file mode 100644 index 0000000000000000000000000000000000000000..ff47b435be859cc66584503a43ba2c2f57eb4109 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/contract_services.ml @@ -0,0 +1,462 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +let custom_root = + ( RPC_path.(open_root / "context" / "contracts") + : RPC_context.t RPC_path.context ) + +let big_map_root = + ( RPC_path.(open_root / "context" / "big_maps") + : RPC_context.t RPC_path.context ) + +type info = { + balance : Tez.t; + delegate : public_key_hash option; + counter : counter option; + script : Script.t option; +} + +let info_encoding = + let open Data_encoding in + conv + (fun {balance; delegate; script; counter} -> + (balance, delegate, script, counter)) + (fun (balance, delegate, script, counter) -> + {balance; delegate; script; counter}) + @@ obj4 + (req "balance" Tez.encoding) + (opt "delegate" Signature.Public_key_hash.encoding) + (opt "script" Script.encoding) + (opt "counter" n) + +module S = struct + open Data_encoding + + let balance = + RPC_service.get_service + ~description:"Access the balance of a contract." + ~query:RPC_query.empty + ~output:Tez.encoding + RPC_path.(custom_root /: Contract.rpc_arg / "balance") + + let manager_key = + RPC_service.get_service + ~description:"Access the manager of a contract." + ~query:RPC_query.empty + ~output:(option Signature.Public_key.encoding) + RPC_path.(custom_root /: Contract.rpc_arg / "manager_key") + + let delegate = + RPC_service.get_service + ~description:"Access the delegate of a contract, if any." + ~query:RPC_query.empty + ~output:Signature.Public_key_hash.encoding + RPC_path.(custom_root /: Contract.rpc_arg / "delegate") + + let counter = + RPC_service.get_service + ~description:"Access the counter of a contract, if any." + ~query:RPC_query.empty + ~output:z + RPC_path.(custom_root /: Contract.rpc_arg / "counter") + + let script = + RPC_service.get_service + ~description:"Access the code and data of the contract." + ~query:RPC_query.empty + ~output:Script.encoding + RPC_path.(custom_root /: Contract.rpc_arg / "script") + + let storage = + RPC_service.get_service + ~description:"Access the data of the contract." + ~query:RPC_query.empty + ~output:Script.expr_encoding + RPC_path.(custom_root /: Contract.rpc_arg / "storage") + + let entrypoint_type = + RPC_service.get_service + ~description:"Return the type of the given entrypoint of the contract" + ~query:RPC_query.empty + ~output:Script.expr_encoding + RPC_path.( + custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string) + + let list_entrypoints = + RPC_service.get_service + ~description:"Return the list of entrypoints of the contract" + ~query:RPC_query.empty + ~output: + (obj2 + (dft + "unreachable" + (Data_encoding.list + (obj1 + (req + "path" + (Data_encoding.list + Michelson_v1_primitives.prim_encoding)))) + []) + (req "entrypoints" (assoc Script.expr_encoding))) + RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints") + + let contract_big_map_get_opt = + RPC_service.post_service + ~description: + "Access the value associated with a key in a big map of the contract \ + (deprecated)." + ~query:RPC_query.empty + ~input: + (obj2 + (req "key" Script.expr_encoding) + (req "type" Script.expr_encoding)) + ~output:(option Script.expr_encoding) + RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get") + + let big_map_get = + RPC_service.get_service + ~description:"Access the value associated with a key in a big map." + ~query:RPC_query.empty + ~output:Script.expr_encoding + RPC_path.(big_map_root /: Big_map.Id.rpc_arg /: Script_expr_hash.rpc_arg) + + let info = + RPC_service.get_service + ~description:"Access the complete status of a contract." + ~query:RPC_query.empty + ~output:info_encoding + RPC_path.(custom_root /: Contract.rpc_arg) + + let list = + RPC_service.get_service + ~description: + "All existing contracts (including non-empty default contracts)." + ~query:RPC_query.empty + ~output:(list Contract.encoding) + custom_root + + module Sapling = struct + (* + Sapling: these RPCs are like Sapling RPCs (sapling_services.ml) + specialized for contracts containing a single sapling state. + *) + + let single_sapling_get_id ctxt contract_id = + Contract.get_script ctxt contract_id + >>=? fun (ctxt, script) -> + match script with + | None -> + raise Not_found + | Some script -> + let ctxt = Gas.set_unlimited ctxt in + Script_ir_translator.parse_script + ctxt + ~legacy:true + ~allow_forged_in_storage:true + script + >|= fun tzresult -> + tzresult + >>? fun (Ex_script script, ctxt) -> + Script_ir_translator.get_single_sapling_state + ctxt + script.storage_type + script.storage + + let make_service + Sapling_services.S.Args.{name; description; query; output; f} = + let name = "single_sapling_" ^ name in + let path = RPC_path.(custom_root /: Contract.rpc_arg / name) in + let service = RPC_service.get_service ~description ~query ~output path in + ( service, + fun ctxt contract_id q () -> + single_sapling_get_id ctxt contract_id + >>=? fun (sapling_id, ctxt) -> f ctxt sapling_id q ) + + let get_diff = make_service Sapling_services.S.Args.get_diff + + let register () = + let reg (service, f) = Services_registration.register1 service f in + reg get_diff + + let mk_call1 (service, _f) ctxt block id q = + RPC_context.make_call1 service ctxt block id q () + end +end + +let register () = + let open Services_registration in + register0 S.list (fun ctxt () () -> Contract.list ctxt >|= ok) ; + let register_field s f = + register1 s (fun ctxt contract () () -> + Contract.exists ctxt contract + >>=? function true -> f ctxt contract | false -> raise Not_found) + in + let register_opt_field s f = + register_field s (fun ctxt a1 -> + f ctxt a1 >|=? function None -> raise Not_found | Some v -> v) + in + let do_big_map_get ctxt id key = + let open Script_ir_translator in + let ctxt = Gas.set_unlimited ctxt in + Big_map.exists ctxt id + >>=? fun (ctxt, types) -> + match types with + | None -> + raise Not_found + | Some (_, value_type) -> ( + parse_big_map_value_ty ctxt ~legacy:true (Micheline.root value_type) + >>?= fun (Ex_ty value_type, ctxt) -> + Big_map.get_opt ctxt id key + >>=? fun (_ctxt, value) -> + match value with + | None -> + raise Not_found + | Some value -> + parse_data + ctxt + ~legacy:true + ~allow_forged:true + value_type + (Micheline.root value) + >>=? fun (value, ctxt) -> + unparse_data ctxt Readable value_type value + >|=? fun (value, _ctxt) -> Micheline.strip_locations value ) + in + register_field S.balance Contract.get_balance ; + register1 S.manager_key (fun ctxt contract () () -> + match Contract.is_implicit contract with + | None -> + raise Not_found + | Some mgr -> ( + Contract.is_manager_key_revealed ctxt mgr + >>=? function + | false -> + return_none + | true -> + Contract.get_manager_key ctxt mgr >>=? return_some )) ; + register_opt_field S.delegate Delegate.get ; + register1 S.counter (fun ctxt contract () () -> + match Contract.is_implicit contract with + | None -> + raise Not_found + | Some mgr -> + Contract.get_counter ctxt mgr) ; + register_opt_field S.script (fun c v -> + Contract.get_script c v >|=? fun (_, v) -> v) ; + register_opt_field S.storage (fun ctxt contract -> + Contract.get_script ctxt contract + >>=? fun (ctxt, script) -> + match script with + | None -> + return_none + | Some script -> + let ctxt = Gas.set_unlimited ctxt in + let open Script_ir_translator in + parse_script ctxt ~legacy:true ~allow_forged_in_storage:true script + >>=? fun (Ex_script script, ctxt) -> + unparse_script ctxt Readable script + >>=? fun (script, ctxt) -> + Script.force_decode_in_context ctxt script.storage + >>?= fun (storage, _ctxt) -> return_some storage) ; + register2 S.entrypoint_type (fun ctxt v entrypoint () () -> + Contract.get_script_code ctxt v + >>=? fun (_, expr) -> + match expr with + | None -> + raise Not_found + | Some expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = true in + let open Script_ir_translator in + Lwt.return + ( Script.force_decode_in_context ctxt expr + >>? fun (expr, _) -> + parse_toplevel ~legacy expr + >>? (fun (arg_type, _, _, root_name) -> + parse_parameter_ty ctxt ~legacy arg_type + >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.find_entrypoint + ~root_name + arg_type + entrypoint) + |> function + | Ok (_f, Ex_ty ty) -> + unparse_ty ctxt ty + >|? fun (ty_node, _) -> Micheline.strip_locations ty_node + | Error _ -> + raise Not_found )) ; + register1 S.list_entrypoints (fun ctxt v () () -> + Contract.get_script_code ctxt v + >>=? fun (_, expr) -> + match expr with + | None -> + raise Not_found + | Some expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = true in + let open Script_ir_translator in + Lwt.return + ( Script.force_decode_in_context ctxt expr + >>? fun (expr, _) -> + parse_toplevel ~legacy expr + >>? (fun (arg_type, _, _, root_name) -> + parse_parameter_ty ctxt ~legacy arg_type + >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.list_entrypoints + ~root_name + arg_type + ctxt) + >|? fun (unreachable_entrypoint, map) -> + ( unreachable_entrypoint, + Entrypoints_map.fold + (fun entry (_, ty) acc -> + (entry, Micheline.strip_locations ty) :: acc) + map + [] ) )) ; + register1 S.contract_big_map_get_opt (fun ctxt contract () (key, key_type) -> + Contract.get_script ctxt contract + >>=? fun (ctxt, script) -> + Script_ir_translator.parse_comparable_ty ctxt (Micheline.root key_type) + >>?= fun (Ex_comparable_ty key_type, ctxt) -> + Script_ir_translator.parse_comparable_data + ctxt + key_type + (Micheline.root key) + >>=? fun (key, ctxt) -> + Script_ir_translator.hash_comparable_data ctxt key_type key + >>=? fun (key, ctxt) -> + match script with + | None -> + raise Not_found + | Some script -> ( + let ctxt = Gas.set_unlimited ctxt in + let open Script_ir_translator in + parse_script ctxt ~legacy:true ~allow_forged_in_storage:true script + >>=? fun (Ex_script script, ctxt) -> + Script_ir_translator.collect_lazy_storage + ctxt + script.storage_type + script.storage + >>?= fun (ids, _ctxt) -> + match Script_ir_translator.list_of_big_map_ids ids with + | [] | _ :: _ :: _ -> + return_none + | [id] -> ( + try do_big_map_get ctxt id key >>=? return_some + with Not_found -> return_none ) )) ; + register2 S.big_map_get (fun ctxt id key () () -> do_big_map_get ctxt id key) ; + register_field S.info (fun ctxt contract -> + Contract.get_balance ctxt contract + >>=? fun balance -> + Delegate.get ctxt contract + >>=? fun delegate -> + ( match Contract.is_implicit contract with + | Some manager -> + Contract.get_counter ctxt manager + >>=? fun counter -> return_some counter + | None -> + return_none ) + >>=? fun counter -> + Contract.get_script ctxt contract + >>=? fun (ctxt, script) -> + ( match script with + | None -> + return (None, ctxt) + | Some script -> + let ctxt = Gas.set_unlimited ctxt in + let open Script_ir_translator in + parse_script ctxt ~legacy:true ~allow_forged_in_storage:true script + >>=? fun (Ex_script script, ctxt) -> + unparse_script ctxt Readable script + >|=? fun (script, ctxt) -> (Some script, ctxt) ) + >|=? fun (script, _ctxt) -> {balance; delegate; script; counter}) ; + S.Sapling.register () + +let list ctxt block = RPC_context.make_call0 S.list ctxt block () () + +let info ctxt block contract = + RPC_context.make_call1 S.info ctxt block contract () () + +let balance ctxt block contract = + RPC_context.make_call1 S.balance ctxt block contract () () + +let manager_key ctxt block mgr = + RPC_context.make_call1 + S.manager_key + ctxt + block + (Contract.implicit_contract mgr) + () + () + +let delegate ctxt block contract = + RPC_context.make_call1 S.delegate ctxt block contract () () + +let delegate_opt ctxt block contract = + RPC_context.make_opt_call1 S.delegate ctxt block contract () () + +let counter ctxt block mgr = + RPC_context.make_call1 + S.counter + ctxt + block + (Contract.implicit_contract mgr) + () + () + +let script ctxt block contract = + RPC_context.make_call1 S.script ctxt block contract () () + +let script_opt ctxt block contract = + RPC_context.make_opt_call1 S.script ctxt block contract () () + +let storage ctxt block contract = + RPC_context.make_call1 S.storage ctxt block contract () () + +let entrypoint_type ctxt block contract entrypoint = + RPC_context.make_call2 S.entrypoint_type ctxt block contract entrypoint () () + +let list_entrypoints ctxt block contract = + RPC_context.make_call1 S.list_entrypoints ctxt block contract () () + +let storage_opt ctxt block contract = + RPC_context.make_opt_call1 S.storage ctxt block contract () () + +let big_map_get ctxt block id key = + RPC_context.make_call2 S.big_map_get ctxt block id key () () + +let contract_big_map_get_opt ctxt block contract key = + RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract () key + +let single_sapling_get_diff ctxt block id ?offset_commitment ?offset_nullifier + () = + S.Sapling.(mk_call1 get_diff) + ctxt + block + id + Sapling_services.{offset_commitment; offset_nullifier} diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/contract_services.mli b/src/proto_008_PtEdo2Zk/lib_protocol/contract_services.mli new file mode 100644 index 0000000000000000000000000000000000000000..db0285932a50a513644ace241390265a644a8f1d --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/contract_services.mli @@ -0,0 +1,129 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +val list : 'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t + +type info = { + balance : Tez.t; + delegate : public_key_hash option; + counter : counter option; + script : Script.t option; +} + +val info_encoding : info Data_encoding.t + +val info : + 'a #RPC_context.simple -> 'a -> Contract.t -> info shell_tzresult Lwt.t + +val balance : + 'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t + +val manager_key : + 'a #RPC_context.simple -> + 'a -> + public_key_hash -> + public_key option shell_tzresult Lwt.t + +val delegate : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + public_key_hash shell_tzresult Lwt.t + +val delegate_opt : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + public_key_hash option shell_tzresult Lwt.t + +val counter : + 'a #RPC_context.simple -> + 'a -> + public_key_hash -> + counter shell_tzresult Lwt.t + +val script : + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t + +val script_opt : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + Script.t option shell_tzresult Lwt.t + +val storage : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + Script.expr shell_tzresult Lwt.t + +val entrypoint_type : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + string -> + Script.expr shell_tzresult Lwt.t + +val list_entrypoints : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + (Michelson_v1_primitives.prim list list * (string * Script.expr) list) + shell_tzresult + Lwt.t + +val storage_opt : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + Script.expr option shell_tzresult Lwt.t + +val big_map_get : + 'a #RPC_context.simple -> + 'a -> + Big_map.Id.t -> + Script_expr_hash.t -> + Script.expr shell_tzresult Lwt.t + +val contract_big_map_get_opt : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + Script.expr * Script.expr -> + Script.expr option shell_tzresult Lwt.t + +val single_sapling_get_diff : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + ?offset_commitment:int64 -> + ?offset_nullifier:int64 -> + unit -> + (Sapling.root * Sapling.diff) shell_tzresult Lwt.t + +val register : unit -> unit diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/contract_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/contract_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..f728f8e2aa0af1456127b656ae3e29358eaef6d8 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/contract_storage.ml @@ -0,0 +1,818 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += + | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t + | (* `Temporary *) + Counter_in_the_past of Contract_repr.contract * Z.t * Z.t + | (* `Branch *) + Counter_in_the_future of Contract_repr.contract * Z.t * Z.t + | (* `Temporary *) + Unspendable_contract of Contract_repr.contract + | (* `Permanent *) + Non_existing_contract of Contract_repr.contract + | (* `Temporary *) + Empty_implicit_contract of Signature.Public_key_hash.t + | (* `Temporary *) + Empty_implicit_delegated_contract of + Signature.Public_key_hash.t + | (* `Temporary *) + Empty_transaction of Contract_repr.t (* `Temporary *) + | Inconsistent_hash of + Signature.Public_key.t + * Signature.Public_key_hash.t + * Signature.Public_key_hash.t + | (* `Permanent *) + Inconsistent_public_key of + Signature.Public_key.t * Signature.Public_key.t + | (* `Permanent *) + Failure of string (* `Permanent *) + | Previously_revealed_key of Contract_repr.t (* `Permanent *) + | Unrevealed_manager_key of Contract_repr.t + +(* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"contract.unspendable_contract" + ~title:"Unspendable contract" + ~description: + "An operation tried to spend tokens from an unspendable contract" + ~pp:(fun ppf c -> + Format.fprintf + ppf + "The tokens of contract %a can only be spent by its script" + Contract_repr.pp + c) + Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) + (function Unspendable_contract c -> Some c | _ -> None) + (fun c -> Unspendable_contract c) ; + register_error_kind + `Temporary + ~id:"contract.balance_too_low" + ~title:"Balance too low" + ~description: + "An operation tried to spend more tokens than the contract has" + ~pp:(fun ppf (c, b, a) -> + Format.fprintf + ppf + "Balance of contract %a too low (%a) to spend %a" + Contract_repr.pp + c + Tez_repr.pp + b + Tez_repr.pp + a) + Data_encoding.( + obj3 + (req "contract" Contract_repr.encoding) + (req "balance" Tez_repr.encoding) + (req "amount" Tez_repr.encoding)) + (function Balance_too_low (c, b, a) -> Some (c, b, a) | _ -> None) + (fun (c, b, a) -> Balance_too_low (c, b, a)) ; + register_error_kind + `Temporary + ~id:"contract.counter_in_the_future" + ~title:"Invalid counter (not yet reached) in a manager operation" + ~description:"An operation assumed a contract counter in the future" + ~pp:(fun ppf (contract, exp, found) -> + Format.fprintf + ppf + "Counter %a not yet reached for contract %a (expected %a)" + Z.pp_print + found + Contract_repr.pp + contract + Z.pp_print + exp) + Data_encoding.( + obj3 + (req "contract" Contract_repr.encoding) + (req "expected" z) + (req "found" z)) + (function Counter_in_the_future (c, x, y) -> Some (c, x, y) | _ -> None) + (fun (c, x, y) -> Counter_in_the_future (c, x, y)) ; + register_error_kind + `Branch + ~id:"contract.counter_in_the_past" + ~title:"Invalid counter (already used) in a manager operation" + ~description:"An operation assumed a contract counter in the past" + ~pp:(fun ppf (contract, exp, found) -> + Format.fprintf + ppf + "Counter %a already used for contract %a (expected %a)" + Z.pp_print + found + Contract_repr.pp + contract + Z.pp_print + exp) + Data_encoding.( + obj3 + (req "contract" Contract_repr.encoding) + (req "expected" z) + (req "found" z)) + (function Counter_in_the_past (c, x, y) -> Some (c, x, y) | _ -> None) + (fun (c, x, y) -> Counter_in_the_past (c, x, y)) ; + register_error_kind + `Temporary + ~id:"contract.non_existing_contract" + ~title:"Non existing contract" + ~description: + "A contract handle is not present in the context (either it never was \ + or it has been destroyed)" + ~pp:(fun ppf contract -> + Format.fprintf ppf "Contract %a does not exist" Contract_repr.pp contract) + Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) + (function Non_existing_contract c -> Some c | _ -> None) + (fun c -> Non_existing_contract c) ; + register_error_kind + `Permanent + ~id:"contract.manager.inconsistent_hash" + ~title:"Inconsistent public key hash" + ~description: + "A revealed manager public key is inconsistent with the announced hash" + ~pp:(fun ppf (k, eh, ph) -> + Format.fprintf + ppf + "The hash of the manager public key %s is not %a as announced but %a" + (Signature.Public_key.to_b58check k) + Signature.Public_key_hash.pp + ph + Signature.Public_key_hash.pp + eh) + Data_encoding.( + obj3 + (req "public_key" Signature.Public_key.encoding) + (req "expected_hash" Signature.Public_key_hash.encoding) + (req "provided_hash" Signature.Public_key_hash.encoding)) + (function Inconsistent_hash (k, eh, ph) -> Some (k, eh, ph) | _ -> None) + (fun (k, eh, ph) -> Inconsistent_hash (k, eh, ph)) ; + register_error_kind + `Permanent + ~id:"contract.manager.inconsistent_public_key" + ~title:"Inconsistent public key" + ~description: + "A provided manager public key is different with the public key stored \ + in the contract" + ~pp:(fun ppf (eh, ph) -> + Format.fprintf + ppf + "Expected manager public key %s but %s was provided" + (Signature.Public_key.to_b58check ph) + (Signature.Public_key.to_b58check eh)) + Data_encoding.( + obj2 + (req "public_key" Signature.Public_key.encoding) + (req "expected_public_key" Signature.Public_key.encoding)) + (function Inconsistent_public_key (eh, ph) -> Some (eh, ph) | _ -> None) + (fun (eh, ph) -> Inconsistent_public_key (eh, ph)) ; + register_error_kind + `Permanent + ~id:"contract.failure" + ~title:"Contract storage failure" + ~description:"Unexpected contract storage error" + ~pp:(fun ppf s -> Format.fprintf ppf "Contract_storage.Failure %S" s) + Data_encoding.(obj1 (req "message" string)) + (function Failure s -> Some s | _ -> None) + (fun s -> Failure s) ; + register_error_kind + `Branch + ~id:"contract.unrevealed_key" + ~title:"Manager operation precedes key revelation" + ~description: + "One tried to apply a manager operation without revealing the manager \ + public key" + ~pp:(fun ppf s -> + Format.fprintf + ppf + "Unrevealed manager key for contract %a." + Contract_repr.pp + s) + Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) + (function Unrevealed_manager_key s -> Some s | _ -> None) + (fun s -> Unrevealed_manager_key s) ; + register_error_kind + `Branch + ~id:"contract.previously_revealed_key" + ~title:"Manager operation already revealed" + ~description:"One tried to revealed twice a manager public key" + ~pp:(fun ppf s -> + Format.fprintf + ppf + "Previously revealed manager key for contract %a." + Contract_repr.pp + s) + Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) + (function Previously_revealed_key s -> Some s | _ -> None) + (fun s -> Previously_revealed_key s) ; + register_error_kind + `Branch + ~id:"implicit.empty_implicit_contract" + ~title:"Empty implicit contract" + ~description: + "No manager operations are allowed on an empty implicit contract." + ~pp:(fun ppf implicit -> + Format.fprintf + ppf + "Empty implicit contract (%a)" + Signature.Public_key_hash.pp + implicit) + Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding)) + (function Empty_implicit_contract c -> Some c | _ -> None) + (fun c -> Empty_implicit_contract c) ; + register_error_kind + `Branch + ~id:"implicit.empty_implicit_delegated_contract" + ~title:"Empty implicit delegated contract" + ~description:"Emptying an implicit delegated account is not allowed." + ~pp:(fun ppf implicit -> + Format.fprintf + ppf + "Emptying implicit delegated contract (%a)" + Signature.Public_key_hash.pp + implicit) + Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding)) + (function Empty_implicit_delegated_contract c -> Some c | _ -> None) + (fun c -> Empty_implicit_delegated_contract c) ; + register_error_kind + `Branch + ~id:"contract.empty_transaction" + ~title:"Empty transaction" + ~description:"Forbidden to credit 0ꜩ to a contract without code." + ~pp:(fun ppf contract -> + Format.fprintf + ppf + "Transaction of 0ꜩ towards a contract without code are forbidden \ + (%a)." + Contract_repr.pp + contract) + Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) + (function Empty_transaction c -> Some c | _ -> None) + (fun c -> Empty_transaction c) + +let failwith msg = fail (Failure msg) + +module Legacy_big_map_diff = struct + (* + Big_map_diff receipt as it was represented in 006 and earlier. + It is kept here for now for backward compatibility of tools. *) + + type item = + | Update of { + big_map : Z.t; + diff_key : Script_repr.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script_repr.expr option; + } + | Clear of Z.t + | Copy of {src : Z.t; dst : Z.t} + | Alloc of { + big_map : Z.t; + key_type : Script_repr.expr; + value_type : Script_repr.expr; + } + + type t = item list + + let item_encoding = + let open Data_encoding in + union + [ case + (Tag 0) + ~title:"update" + (obj5 + (req "action" (constant "update")) + (req "big_map" z) + (req "key_hash" Script_expr_hash.encoding) + (req "key" Script_repr.expr_encoding) + (opt "value" Script_repr.expr_encoding)) + (function + | Update {big_map; diff_key_hash; diff_key; diff_value} -> + Some ((), big_map, diff_key_hash, diff_key, diff_value) + | _ -> + None) + (fun ((), big_map, diff_key_hash, diff_key, diff_value) -> + Update {big_map; diff_key_hash; diff_key; diff_value}); + case + (Tag 1) + ~title:"remove" + (obj2 (req "action" (constant "remove")) (req "big_map" z)) + (function Clear big_map -> Some ((), big_map) | _ -> None) + (fun ((), big_map) -> Clear big_map); + case + (Tag 2) + ~title:"copy" + (obj3 + (req "action" (constant "copy")) + (req "source_big_map" z) + (req "destination_big_map" z)) + (function Copy {src; dst} -> Some ((), src, dst) | _ -> None) + (fun ((), src, dst) -> Copy {src; dst}); + case + (Tag 3) + ~title:"alloc" + (obj4 + (req "action" (constant "alloc")) + (req "big_map" z) + (req "key_type" Script_repr.expr_encoding) + (req "value_type" Script_repr.expr_encoding)) + (function + | Alloc {big_map; key_type; value_type} -> + Some ((), big_map, key_type, value_type) + | _ -> + None) + (fun ((), big_map, key_type, value_type) -> + Alloc {big_map; key_type; value_type}) ] + + let encoding = Data_encoding.list item_encoding + + let to_lazy_storage_diff legacy_diffs = + let rev_head (diffs : (_ * (_, _, _) Lazy_storage_diff.diff) list) = + match diffs with + | [] -> + [] + | (_, Remove) :: _ -> + diffs + | (id, Update {init; updates}) :: rest -> + (id, Update {init; updates = List.rev updates}) :: rest + in + (* Invariant: + Updates are collected one by one, in reverse order, on the head diff + item. So only and exactly the head diff item has its updates reversed. + *) + List.fold_left + (fun (new_diff : (_ * (_, _, _) Lazy_storage_diff.diff) list) item -> + match item with + | Clear id -> + (id, Lazy_storage_diff.Remove) :: rev_head new_diff + | Copy {src; dst} -> + let src = + Lazy_storage_kind.Big_map.Id + .of_legacy_USE_ONLY_IN_Legacy_big_map_diff + src + in + (dst, Lazy_storage_diff.Update {init = Copy {src}; updates = []}) + :: rev_head new_diff + | Alloc {big_map; key_type; value_type} -> + ( big_map, + Lazy_storage_diff.( + Update + { + init = + Alloc Lazy_storage_kind.Big_map.{key_type; value_type}; + updates = []; + }) ) + :: rev_head new_diff + | Update + { big_map; + diff_key = key; + diff_key_hash = key_hash; + diff_value = value } -> ( + match new_diff with + | (id, diff) :: rest when Compare.Z.(id = big_map) -> + let diff = + match diff with + | Remove -> + assert false + | Update {init; updates} -> + let updates = + Lazy_storage_kind.Big_map.{key; key_hash; value} + :: updates + in + Lazy_storage_diff.Update {init; updates} + in + (id, diff) :: rest + | new_diff -> + let updates = + [Lazy_storage_kind.Big_map.{key; key_hash; value}] + in + (big_map, Update {init = Existing; updates}) :: rev_head new_diff + )) + [] + legacy_diffs + |> rev_head + |> List.rev_map (fun (id, diff) -> + let id = + Lazy_storage_kind.Big_map.Id + .of_legacy_USE_ONLY_IN_Legacy_big_map_diff + id + in + Lazy_storage_diff.make Lazy_storage_kind.Big_map id diff) + + let of_lazy_storage_diff diffs = + List.fold_left + (fun legacy_diffs (Lazy_storage_diff.Item (kind, id, diff)) -> + let diffs = + match kind with + | Lazy_storage_kind.Big_map -> ( + let id = + Lazy_storage_kind.Big_map.Id + .to_legacy_USE_ONLY_IN_Legacy_big_map_diff + id + in + match diff with + | Remove -> + [Clear id] + | Update {init; updates} -> ( + let updates = + List.rev_map + (fun {Lazy_storage_kind.Big_map.key; key_hash; value} -> + Update + { + big_map = id; + diff_key = key; + diff_key_hash = key_hash; + diff_value = value; + }) + updates + in + match init with + | Existing -> + updates + | Copy {src} -> + let src = + Lazy_storage_kind.Big_map.Id + .to_legacy_USE_ONLY_IN_Legacy_big_map_diff + src + in + Copy {src; dst = id} :: updates + | Alloc {key_type; value_type} -> + Alloc {big_map = id; key_type; value_type} :: updates ) ) + | _ -> + (* Not a Big_map *) [] + in + diffs :: legacy_diffs) + [] + diffs + |> List.rev |> List.flatten + [@@coq_axiom "gadt"] +end + +let update_script_lazy_storage c = function + | None -> + return (c, Z.zero) + | Some diffs -> + Lazy_storage_diff.apply c diffs + +let create_base c ?(prepaid_bootstrap_storage = false) + (* Free space for bootstrap contracts *) + contract ~balance ~manager ~delegate ?script () = + ( match Contract_repr.is_implicit contract with + | None -> + return c + | Some _ -> + Storage.Contract.Global_counter.get c + >>=? fun counter -> Storage.Contract.Counter.init c contract counter ) + >>=? fun c -> + Storage.Contract.Balance.init c contract balance + >>=? fun c -> + ( match manager with + | Some manager -> + Storage.Contract.Manager.init c contract (Manager_repr.Hash manager) + | None -> + return c ) + >>=? fun c -> + ( match delegate with + | None -> + return c + | Some delegate -> + Delegate_storage.init c contract delegate ) + >>=? fun c -> + match script with + | Some ({Script_repr.code; storage}, lazy_storage_diff) -> + Storage.Contract.Code.init c contract code + >>=? fun (c, code_size) -> + Storage.Contract.Storage.init c contract storage + >>=? fun (c, storage_size) -> + update_script_lazy_storage c lazy_storage_diff + >>=? fun (c, lazy_storage_size) -> + let total_size = + Z.add + (Z.add (Z.of_int code_size) (Z.of_int storage_size)) + lazy_storage_size + in + assert (Compare.Z.(total_size >= Z.zero)) ; + let prepaid_bootstrap_storage = + if prepaid_bootstrap_storage then total_size else Z.zero + in + Storage.Contract.Paid_storage_space.init + c + contract + prepaid_bootstrap_storage + >>=? fun c -> + Storage.Contract.Used_storage_space.init c contract total_size + | None -> + return c + +let raw_originate c ?prepaid_bootstrap_storage contract ~balance ~script + ~delegate = + create_base + c + ?prepaid_bootstrap_storage + contract + ~balance + ~manager:None + ~delegate + ~script + () + +let create_implicit c manager ~balance = + create_base + c + (Contract_repr.implicit_contract manager) + ~balance + ~manager:(Some manager) + ?script:None + ~delegate:None + () + +let delete c contract = + match Contract_repr.is_implicit contract with + | None -> + (* For non implicit contract Big_map should be cleared *) + failwith "Non implicit contracts cannot be removed" + | Some _ -> + Delegate_storage.remove c contract + >>=? fun c -> + Storage.Contract.Balance.delete c contract + >>=? fun c -> + Storage.Contract.Manager.delete c contract + >>=? fun c -> + Storage.Contract.Counter.delete c contract + >>=? fun c -> + Storage.Contract.Code.remove c contract + >>=? fun (c, _, _) -> + Storage.Contract.Storage.remove c contract + >>=? fun (c, _, _) -> + Storage.Contract.Paid_storage_space.remove c contract + >>= fun c -> Storage.Contract.Used_storage_space.remove c contract >|= ok + +let allocated c contract = + Storage.Contract.Balance.get_option c contract + >>=? function None -> return_false | Some _ -> return_true + +let exists c contract = + match Contract_repr.is_implicit contract with + | Some _ -> + return_true + | None -> + allocated c contract + +let must_exist c contract = + exists c contract + >>=? function + | true -> return_unit | false -> fail (Non_existing_contract contract) + +let must_be_allocated c contract = + allocated c contract + >>=? function + | true -> + return_unit + | false -> ( + match Contract_repr.is_implicit contract with + | Some pkh -> + fail (Empty_implicit_contract pkh) + | None -> + fail (Non_existing_contract contract) ) + +let list c = Storage.Contract.list c + +let fresh_contract_from_current_nonce c = + Raw_context.increment_origination_nonce c + >|? fun (c, nonce) -> (c, Contract_repr.originated_contract nonce) + +let originated_from_current_nonce ~since:ctxt_since ~until:ctxt_until = + Raw_context.origination_nonce ctxt_since + >>?= fun since -> + Raw_context.origination_nonce ctxt_until + >>?= fun until -> + filter_s + (fun contract -> exists ctxt_until contract) + (Contract_repr.originated_contracts ~since ~until) + +let check_counter_increment c manager counter = + let contract = Contract_repr.implicit_contract manager in + Storage.Contract.Counter.get c contract + >>=? fun contract_counter -> + let expected = Z.succ contract_counter in + if Compare.Z.(expected = counter) then return_unit + else if Compare.Z.(expected > counter) then + fail (Counter_in_the_past (contract, expected, counter)) + else fail (Counter_in_the_future (contract, expected, counter)) + +let increment_counter c manager = + let contract = Contract_repr.implicit_contract manager in + Storage.Contract.Global_counter.get c + >>=? fun global_counter -> + Storage.Contract.Global_counter.set c (Z.succ global_counter) + >>=? fun c -> + Storage.Contract.Counter.get c contract + >>=? fun contract_counter -> + Storage.Contract.Counter.set c contract (Z.succ contract_counter) + +let get_script_code c contract = Storage.Contract.Code.get_option c contract + +let get_script c contract = + Storage.Contract.Code.get_option c contract + >>=? fun (c, code) -> + Storage.Contract.Storage.get_option c contract + >>=? fun (c, storage) -> + match (code, storage) with + | (None, None) -> + return (c, None) + | (Some code, Some storage) -> + return (c, Some {Script_repr.code; storage}) + | (None, Some _) | (Some _, None) -> + failwith "get_script" + +let get_storage ctxt contract = + Storage.Contract.Storage.get_option ctxt contract + >>=? function + | (ctxt, None) -> + return (ctxt, None) + | (ctxt, Some storage) -> + Lwt.return (Script_repr.force_decode storage) + >>=? fun (storage, cost) -> + Lwt.return (Raw_context.consume_gas ctxt cost) + >>=? fun ctxt -> return (ctxt, Some storage) + +let get_counter c manager = + let contract = Contract_repr.implicit_contract manager in + Storage.Contract.Counter.get_option c contract + >>=? function + | None -> ( + match Contract_repr.is_implicit contract with + | Some _ -> + Storage.Contract.Global_counter.get c + | None -> + failwith "get_counter" ) + | Some v -> + return v + +let get_manager_key c manager = + let contract = Contract_repr.implicit_contract manager in + Storage.Contract.Manager.get_option c contract + >>=? function + | None -> + failwith "get_manager_key" + | Some (Manager_repr.Hash _) -> + fail (Unrevealed_manager_key contract) + | Some (Manager_repr.Public_key v) -> + return v + +let is_manager_key_revealed c manager = + let contract = Contract_repr.implicit_contract manager in + Storage.Contract.Manager.get_option c contract + >>=? function + | None -> + return_false + | Some (Manager_repr.Hash _) -> + return_false + | Some (Manager_repr.Public_key _) -> + return_true + +let reveal_manager_key c manager public_key = + let contract = Contract_repr.implicit_contract manager in + Storage.Contract.Manager.get c contract + >>=? function + | Public_key _ -> + fail (Previously_revealed_key contract) + | Hash v -> + let actual_hash = Signature.Public_key.hash public_key in + if Signature.Public_key_hash.equal actual_hash v then + let v = Manager_repr.Public_key public_key in + Storage.Contract.Manager.set c contract v + else fail (Inconsistent_hash (public_key, v, actual_hash)) + +let get_balance c contract = + Storage.Contract.Balance.get_option c contract + >>=? function + | None -> ( + match Contract_repr.is_implicit contract with + | Some _ -> + return Tez_repr.zero + | None -> + failwith "get_balance" ) + | Some v -> + return v + +let get_balance_carbonated c contract = + (* Reading an int64 from /contracts/pkh/balance + NB: this cost assumes a flattened storage structure. *) + Raw_context.consume_gas + c + (Storage_costs.read_access ~path_length:3 ~read_bytes:8) + >>?= fun c -> get_balance c contract >>=? fun balance -> return (c, balance) + +let update_script_storage c contract storage lazy_storage_diff = + let storage = Script_repr.lazy_expr storage in + update_script_lazy_storage c lazy_storage_diff + >>=? fun (c, lazy_storage_size_diff) -> + Storage.Contract.Storage.set c contract storage + >>=? fun (c, size_diff) -> + Storage.Contract.Used_storage_space.get c contract + >>=? fun previous_size -> + let new_size = + Z.add previous_size (Z.add lazy_storage_size_diff (Z.of_int size_diff)) + in + Storage.Contract.Used_storage_space.set c contract new_size + +let spend c contract amount = + Storage.Contract.Balance.get c contract + >>=? fun balance -> + match Tez_repr.(balance -? amount) with + | Error _ -> + fail (Balance_too_low (contract, balance, amount)) + | Ok new_balance -> ( + Storage.Contract.Balance.set c contract new_balance + >>=? fun c -> + Roll_storage.Contract.remove_amount c contract amount + >>=? fun c -> + if Tez_repr.(new_balance > Tez_repr.zero) then return c + else + match Contract_repr.is_implicit contract with + | None -> + return c (* Never delete originated contracts *) + | Some pkh -> ( + Delegate_storage.get c contract + >>=? function + | Some pkh' -> + if Signature.Public_key_hash.equal pkh pkh' then return c + else + (* Delegated implicit accounts cannot be emptied *) + fail (Empty_implicit_delegated_contract pkh) + | None -> + (* Delete empty implicit contract *) + delete c contract ) ) + +let credit c contract amount = + ( if Tez_repr.(amount <> Tez_repr.zero) then return c + else + must_exist c contract + >>=? fun () -> + Storage.Contract.Code.mem c contract + >>=? fun (c, target_has_code) -> + Lwt.return + ( error_unless target_has_code (Empty_transaction contract) + >|? fun () -> c ) ) + >>=? fun c -> + Storage.Contract.Balance.get_option c contract + >>=? function + | None -> ( + match Contract_repr.is_implicit contract with + | None -> + fail (Non_existing_contract contract) + | Some manager -> + create_implicit c manager ~balance:amount ) + | Some balance -> + Tez_repr.(amount +? balance) + >>?= fun balance -> + Storage.Contract.Balance.set c contract balance + >>=? fun c -> Roll_storage.Contract.add_amount c contract amount + +let init c = + Storage.Contract.Global_counter.init c Z.zero + >>=? fun c -> Lazy_storage_diff.init c + +let used_storage_space c contract = + Storage.Contract.Used_storage_space.get_option c contract + >|=? Option.value ~default:Z.zero + +let paid_storage_space c contract = + Storage.Contract.Paid_storage_space.get_option c contract + >|=? Option.value ~default:Z.zero + +let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space + = + Storage.Contract.Paid_storage_space.get c contract + >>=? fun already_paid_space -> + if Compare.Z.(already_paid_space >= new_storage_space) then return (Z.zero, c) + else + let to_pay = Z.sub new_storage_space already_paid_space in + Storage.Contract.Paid_storage_space.set c contract new_storage_space + >|=? fun c -> (to_pay, c) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/contract_storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/contract_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..51cdccb40b08f75b138e4fab952f480968c6c44a --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/contract_storage.mli @@ -0,0 +1,183 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += + | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t + | (* `Temporary *) + Counter_in_the_past of Contract_repr.contract * Z.t * Z.t + | (* `Branch *) + Counter_in_the_future of Contract_repr.contract * Z.t * Z.t + | (* `Temporary *) + Unspendable_contract of Contract_repr.contract + | (* `Permanent *) + Non_existing_contract of Contract_repr.contract + | (* `Temporary *) + Empty_implicit_contract of Signature.Public_key_hash.t + | (* `Temporary *) + Empty_implicit_delegated_contract of + Signature.Public_key_hash.t + | (* `Temporary *) + Empty_transaction of Contract_repr.t (* `Temporary *) + | Inconsistent_hash of + Signature.Public_key.t + * Signature.Public_key_hash.t + * Signature.Public_key_hash.t + | (* `Permanent *) + Inconsistent_public_key of + Signature.Public_key.t * Signature.Public_key.t + | (* `Permanent *) + Failure of string (* `Permanent *) + | Previously_revealed_key of Contract_repr.t (* `Permanent *) + | Unrevealed_manager_key of Contract_repr.t + +(* `Permanent *) + +val exists : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t + +val must_exist : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t + +val allocated : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t + +val must_be_allocated : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t + +val list : Raw_context.t -> Contract_repr.t list Lwt.t + +val check_counter_increment : + Raw_context.t -> Signature.Public_key_hash.t -> Z.t -> unit tzresult Lwt.t + +val increment_counter : + Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t + +val get_manager_key : + Raw_context.t -> + Signature.Public_key_hash.t -> + Signature.Public_key.t tzresult Lwt.t + +val is_manager_key_revealed : + Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t + +val reveal_manager_key : + Raw_context.t -> + Signature.Public_key_hash.t -> + Signature.Public_key.t -> + Raw_context.t tzresult Lwt.t + +val get_balance : Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t + +val get_balance_carbonated : + Raw_context.t -> + Contract_repr.t -> + (Raw_context.t * Tez_repr.t) tzresult Lwt.t + +val get_counter : + Raw_context.t -> Signature.Public_key_hash.t -> Z.t tzresult Lwt.t + +val get_script_code : + Raw_context.t -> + Contract_repr.t -> + (Raw_context.t * Script_repr.lazy_expr option) tzresult Lwt.t + +val get_script : + Raw_context.t -> + Contract_repr.t -> + (Raw_context.t * Script_repr.t option) tzresult Lwt.t + +val get_storage : + Raw_context.t -> + Contract_repr.t -> + (Raw_context.t * Script_repr.expr option) tzresult Lwt.t + +module Legacy_big_map_diff : sig + type item = private + | Update of { + big_map : Z.t; + diff_key : Script_repr.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script_repr.expr option; + } + | Clear of Z.t + | Copy of {src : Z.t; dst : Z.t} + | Alloc of { + big_map : Z.t; + key_type : Script_repr.expr; + value_type : Script_repr.expr; + } + + type t = item list + + val encoding : t Data_encoding.t + + val to_lazy_storage_diff : t -> Lazy_storage_diff.diffs + + val of_lazy_storage_diff : Lazy_storage_diff.diffs -> t +end + +val update_script_storage : + Raw_context.t -> + Contract_repr.t -> + Script_repr.expr -> + Lazy_storage_diff.diffs option -> + Raw_context.t tzresult Lwt.t + +val credit : + Raw_context.t -> + Contract_repr.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t + +val spend : + Raw_context.t -> + Contract_repr.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t + +val raw_originate : + Raw_context.t -> + ?prepaid_bootstrap_storage:bool -> + Contract_repr.t -> + balance:Tez_repr.t -> + script:Script_repr.t * Lazy_storage_diff.diffs option -> + delegate:Signature.Public_key_hash.t option -> + Raw_context.t tzresult Lwt.t + +val fresh_contract_from_current_nonce : + Raw_context.t -> (Raw_context.t * Contract_repr.t) tzresult + +val originated_from_current_nonce : + since:Raw_context.t -> + until:Raw_context.t -> + Contract_repr.t list tzresult Lwt.t + +val init : Raw_context.t -> Raw_context.t tzresult Lwt.t + +val used_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t + +val paid_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t + +val set_paid_storage_space_and_return_fees_to_pay : + Raw_context.t -> + Contract_repr.t -> + Z.t -> + (Z.t * Raw_context.t) tzresult Lwt.t diff --git a/src/proto_008_PtEdoTez/lib_protocol/coq-of-ocaml/README.md b/src/proto_008_PtEdo2Zk/lib_protocol/coq-of-ocaml/README.md similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/coq-of-ocaml/README.md rename to src/proto_008_PtEdo2Zk/lib_protocol/coq-of-ocaml/README.md diff --git a/src/proto_008_PtEdoTez/lib_protocol/coq-of-ocaml/config.json b/src/proto_008_PtEdo2Zk/lib_protocol/coq-of-ocaml/config.json similarity index 94% rename from src/proto_008_PtEdoTez/lib_protocol/coq-of-ocaml/config.json rename to src/proto_008_PtEdo2Zk/lib_protocol/coq-of-ocaml/config.json index cf3751fa18de692c6c3b32c258bbafbffc482626..ded4f89dfcd2d1d39ed0aec6ad43015c7dfad17d 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/coq-of-ocaml/config.json +++ b/src/proto_008_PtEdo2Zk/lib_protocol/coq-of-ocaml/config.json @@ -38,7 +38,7 @@ "voting_period_repr.ml" ], "error_message_blacklist": [ - "Unbound module Tezos_protocol_008_PtEdoTez_functor" + "Unbound module Tezos_protocol_008_PtEdo2Zk_functor" ], "escape_value": [ "a", @@ -81,7 +81,7 @@ "type_logger" ], "first_class_module_path_blacklist": [ - "Tezos_raw_protocol_008_PtEdoTez" + "Tezos_raw_protocol_008_PtEdo2Zk" ], "head_suffix": "Import Environment.Notations.\n", "monadic_operators": [ @@ -90,7 +90,7 @@ ["Error_monad.op_gtgtquestion", "let?"] ], "require": [ - ["Tezos_raw_protocol_008_PtEdoTez", "TezosOfOCaml.Proto_alpha"] + ["Tezos_raw_protocol_008_PtEdo2Zk", "TezosOfOCaml.Proto_alpha"] ], "require_import": [ ["Tezos_protocol_environment_alpha", "TezosOfOCaml.Proto_alpha"] diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/cycle_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/cycle_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..2b58e176923dab9dea8166fe82b419bc7f0896d9 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/cycle_repr.ml @@ -0,0 +1,86 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = int32 + +type cycle = t + +let encoding = Data_encoding.int32 + +let rpc_arg = + let construct = Int32.to_string in + let destruct str = + Int32.of_string_opt str |> Option.to_result ~none:"Cannot parse cycle" + in + RPC_arg.make + ~descr:"A cycle integer" + ~name:"block_cycle" + ~construct + ~destruct + () + +let pp ppf cycle = Format.fprintf ppf "%ld" cycle + +include (Compare.Int32 : Compare.S with type t := t) + +module Map = Map.Make (Compare.Int32) + +let root = 0l + +let succ = Int32.succ + +let pred = function 0l -> None | i -> Some (Int32.pred i) + +let add c i = + assert (Compare.Int.(i >= 0)) ; + Int32.add c (Int32.of_int i) + +let sub c i = + assert (Compare.Int.(i >= 0)) ; + let r = Int32.sub c (Int32.of_int i) in + if Compare.Int32.(r < 0l) then None else Some r + +let to_int32 i = i + +let of_int32_exn l = + if Compare.Int32.(l >= 0l) then l + else invalid_arg "Level_repr.Cycle.of_int32" + +module Index = struct + type t = cycle + + let path_length = 1 + + let to_path c l = Int32.to_string (to_int32 c) :: l + + let of_path = function [s] -> Int32.of_string_opt s | _ -> None + + let rpc_arg = rpc_arg + + let encoding = encoding + + let compare = compare +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/cycle_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/cycle_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..241992c708fdb4f27f4267063f7cd0e2d42ef882 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/cycle_repr.mli @@ -0,0 +1,54 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t + +type cycle = t + +include Compare.S with type t := t + +val encoding : cycle Data_encoding.t + +val rpc_arg : cycle RPC_arg.arg + +val pp : Format.formatter -> cycle -> unit + +val root : cycle + +val pred : cycle -> cycle option + +val add : cycle -> int -> cycle + +val sub : cycle -> int -> cycle option + +val succ : cycle -> cycle + +val to_int32 : cycle -> int32 + +val of_int32_exn : int32 -> cycle + +module Map : S.MAP with type key = cycle + +module Index : Storage_description.INDEX with type t = cycle diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/delegate_services.ml b/src/proto_008_PtEdo2Zk/lib_protocol/delegate_services.ml new file mode 100644 index 0000000000000000000000000000000000000000..6c8401f8a6249614107616f370d83ea083a5a8ad --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/delegate_services.ml @@ -0,0 +1,768 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +type info = { + balance : Tez.t; + frozen_balance : Tez.t; + frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t; + staking_balance : Tez.t; + delegated_contracts : Contract_repr.t list; + delegated_balance : Tez.t; + deactivated : bool; + grace_period : Cycle.t; + voting_power : int32; +} + +let info_encoding = + let open Data_encoding in + conv + (fun { balance; + frozen_balance; + frozen_balance_by_cycle; + staking_balance; + delegated_contracts; + delegated_balance; + deactivated; + grace_period; + voting_power } -> + ( balance, + frozen_balance, + frozen_balance_by_cycle, + staking_balance, + delegated_contracts, + delegated_balance, + deactivated, + grace_period, + voting_power )) + (fun ( balance, + frozen_balance, + frozen_balance_by_cycle, + staking_balance, + delegated_contracts, + delegated_balance, + deactivated, + grace_period, + voting_power ) -> + { + balance; + frozen_balance; + frozen_balance_by_cycle; + staking_balance; + delegated_contracts; + delegated_balance; + deactivated; + grace_period; + voting_power; + }) + (obj9 + (req "balance" Tez.encoding) + (req "frozen_balance" Tez.encoding) + (req "frozen_balance_by_cycle" Delegate.frozen_balance_by_cycle_encoding) + (req "staking_balance" Tez.encoding) + (req "delegated_contracts" (list Contract_repr.encoding)) + (req "delegated_balance" Tez.encoding) + (req "deactivated" bool) + (req "grace_period" Cycle.encoding) + (req "voting_power" int32)) + +module S = struct + let path = RPC_path.(open_root / "context" / "delegates") + + open Data_encoding + + type list_query = {active : bool; inactive : bool} + + let list_query : list_query RPC_query.t = + let open RPC_query in + query (fun active inactive -> {active; inactive}) + |+ flag "active" (fun t -> t.active) + |+ flag "inactive" (fun t -> t.inactive) + |> seal + + let list_delegate = + RPC_service.get_service + ~description:"Lists all registered delegates." + ~query:list_query + ~output:(list Signature.Public_key_hash.encoding) + path + + let path = RPC_path.(path /: Signature.Public_key_hash.rpc_arg) + + let info = + RPC_service.get_service + ~description:"Everything about a delegate." + ~query:RPC_query.empty + ~output:info_encoding + path + + let balance = + RPC_service.get_service + ~description: + "Returns the full balance of a given delegate, including the frozen \ + balances." + ~query:RPC_query.empty + ~output:Tez.encoding + RPC_path.(path / "balance") + + let frozen_balance = + RPC_service.get_service + ~description: + "Returns the total frozen balances of a given delegate, this includes \ + the frozen deposits, rewards and fees." + ~query:RPC_query.empty + ~output:Tez.encoding + RPC_path.(path / "frozen_balance") + + let frozen_balance_by_cycle = + RPC_service.get_service + ~description: + "Returns the frozen balances of a given delegate, indexed by the \ + cycle by which it will be unfrozen" + ~query:RPC_query.empty + ~output:Delegate.frozen_balance_by_cycle_encoding + RPC_path.(path / "frozen_balance_by_cycle") + + let staking_balance = + RPC_service.get_service + ~description: + "Returns the total amount of tokens delegated to a given delegate. \ + This includes the balances of all the contracts that delegate to it, \ + but also the balance of the delegate itself and its frozen fees and \ + deposits. The rewards do not count in the delegated balance until \ + they are unfrozen." + ~query:RPC_query.empty + ~output:Tez.encoding + RPC_path.(path / "staking_balance") + + let delegated_contracts = + RPC_service.get_service + ~description: + "Returns the list of contracts that delegate to a given delegate." + ~query:RPC_query.empty + ~output:(list Contract_repr.encoding) + RPC_path.(path / "delegated_contracts") + + let delegated_balance = + RPC_service.get_service + ~description: + "Returns the balances of all the contracts that delegate to a given \ + delegate. This excludes the delegate's own balance and its frozen \ + balances." + ~query:RPC_query.empty + ~output:Tez.encoding + RPC_path.(path / "delegated_balance") + + let deactivated = + RPC_service.get_service + ~description: + "Tells whether the delegate is currently tagged as deactivated or not." + ~query:RPC_query.empty + ~output:bool + RPC_path.(path / "deactivated") + + let grace_period = + RPC_service.get_service + ~description: + "Returns the cycle by the end of which the delegate might be \ + deactivated if she fails to execute any delegate action. A \ + deactivated delegate might be reactivated (without loosing any \ + rolls) by simply re-registering as a delegate. For deactivated \ + delegates, this value contains the cycle by which they were \ + deactivated." + ~query:RPC_query.empty + ~output:Cycle.encoding + RPC_path.(path / "grace_period") + + let voting_power = + RPC_service.get_service + ~description: + "The number of rolls in the vote listings for a given delegate" + ~query:RPC_query.empty + ~output:Data_encoding.int32 + RPC_path.(path / "voting_power") +end + +let register () = + let open Services_registration in + register0 S.list_delegate (fun ctxt q () -> + Delegate.list ctxt + >>= fun delegates -> + match q with + | {active = true; inactive = false} -> + filter_s + (fun pkh -> Delegate.deactivated ctxt pkh >|=? not) + delegates + | {active = false; inactive = true} -> + filter_s (fun pkh -> Delegate.deactivated ctxt pkh) delegates + | _ -> + return delegates) ; + register1 S.info (fun ctxt pkh () () -> + Delegate.full_balance ctxt pkh + >>=? fun balance -> + Delegate.frozen_balance ctxt pkh + >>=? fun frozen_balance -> + Delegate.frozen_balance_by_cycle ctxt pkh + >>= fun frozen_balance_by_cycle -> + Delegate.staking_balance ctxt pkh + >>=? fun staking_balance -> + Delegate.delegated_contracts ctxt pkh + >>= fun delegated_contracts -> + Delegate.delegated_balance ctxt pkh + >>=? fun delegated_balance -> + Delegate.deactivated ctxt pkh + >>=? fun deactivated -> + Delegate.grace_period ctxt pkh + >>=? fun grace_period -> + Vote.get_voting_power_free ctxt pkh + >|=? fun voting_power -> + { + balance; + frozen_balance; + frozen_balance_by_cycle; + staking_balance; + delegated_contracts; + delegated_balance; + deactivated; + grace_period; + voting_power; + }) ; + register1 S.balance (fun ctxt pkh () () -> Delegate.full_balance ctxt pkh) ; + register1 S.frozen_balance (fun ctxt pkh () () -> + Delegate.frozen_balance ctxt pkh) ; + register1 S.frozen_balance_by_cycle (fun ctxt pkh () () -> + Delegate.frozen_balance_by_cycle ctxt pkh >|= ok) ; + register1 S.staking_balance (fun ctxt pkh () () -> + Delegate.staking_balance ctxt pkh) ; + register1 S.delegated_contracts (fun ctxt pkh () () -> + Delegate.delegated_contracts ctxt pkh >|= ok) ; + register1 S.delegated_balance (fun ctxt pkh () () -> + Delegate.delegated_balance ctxt pkh) ; + register1 S.deactivated (fun ctxt pkh () () -> Delegate.deactivated ctxt pkh) ; + register1 S.grace_period (fun ctxt pkh () () -> + Delegate.grace_period ctxt pkh) ; + register1 S.voting_power (fun ctxt pkh () () -> + Vote.get_voting_power_free ctxt pkh) + +let list ctxt block ?(active = true) ?(inactive = false) () = + RPC_context.make_call0 S.list_delegate ctxt block {active; inactive} () + +let info ctxt block pkh = RPC_context.make_call1 S.info ctxt block pkh () () + +let balance ctxt block pkh = + RPC_context.make_call1 S.balance ctxt block pkh () () + +let frozen_balance ctxt block pkh = + RPC_context.make_call1 S.frozen_balance ctxt block pkh () () + +let frozen_balance_by_cycle ctxt block pkh = + RPC_context.make_call1 S.frozen_balance_by_cycle ctxt block pkh () () + +let staking_balance ctxt block pkh = + RPC_context.make_call1 S.staking_balance ctxt block pkh () () + +let delegated_contracts ctxt block pkh = + RPC_context.make_call1 S.delegated_contracts ctxt block pkh () () + +let delegated_balance ctxt block pkh = + RPC_context.make_call1 S.delegated_balance ctxt block pkh () () + +let deactivated ctxt block pkh = + RPC_context.make_call1 S.deactivated ctxt block pkh () () + +let grace_period ctxt block pkh = + RPC_context.make_call1 S.grace_period ctxt block pkh () () + +let voting_power ctxt block pkh = + RPC_context.make_call1 S.voting_power ctxt block pkh () () + +let requested_levels ~default ctxt cycles levels = + match (levels, cycles) with + | ([], []) -> + ok [default] + | (levels, cycles) -> + (* explicitly fail when requested levels or cycle are in the past... + or too far in the future... *) + let levels = + List.sort_uniq + Level.compare + (List.concat + ( List.map (Level.from_raw ctxt) levels + :: List.map (Level.levels_in_cycle ctxt) cycles )) + in + map + (fun level -> + let current_level = Level.current ctxt in + if Level.(level <= current_level) then ok (level, None) + else + Baking.earlier_predecessor_timestamp ctxt level + >|? fun timestamp -> (level, Some timestamp)) + levels + +module Baking_rights = struct + type t = { + level : Raw_level.t; + delegate : Signature.Public_key_hash.t; + priority : int; + timestamp : Timestamp.t option; + } + + let encoding = + let open Data_encoding in + conv + (fun {level; delegate; priority; timestamp} -> + (level, delegate, priority, timestamp)) + (fun (level, delegate, priority, timestamp) -> + {level; delegate; priority; timestamp}) + (obj4 + (req "level" Raw_level.encoding) + (req "delegate" Signature.Public_key_hash.encoding) + (req "priority" uint16) + (opt "estimated_time" Timestamp.encoding)) + + module S = struct + open Data_encoding + + let custom_root = RPC_path.(open_root / "helpers" / "baking_rights") + + type baking_rights_query = { + levels : Raw_level.t list; + cycles : Cycle.t list; + delegates : Signature.Public_key_hash.t list; + max_priority : int option; + all : bool; + } + + let baking_rights_query = + let open RPC_query in + query (fun levels cycles delegates max_priority all -> + {levels; cycles; delegates; max_priority; all}) + |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels) + |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles) + |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> + t.delegates) + |+ opt_field "max_priority" RPC_arg.int (fun t -> t.max_priority) + |+ flag "all" (fun t -> t.all) + |> seal + + let baking_rights = + RPC_service.get_service + ~description: + "Retrieves the list of delegates allowed to bake a block.\n\ + By default, it gives the best baking priorities for bakers that \ + have at least one opportunity below the 64th priority for the next \ + block.\n\ + Parameters `level` and `cycle` can be used to specify the (valid) \ + level(s) in the past or future at which the baking rights have to \ + be returned. When asked for (a) whole cycle(s), baking \ + opportunities are given by default up to the priority 8.\n\ + Parameter `delegate` can be used to restrict the results to the \ + given delegates. If parameter `all` is set, all the baking \ + opportunities for each baker at each level are returned, instead \ + of just the first one.\n\ + Returns the list of baking slots. Also returns the minimal \ + timestamps that correspond to these slots. The timestamps are \ + omitted for levels in the past, and are only estimates for levels \ + later that the next block, based on the hypothesis that all \ + predecessor blocks were baked at the first priority." + ~query:baking_rights_query + ~output:(list encoding) + custom_root + end + + let baking_priorities ctxt max_prio (level, pred_timestamp) = + Baking.baking_priorities ctxt level + >>=? fun contract_list -> + let rec loop l acc priority = + if Compare.Int.(priority > max_prio) then return (List.rev acc) + else + let (Misc.LCons (pk, next)) = l in + let delegate = Signature.Public_key.hash pk in + ( match pred_timestamp with + | None -> + ok_none + | Some pred_timestamp -> + Baking.minimal_time ctxt priority pred_timestamp + >|? fun t -> Some t ) + >>?= fun timestamp -> + let acc = + {level = level.level; delegate; priority; timestamp} :: acc + in + next () >>=? fun l -> loop l acc (priority + 1) + in + loop contract_list [] 0 + + let baking_priorities_of_delegates ctxt ~all ~max_prio delegates + (level, pred_timestamp) = + Baking.baking_priorities ctxt level + >>=? fun contract_list -> + let rec loop l acc priority delegates = + match delegates with + | [] -> + return (List.rev acc) + | _ :: _ -> ( + if Compare.Int.(priority > max_prio) then return (List.rev acc) + else + let (Misc.LCons (pk, next)) = l in + next () + >>=? fun l -> + match + List.partition + (fun (pk', _) -> Signature.Public_key.equal pk pk') + delegates + with + | ([], _) -> + loop l acc (priority + 1) delegates + | ((_, delegate) :: _, delegates') -> + ( match pred_timestamp with + | None -> + ok_none + | Some pred_timestamp -> + Baking.minimal_time ctxt priority pred_timestamp + >|? fun t -> Some t ) + >>?= fun timestamp -> + let acc = + {level = level.level; delegate; priority; timestamp} :: acc + in + let delegates'' = if all then delegates else delegates' in + loop l acc (priority + 1) delegates'' ) + in + loop contract_list [] 0 delegates + + let remove_duplicated_delegates rights = + List.rev @@ fst + @@ List.fold_left + (fun (acc, previous) r -> + if Signature.Public_key_hash.Set.mem r.delegate previous then + (acc, previous) + else + (r :: acc, Signature.Public_key_hash.Set.add r.delegate previous)) + ([], Signature.Public_key_hash.Set.empty) + rights + + let register () = + let open Services_registration in + register0 S.baking_rights (fun ctxt q () -> + requested_levels + ~default: + ( Level.succ ctxt (Level.current ctxt), + Some (Timestamp.current ctxt) ) + ctxt + q.cycles + q.levels + >>?= fun levels -> + let max_priority = + match q.max_priority with + | Some max -> + max + | None -> ( + match q.cycles with [] -> 64 | _ :: _ -> 8 ) + in + match q.delegates with + | [] -> + map_s (baking_priorities ctxt max_priority) levels + >|=? fun rights -> + let rights = + if q.all then rights + else List.map remove_duplicated_delegates rights + in + List.concat rights + | _ :: _ as delegates -> + Lwt_list.filter_map_s + (fun delegate -> + Contract.get_manager_key ctxt delegate + >>= function + | Ok pk -> + Lwt.return (Some (pk, delegate)) + | Error _ -> + Lwt.return_none) + delegates + >>= fun delegates -> + map_s + (fun level -> + baking_priorities_of_delegates + ctxt + q.all + max_priority + delegates + level) + levels + >|=? List.concat) + + let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) ?(all = false) + ?max_priority block = + RPC_context.make_call0 + S.baking_rights + ctxt + block + {levels; cycles; delegates; max_priority; all} + () +end + +module Endorsing_rights = struct + type t = { + level : Raw_level.t; + delegate : Signature.Public_key_hash.t; + slots : int list; + estimated_time : Time.t option; + } + + let encoding = + let open Data_encoding in + conv + (fun {level; delegate; slots; estimated_time} -> + (level, delegate, slots, estimated_time)) + (fun (level, delegate, slots, estimated_time) -> + {level; delegate; slots; estimated_time}) + (obj4 + (req "level" Raw_level.encoding) + (req "delegate" Signature.Public_key_hash.encoding) + (req "slots" (list uint16)) + (opt "estimated_time" Timestamp.encoding)) + + module S = struct + open Data_encoding + + let custom_root = RPC_path.(open_root / "helpers" / "endorsing_rights") + + type endorsing_rights_query = { + levels : Raw_level.t list; + cycles : Cycle.t list; + delegates : Signature.Public_key_hash.t list; + } + + let endorsing_rights_query = + let open RPC_query in + query (fun levels cycles delegates -> {levels; cycles; delegates}) + |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels) + |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles) + |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> + t.delegates) + |> seal + + let endorsing_rights = + RPC_service.get_service + ~description: + "Retrieves the delegates allowed to endorse a block.\n\ + By default, it gives the endorsement slots for delegates that have \ + at least one in the next block.\n\ + Parameters `level` and `cycle` can be used to specify the (valid) \ + level(s) in the past or future at which the endorsement rights \ + have to be returned. Parameter `delegate` can be used to restrict \ + the results to the given delegates.\n\ + Returns the list of endorsement slots. Also returns the minimal \ + timestamps that correspond to these slots. The timestamps are \ + omitted for levels in the past, and are only estimates for levels \ + later that the next block, based on the hypothesis that all \ + predecessor blocks were baked at the first priority." + ~query:endorsing_rights_query + ~output:(list encoding) + custom_root + end + + let endorsement_slots ctxt (level, estimated_time) = + Baking.endorsement_rights ctxt level + >|=? fun rights -> + Signature.Public_key_hash.Map.fold + (fun delegate (_, slots, _) acc -> + {level = level.level; delegate; slots; estimated_time} :: acc) + rights + [] + + let register () = + let open Services_registration in + register0 S.endorsing_rights (fun ctxt q () -> + requested_levels + ~default:(Level.current ctxt, Some (Timestamp.current ctxt)) + ctxt + q.cycles + q.levels + >>?= fun levels -> + map_s (endorsement_slots ctxt) levels + >|=? fun rights -> + let rights = List.concat rights in + match q.delegates with + | [] -> + rights + | _ :: _ as delegates -> + let is_requested p = + List.exists + (Signature.Public_key_hash.equal p.delegate) + delegates + in + List.filter is_requested rights) + + let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) block = + RPC_context.make_call0 + S.endorsing_rights + ctxt + block + {levels; cycles; delegates} + () +end + +module Endorsing_power = struct + let endorsing_power ctxt (operation, chain_id) = + let (Operation_data data) = operation.protocol_data in + match data.contents with + | Single (Endorsement _) -> + Baking.check_endorsement_rights + ctxt + chain_id + {shell = operation.shell; protocol_data = data} + >|=? fun (_, slots, _) -> List.length slots + | _ -> + failwith "Operation is not an endorsement" + + module S = struct + let endorsing_power = + let open Data_encoding in + RPC_service.post_service + ~description: + "Get the endorsing power of an endorsement, that is, the number of \ + slots that the endorser has" + ~query:RPC_query.empty + ~input: + (obj2 + (req "endorsement_operation" Operation.encoding) + (req "chain_id" Chain_id.encoding)) + ~output:int31 + RPC_path.(open_root / "endorsing_power") + end + + let register () = + let open Services_registration in + register0 S.endorsing_power (fun ctxt () (op, chain_id) -> + endorsing_power ctxt (op, chain_id)) + + let get ctxt block op chain_id = + RPC_context.make_call0 S.endorsing_power ctxt block () (op, chain_id) +end + +module Required_endorsements = struct + let required_endorsements ctxt block_delay = + Baking.minimum_allowed_endorsements ctxt ~block_delay + + module S = struct + type t = {block_delay : Period.t} + + let required_endorsements_query = + let open RPC_query in + query (fun block_delay -> {block_delay}) + |+ field "block_delay" Period.rpc_arg Period.zero (fun t -> + t.block_delay) + |> seal + + let required_endorsements = + let open Data_encoding in + RPC_service.get_service + ~description: + "Minimum number of endorsements for a block to be valid, given a \ + delay of the block's timestamp with respect to the minimum time to \ + bake at the block's priority" + ~query:required_endorsements_query + ~output:int31 + RPC_path.(open_root / "required_endorsements") + end + + let register () = + let open Services_registration in + register0 S.required_endorsements (fun ctxt {block_delay} () -> + return @@ required_endorsements ctxt block_delay) + + let get ctxt block block_delay = + RPC_context.make_call0 S.required_endorsements ctxt block {block_delay} () +end + +module Minimal_valid_time = struct + let minimal_valid_time ctxt ~priority ~endorsing_power = + Baking.minimal_valid_time ctxt ~priority ~endorsing_power + + module S = struct + type t = {priority : int; endorsing_power : int} + + let minimal_valid_time_query = + let open RPC_query in + query (fun priority endorsing_power -> {priority; endorsing_power}) + |+ field "priority" RPC_arg.int 0 (fun t -> t.priority) + |+ field "endorsing_power" RPC_arg.int 0 (fun t -> t.endorsing_power) + |> seal + + let minimal_valid_time = + RPC_service.get_service + ~description: + "Minimal valid time for a block given a priority and an endorsing \ + power." + ~query:minimal_valid_time_query + ~output:Time.encoding + RPC_path.(open_root / "minimal_valid_time") + end + + let register () = + let open Services_registration in + register0 S.minimal_valid_time (fun ctxt {priority; endorsing_power} () -> + Lwt.return @@ minimal_valid_time ctxt ~priority ~endorsing_power) + + let get ctxt block priority endorsing_power = + RPC_context.make_call0 + S.minimal_valid_time + ctxt + block + {priority; endorsing_power} + () +end + +let register () = + register () ; + Baking_rights.register () ; + Endorsing_rights.register () ; + Endorsing_power.register () ; + Required_endorsements.register () ; + Minimal_valid_time.register () + +let endorsement_rights ctxt level = + Endorsing_rights.endorsement_slots ctxt (level, None) + >|=? fun l -> List.map (fun {Endorsing_rights.delegate; _} -> delegate) l + +let baking_rights ctxt max_priority = + let max = match max_priority with None -> 64 | Some m -> m in + let level = Level.current ctxt in + Baking_rights.baking_priorities ctxt max (level, None) + >|=? fun l -> + ( level.level, + List.map + (fun {Baking_rights.delegate; timestamp; _} -> (delegate, timestamp)) + l ) + +let endorsing_power ctxt operation = + Endorsing_power.endorsing_power ctxt operation + +let required_endorsements ctxt delay = + Required_endorsements.required_endorsements ctxt delay + +let minimal_valid_time ctxt priority endorsing_power = + Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/delegate_services.mli b/src/proto_008_PtEdo2Zk/lib_protocol/delegate_services.mli new file mode 100644 index 0000000000000000000000000000000000000000..05d2dfcce29ae7f28b8a918c4580366853da58dc --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/delegate_services.mli @@ -0,0 +1,215 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +val list : + 'a #RPC_context.simple -> + 'a -> + ?active:bool -> + ?inactive:bool -> + unit -> + Signature.Public_key_hash.t list shell_tzresult Lwt.t + +type info = { + balance : Tez.t; + frozen_balance : Tez.t; + frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t; + staking_balance : Tez.t; + delegated_contracts : Contract_repr.t list; + delegated_balance : Tez.t; + deactivated : bool; + grace_period : Cycle.t; + voting_power : int32; +} + +val info_encoding : info Data_encoding.t + +val info : + 'a #RPC_context.simple -> + 'a -> + Signature.Public_key_hash.t -> + info shell_tzresult Lwt.t + +val balance : + 'a #RPC_context.simple -> + 'a -> + Signature.Public_key_hash.t -> + Tez.t shell_tzresult Lwt.t + +val frozen_balance : + 'a #RPC_context.simple -> + 'a -> + Signature.Public_key_hash.t -> + Tez.t shell_tzresult Lwt.t + +val frozen_balance_by_cycle : + 'a #RPC_context.simple -> + 'a -> + Signature.Public_key_hash.t -> + Delegate.frozen_balance Cycle.Map.t shell_tzresult Lwt.t + +val staking_balance : + 'a #RPC_context.simple -> + 'a -> + Signature.Public_key_hash.t -> + Tez.t shell_tzresult Lwt.t + +val delegated_contracts : + 'a #RPC_context.simple -> + 'a -> + Signature.Public_key_hash.t -> + Contract_repr.t list shell_tzresult Lwt.t + +val delegated_balance : + 'a #RPC_context.simple -> + 'a -> + Signature.Public_key_hash.t -> + Tez.t shell_tzresult Lwt.t + +val deactivated : + 'a #RPC_context.simple -> + 'a -> + Signature.Public_key_hash.t -> + bool shell_tzresult Lwt.t + +val grace_period : + 'a #RPC_context.simple -> + 'a -> + Signature.Public_key_hash.t -> + Cycle.t shell_tzresult Lwt.t + +val voting_power : + 'a #RPC_context.simple -> 'a -> public_key_hash -> int32 shell_tzresult Lwt.t + +module Baking_rights : sig + type t = { + level : Raw_level.t; + delegate : Signature.Public_key_hash.t; + priority : int; + timestamp : Timestamp.t option; + } + + (** Retrieves the list of delegates allowed to bake a block. + + By default, it gives the best baking priorities for bakers + that have at least one opportunity below the 64th priority for + the next block. + + Parameters [levels] and [cycles] can be used to specify the + (valid) level(s) in the past or future at which the baking rights + have to be returned. Parameter [delegates] can be used to + restrict the results to the given delegates. If parameter [all] + is [true], all the baking opportunities for each baker at each level + are returned, instead of just the first one. + + Returns the list of baking slots. Also returns the minimal + timestamps that correspond to these slots. The timestamps are + omitted for levels in the past, and are only estimates for levels + later that the next block, based on the hypothesis that all + predecessor blocks were baked at the first priority. *) + val get : + 'a #RPC_context.simple -> + ?levels:Raw_level.t list -> + ?cycles:Cycle.t list -> + ?delegates:Signature.public_key_hash list -> + ?all:bool -> + ?max_priority:int -> + 'a -> + t list shell_tzresult Lwt.t +end + +module Endorsing_rights : sig + type t = { + level : Raw_level.t; + delegate : Signature.Public_key_hash.t; + slots : int list; + estimated_time : Timestamp.t option; + } + + (** Retrieves the delegates allowed to endorse a block. + + By default, it gives the endorsement slots for bakers that have + at least one in the next block. + + Parameters [levels] and [cycles] can be used to specify the + (valid) level(s) in the past or future at which the endorsement + rights have to be returned. Parameter [delegates] can be used to + restrict the results to the given delegates. Returns the list of + endorsement slots. Also returns the minimal timestamps that + correspond to these slots. + + Timestamps are omitted for levels in the past, and are only + estimates for levels later that the next block, based on the + hypothesis that all predecessor blocks were baked at the first + priority. *) + val get : + 'a #RPC_context.simple -> + ?levels:Raw_level.t list -> + ?cycles:Cycle.t list -> + ?delegates:Signature.public_key_hash list -> + 'a -> + t list shell_tzresult Lwt.t +end + +module Endorsing_power : sig + val get : + 'a #RPC_context.simple -> + 'a -> + Alpha_context.packed_operation -> + Chain_id.t -> + int shell_tzresult Lwt.t +end + +module Required_endorsements : sig + val get : + 'a #RPC_context.simple -> 'a -> Period.t -> int shell_tzresult Lwt.t +end + +module Minimal_valid_time : sig + val get : + 'a #RPC_context.simple -> 'a -> int -> int -> Time.t shell_tzresult Lwt.t +end + +(* temporary export for deprecated unit test *) +val endorsement_rights : + Alpha_context.t -> Level.t -> public_key_hash list tzresult Lwt.t + +val baking_rights : + Alpha_context.t -> + int option -> + (Raw_level.t * (public_key_hash * Time.t option) list) tzresult Lwt.t + +val endorsing_power : + Alpha_context.t -> + Alpha_context.packed_operation * Chain_id.t -> + int tzresult Lwt.t + +val required_endorsements : Alpha_context.t -> Alpha_context.Period.t -> int + +val minimal_valid_time : Alpha_context.t -> int -> int -> Time.t tzresult + +val register : unit -> unit diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/delegate_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/delegate_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..eeca6d4607eb18a8033e9abcc79faf470589b285 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/delegate_storage.ml @@ -0,0 +1,701 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type balance = + | Contract of Contract_repr.t + | Rewards of Signature.Public_key_hash.t * Cycle_repr.t + | Fees of Signature.Public_key_hash.t * Cycle_repr.t + | Deposits of Signature.Public_key_hash.t * Cycle_repr.t + +let balance_encoding = + let open Data_encoding in + def "operation_metadata.alpha.balance" + @@ union + [ case + (Tag 0) + ~title:"Contract" + (obj2 + (req "kind" (constant "contract")) + (req "contract" Contract_repr.encoding)) + (function Contract c -> Some ((), c) | _ -> None) + (fun ((), c) -> Contract c); + case + (Tag 1) + ~title:"Rewards" + (obj4 + (req "kind" (constant "freezer")) + (req "category" (constant "rewards")) + (req "delegate" Signature.Public_key_hash.encoding) + (req "cycle" Cycle_repr.encoding)) + (function Rewards (d, l) -> Some ((), (), d, l) | _ -> None) + (fun ((), (), d, l) -> Rewards (d, l)); + case + (Tag 2) + ~title:"Fees" + (obj4 + (req "kind" (constant "freezer")) + (req "category" (constant "fees")) + (req "delegate" Signature.Public_key_hash.encoding) + (req "cycle" Cycle_repr.encoding)) + (function Fees (d, l) -> Some ((), (), d, l) | _ -> None) + (fun ((), (), d, l) -> Fees (d, l)); + case + (Tag 3) + ~title:"Deposits" + (obj4 + (req "kind" (constant "freezer")) + (req "category" (constant "deposits")) + (req "delegate" Signature.Public_key_hash.encoding) + (req "cycle" Cycle_repr.encoding)) + (function Deposits (d, l) -> Some ((), (), d, l) | _ -> None) + (fun ((), (), d, l) -> Deposits (d, l)) ] + +type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t + +let balance_update_encoding = + let open Data_encoding in + def "operation_metadata.alpha.balance_update" + @@ obj1 + (req + "change" + (conv + (function + | Credited v -> + Tez_repr.to_mutez v + | Debited v -> + Int64.neg (Tez_repr.to_mutez v)) + ( Json.wrap_error + @@ fun v -> + if Compare.Int64.(v < 0L) then + match Tez_repr.of_mutez (Int64.neg v) with + | Some v -> + Debited v + | None -> + failwith "Qty.of_mutez" + else + match Tez_repr.of_mutez v with + | Some v -> + Credited v + | None -> + failwith "Qty.of_mutez" ) + int64)) + +type balance_updates = (balance * balance_update) list + +let balance_updates_encoding = + let open Data_encoding in + def "operation_metadata.alpha.balance_updates" + @@ list (merge_objs balance_encoding balance_update_encoding) + +let cleanup_balance_updates balance_updates = + List.filter + (fun (_, (Credited update | Debited update)) -> + not (Tez_repr.equal update Tez_repr.zero)) + balance_updates + +type frozen_balance = { + deposit : Tez_repr.t; + fees : Tez_repr.t; + rewards : Tez_repr.t; +} + +let frozen_balance_encoding = + let open Data_encoding in + conv + (fun {deposit; fees; rewards} -> (deposit, fees, rewards)) + (fun (deposit, fees, rewards) -> {deposit; fees; rewards}) + (obj3 + (req "deposit" Tez_repr.encoding) + (req "fees" Tez_repr.encoding) + (req "rewards" Tez_repr.encoding)) + +type error += + | No_deletion of Signature.Public_key_hash.t (* `Permanent *) + | Active_delegate (* `Temporary *) + | Current_delegate (* `Temporary *) + | Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *) + | Balance_too_low_for_deposit of { + delegate : Signature.Public_key_hash.t; + deposit : Tez_repr.t; + balance : Tez_repr.t; + } + +(* `Temporary *) + +let () = + register_error_kind + `Permanent + ~id:"delegate.no_deletion" + ~title:"Forbidden delegate deletion" + ~description:"Tried to unregister a delegate" + ~pp:(fun ppf delegate -> + Format.fprintf + ppf + "Delegate deletion is forbidden (%a)" + Signature.Public_key_hash.pp + delegate) + Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding)) + (function No_deletion c -> Some c | _ -> None) + (fun c -> No_deletion c) ; + register_error_kind + `Temporary + ~id:"delegate.already_active" + ~title:"Delegate already active" + ~description:"Useless delegate reactivation" + ~pp:(fun ppf () -> + Format.fprintf ppf "The delegate is still active, no need to refresh it") + Data_encoding.empty + (function Active_delegate -> Some () | _ -> None) + (fun () -> Active_delegate) ; + register_error_kind + `Temporary + ~id:"delegate.unchanged" + ~title:"Unchanged delegated" + ~description:"Contract already delegated to the given delegate" + ~pp:(fun ppf () -> + Format.fprintf + ppf + "The contract is already delegated to the same delegate") + Data_encoding.empty + (function Current_delegate -> Some () | _ -> None) + (fun () -> Current_delegate) ; + register_error_kind + `Permanent + ~id:"delegate.empty_delegate_account" + ~title:"Empty delegate account" + ~description: + "Cannot register a delegate when its implicit account is empty" + ~pp:(fun ppf delegate -> + Format.fprintf + ppf + "Delegate registration is forbidden when the delegate\n\ + \ implicit account is empty (%a)" + Signature.Public_key_hash.pp + delegate) + Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding)) + (function Empty_delegate_account c -> Some c | _ -> None) + (fun c -> Empty_delegate_account c) ; + register_error_kind + `Temporary + ~id:"delegate.balance_too_low_for_deposit" + ~title:"Balance too low for deposit" + ~description:"Cannot freeze deposit when the balance is too low" + ~pp:(fun ppf (delegate, balance, deposit) -> + Format.fprintf + ppf + "Delegate %a has a too low balance (%a) to deposit %a" + Signature.Public_key_hash.pp + delegate + Tez_repr.pp + balance + Tez_repr.pp + deposit) + Data_encoding.( + obj3 + (req "delegate" Signature.Public_key_hash.encoding) + (req "balance" Tez_repr.encoding) + (req "deposit" Tez_repr.encoding)) + (function + | Balance_too_low_for_deposit {delegate; balance; deposit} -> + Some (delegate, balance, deposit) + | _ -> + None) + (fun (delegate, balance, deposit) -> + Balance_too_low_for_deposit {delegate; balance; deposit}) + +let link c contract delegate = + Storage.Contract.Balance.get c contract + >>=? fun balance -> + Roll_storage.Delegate.add_amount c delegate balance + >>=? fun c -> + Storage.Contract.Delegated.add + (c, Contract_repr.implicit_contract delegate) + contract + >|= ok + +let unlink c contract = + Storage.Contract.Balance.get c contract + >>=? fun balance -> + Storage.Contract.Delegate.get_option c contract + >>=? function + | None -> + return c + | Some delegate -> + (* Removes the balance of the contract from the delegate *) + Roll_storage.Delegate.remove_amount c delegate balance + >>=? fun c -> + Storage.Contract.Delegated.del + (c, Contract_repr.implicit_contract delegate) + contract + >|= ok + +let known c delegate = + Storage.Contract.Manager.get_option + c + (Contract_repr.implicit_contract delegate) + >>=? function + | None | Some (Manager_repr.Hash _) -> + return_false + | Some (Manager_repr.Public_key _) -> + return_true + +(* A delegate is registered if its "implicit account" delegates to itself. *) +let registered c delegate = + Storage.Contract.Delegate.get_option + c + (Contract_repr.implicit_contract delegate) + >|=? function + | Some current_delegate -> + Signature.Public_key_hash.equal delegate current_delegate + | None -> + false + +let init ctxt contract delegate = + known ctxt delegate + >>=? fun known_delegate -> + error_unless known_delegate (Roll_storage.Unregistered_delegate delegate) + >>?= fun () -> + registered ctxt delegate + >>=? fun is_registered -> + error_unless is_registered (Roll_storage.Unregistered_delegate delegate) + >>?= fun () -> + Storage.Contract.Delegate.init ctxt contract delegate + >>=? fun ctxt -> link ctxt contract delegate + +let get = Roll_storage.get_contract_delegate + +let set c contract delegate = + match delegate with + | None -> ( + let delete () = + unlink c contract + >>=? fun c -> Storage.Contract.Delegate.remove c contract >|= ok + in + match Contract_repr.is_implicit contract with + | Some pkh -> + (* check if contract is a registered delegate *) + registered c pkh + >>=? fun is_registered -> + if is_registered then fail (No_deletion pkh) else delete () + | None -> + delete () ) + | Some delegate -> + known c delegate + >>=? fun known_delegate -> + registered c delegate + >>=? fun registered_delegate -> + let self_delegation = + match Contract_repr.is_implicit contract with + | Some pkh -> + Signature.Public_key_hash.equal pkh delegate + | None -> + false + in + if (not known_delegate) || not (registered_delegate || self_delegation) + then fail (Roll_storage.Unregistered_delegate delegate) + else + Storage.Contract.Delegate.get_option c contract + >>=? (function + | Some current_delegate + when Signature.Public_key_hash.equal delegate current_delegate + -> + if self_delegation then + Roll_storage.Delegate.is_inactive c delegate + >>=? function + | true -> return_unit | false -> fail Active_delegate + else fail Current_delegate + | None | Some _ -> + return_unit) + >>=? fun () -> + (* check if contract is a registered delegate *) + ( match Contract_repr.is_implicit contract with + | Some pkh -> + registered c pkh + >>=? fun is_registered -> + (* allow self-delegation to re-activate *) + if (not self_delegation) && is_registered then + fail (No_deletion pkh) + else return_unit + | None -> + return_unit ) + >>=? fun () -> + Storage.Contract.Balance.mem c contract + >>= fun exists -> + error_when + (self_delegation && not exists) + (Empty_delegate_account delegate) + >>?= fun () -> + unlink c contract + >>=? fun c -> + Storage.Contract.Delegate.init_set c contract delegate + >>= fun c -> + link c contract delegate + >>=? fun c -> + if self_delegation then + Storage.Delegates.add c delegate + >>= fun c -> Roll_storage.Delegate.set_active c delegate + else return c + +let remove ctxt contract = unlink ctxt contract + +let delegated_contracts ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + Storage.Contract.Delegated.elements (ctxt, contract) + +let get_frozen_deposit ctxt contract cycle = + Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle + >|=? Option.value ~default:Tez_repr.zero + +let credit_frozen_deposit ctxt delegate cycle amount = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_deposit ctxt contract cycle + >>=? fun old_amount -> + Tez_repr.(old_amount +? amount) + >>?= fun new_amount -> + Storage.Contract.Frozen_deposits.init_set (ctxt, contract) cycle new_amount + >>= fun ctxt -> + Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >|= ok + +let freeze_deposit ctxt delegate amount = + let ({Level_repr.cycle; _} : Level_repr.t) = Level_storage.current ctxt in + Roll_storage.Delegate.set_active ctxt delegate + >>=? fun ctxt -> + let contract = Contract_repr.implicit_contract delegate in + Storage.Contract.Balance.get ctxt contract + >>=? fun balance -> + record_trace + (Balance_too_low_for_deposit {delegate; deposit = amount; balance}) + Tez_repr.(balance -? amount) + >>?= fun new_balance -> + Storage.Contract.Balance.set ctxt contract new_balance + >>=? fun ctxt -> credit_frozen_deposit ctxt delegate cycle amount + +let get_frozen_fees ctxt contract cycle = + Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle + >|=? Option.value ~default:Tez_repr.zero + +let credit_frozen_fees ctxt delegate cycle amount = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_fees ctxt contract cycle + >>=? fun old_amount -> + Tez_repr.(old_amount +? amount) + >>?= fun new_amount -> + Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount + >>= fun ctxt -> + Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >|= ok + +let freeze_fees ctxt delegate amount = + let ({Level_repr.cycle; _} : Level_repr.t) = Level_storage.current ctxt in + Roll_storage.Delegate.add_amount ctxt delegate amount + >>=? fun ctxt -> credit_frozen_fees ctxt delegate cycle amount + +let burn_fees ctxt delegate cycle amount = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_fees ctxt contract cycle + >>=? fun old_amount -> + ( match Tez_repr.(old_amount -? amount) with + | Ok new_amount -> + Roll_storage.Delegate.remove_amount ctxt delegate amount + >|=? fun ctxt -> (new_amount, ctxt) + | Error _ -> + Roll_storage.Delegate.remove_amount ctxt delegate old_amount + >|=? fun ctxt -> (Tez_repr.zero, ctxt) ) + >>=? fun (new_amount, ctxt) -> + Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount + >|= ok + +let get_frozen_rewards ctxt contract cycle = + Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle + >|=? Option.value ~default:Tez_repr.zero + +let credit_frozen_rewards ctxt delegate cycle amount = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_rewards ctxt contract cycle + >>=? fun old_amount -> + Tez_repr.(old_amount +? amount) + >>?= fun new_amount -> + Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount + >>= fun ctxt -> + Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >|= ok + +let freeze_rewards ctxt delegate amount = + let ({Level_repr.cycle; _} : Level_repr.t) = Level_storage.current ctxt in + credit_frozen_rewards ctxt delegate cycle amount + +let burn_rewards ctxt delegate cycle amount = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_rewards ctxt contract cycle + >>=? fun old_amount -> + let new_amount = + match Tez_repr.(old_amount -? amount) with + | Error _ -> + Tez_repr.zero + | Ok new_amount -> + new_amount + in + Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount + >|= ok + +let unfreeze ctxt delegate cycle = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_deposit ctxt contract cycle + >>=? fun deposit -> + get_frozen_fees ctxt contract cycle + >>=? fun fees -> + get_frozen_rewards ctxt contract cycle + >>=? fun rewards -> + Storage.Contract.Balance.get ctxt contract + >>=? fun balance -> + Tez_repr.(deposit +? fees) + >>?= fun unfrozen_amount -> + Tez_repr.(unfrozen_amount +? rewards) + >>?= fun unfrozen_amount -> + Tez_repr.(balance +? unfrozen_amount) + >>?= fun balance -> + Storage.Contract.Balance.set ctxt contract balance + >>=? fun ctxt -> + Roll_storage.Delegate.add_amount ctxt delegate rewards + >>=? fun ctxt -> + Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle + >>= fun ctxt -> + Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle + >>= fun ctxt -> + Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle + >|= fun ctxt -> + ok + ( ctxt, + cleanup_balance_updates + [ (Deposits (delegate, cycle), Debited deposit); + (Fees (delegate, cycle), Debited fees); + (Rewards (delegate, cycle), Debited rewards); + ( Contract (Contract_repr.implicit_contract delegate), + Credited unfrozen_amount ) ] ) + +let cycle_end ctxt last_cycle unrevealed = + let preserved = Constants_storage.preserved_cycles ctxt in + ( match Cycle_repr.pred last_cycle with + | None -> + return (ctxt, []) + | Some revealed_cycle -> + fold_left_s + (fun (ctxt, balance_updates) (u : Nonce_storage.unrevealed) -> + burn_fees ctxt u.delegate revealed_cycle u.fees + >>=? fun ctxt -> + burn_rewards ctxt u.delegate revealed_cycle u.rewards + >|=? fun ctxt -> + let bus = + [ (Fees (u.delegate, revealed_cycle), Debited u.fees); + (Rewards (u.delegate, revealed_cycle), Debited u.rewards) ] + in + (ctxt, bus @ balance_updates)) + (ctxt, []) + unrevealed ) + >>=? fun (ctxt, balance_updates) -> + match Cycle_repr.sub last_cycle preserved with + | None -> + return (ctxt, balance_updates, []) + | Some unfrozen_cycle -> + Storage.Delegates_with_frozen_balance.fold + (ctxt, unfrozen_cycle) + ~init:(Ok (ctxt, balance_updates)) + ~f:(fun delegate acc -> + acc + >>?= fun (ctxt, bus) -> + unfreeze ctxt delegate unfrozen_cycle + >|=? fun (ctxt, balance_updates) -> (ctxt, balance_updates @ bus)) + >>=? fun (ctxt, balance_updates) -> + Storage.Delegates_with_frozen_balance.clear (ctxt, unfrozen_cycle) + >>= fun ctxt -> + Storage.Active_delegates_with_rolls.fold + ctxt + ~init:(Ok (ctxt, [])) + ~f:(fun delegate acc -> + acc + >>?= fun (ctxt, deactivated) -> + Storage.Contract.Delegate_desactivation.get + ctxt + (Contract_repr.implicit_contract delegate) + >>=? fun cycle -> + if Cycle_repr.(cycle <= last_cycle) then + Roll_storage.Delegate.set_inactive ctxt delegate + >|=? fun ctxt -> (ctxt, delegate :: deactivated) + else return (ctxt, deactivated)) + >|=? fun (ctxt, deactivated) -> (ctxt, balance_updates, deactivated) + +let punish ctxt delegate cycle = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_deposit ctxt contract cycle + >>=? fun deposit -> + get_frozen_fees ctxt contract cycle + >>=? fun fees -> + get_frozen_rewards ctxt contract cycle + >>=? fun rewards -> + Roll_storage.Delegate.remove_amount ctxt delegate deposit + >>=? fun ctxt -> + Roll_storage.Delegate.remove_amount ctxt delegate fees + >>=? fun ctxt -> + (* Rewards are not accounted in the delegate's rolls yet... *) + Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle + >>= fun ctxt -> + Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle + >>= fun ctxt -> + Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle + >|= fun ctxt -> ok (ctxt, {deposit; fees; rewards}) + +let has_frozen_balance ctxt delegate cycle = + let contract = Contract_repr.implicit_contract delegate in + get_frozen_deposit ctxt contract cycle + >>=? fun deposit -> + if Tez_repr.(deposit <> zero) then return_true + else + get_frozen_fees ctxt contract cycle + >>=? fun fees -> + if Tez_repr.(fees <> zero) then return_true + else + get_frozen_rewards ctxt contract cycle + >|=? fun rewards -> Tez_repr.(rewards <> zero) + +let frozen_balance_by_cycle_encoding = + let open Data_encoding in + conv + Cycle_repr.Map.bindings + (List.fold_left + (fun m (c, b) -> Cycle_repr.Map.add c b m) + Cycle_repr.Map.empty) + (list + (merge_objs + (obj1 (req "cycle" Cycle_repr.encoding)) + frozen_balance_encoding)) + +let empty_frozen_balance = + {deposit = Tez_repr.zero; fees = Tez_repr.zero; rewards = Tez_repr.zero} + +let frozen_balance_by_cycle ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + let map = Cycle_repr.Map.empty in + Storage.Contract.Frozen_deposits.fold + (ctxt, contract) + ~init:map + ~f:(fun cycle amount map -> + Lwt.return + (Cycle_repr.Map.add + cycle + {empty_frozen_balance with deposit = amount} + map)) + >>= fun map -> + Storage.Contract.Frozen_fees.fold + (ctxt, contract) + ~init:map + ~f:(fun cycle amount map -> + let balance = + match Cycle_repr.Map.find_opt cycle map with + | None -> + empty_frozen_balance + | Some balance -> + balance + in + Lwt.return (Cycle_repr.Map.add cycle {balance with fees = amount} map)) + >>= fun map -> + Storage.Contract.Frozen_rewards.fold + (ctxt, contract) + ~init:map + ~f:(fun cycle amount map -> + let balance = + match Cycle_repr.Map.find_opt cycle map with + | None -> + empty_frozen_balance + | Some balance -> + balance + in + Lwt.return (Cycle_repr.Map.add cycle {balance with rewards = amount} map)) + +let frozen_balance ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + let balance = Ok Tez_repr.zero in + Storage.Contract.Frozen_deposits.fold + (ctxt, contract) + ~init:balance + ~f:(fun _cycle amount acc -> + Lwt.return (acc >>? fun acc -> Tez_repr.(acc +? amount))) + >>= fun balance -> + Storage.Contract.Frozen_fees.fold + (ctxt, contract) + ~init:balance + ~f:(fun _cycle amount acc -> + Lwt.return (acc >>? fun acc -> Tez_repr.(acc +? amount))) + >>= fun balance -> + Storage.Contract.Frozen_rewards.fold + (ctxt, contract) + ~init:balance + ~f:(fun _cycle amount acc -> + Lwt.return (acc >>? fun acc -> Tez_repr.(acc +? amount))) + +let full_balance ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + frozen_balance ctxt delegate + >>=? fun frozen_balance -> + Storage.Contract.Balance.get ctxt contract + >>=? fun balance -> Lwt.return Tez_repr.(frozen_balance +? balance) + +let deactivated = Roll_storage.Delegate.is_inactive + +let grace_period ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + Storage.Contract.Delegate_desactivation.get ctxt contract + +let staking_balance ctxt delegate = + let token_per_rolls = Constants_storage.tokens_per_roll ctxt in + Roll_storage.get_rolls ctxt delegate + >>=? fun rolls -> + Roll_storage.get_change ctxt delegate + >>=? fun change -> + let rolls = Int64.of_int (List.length rolls) in + Lwt.return + ( Tez_repr.(token_per_rolls *? rolls) + >>? fun balance -> Tez_repr.(balance +? change) ) + +let delegated_balance ctxt delegate = + let contract = Contract_repr.implicit_contract delegate in + staking_balance ctxt delegate + >>=? fun staking_balance -> + Storage.Contract.Balance.get ctxt contract + >>= fun self_staking_balance -> + Storage.Contract.Frozen_deposits.fold + (ctxt, contract) + ~init:self_staking_balance + ~f:(fun _cycle amount acc -> + Lwt.return (acc >>? fun acc -> Tez_repr.(acc +? amount))) + >>= fun self_staking_balance -> + Storage.Contract.Frozen_fees.fold + (ctxt, contract) + ~init:self_staking_balance + ~f:(fun _cycle amount acc -> + Lwt.return (acc >>? fun acc -> Tez_repr.(acc +? amount))) + >>=? fun self_staking_balance -> + Lwt.return Tez_repr.(staking_balance -? self_staking_balance) + +let fold = Storage.Delegates.fold + +let list = Storage.Delegates.elements diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/delegate_storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/delegate_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..2ad8303b8ead98e476d2fbc3c00d4f23e0773be5 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/delegate_storage.mli @@ -0,0 +1,191 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Places where tezzies can be found in the ledger's state. *) +type balance = + | Contract of Contract_repr.t + | Rewards of Signature.Public_key_hash.t * Cycle_repr.t + | Fees of Signature.Public_key_hash.t * Cycle_repr.t + | Deposits of Signature.Public_key_hash.t * Cycle_repr.t + +(** A credit or debit of tezzies to a balance. *) +type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t + +(** A list of balance updates. Duplicates may happen. *) +type balance_updates = (balance * balance_update) list + +val balance_updates_encoding : balance_updates Data_encoding.t + +(** Remove zero-valued balances from a list of updates. *) +val cleanup_balance_updates : balance_updates -> balance_updates + +type frozen_balance = { + deposit : Tez_repr.t; + fees : Tez_repr.t; + rewards : Tez_repr.t; +} + +(** Allow to register a delegate when creating an account. *) +val init : + Raw_context.t -> + Contract_repr.t -> + Signature.Public_key_hash.t -> + Raw_context.t tzresult Lwt.t + +(** Cleanup delegation when deleting a contract. *) +val remove : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t + +(** Reading the current delegate of a contract. *) +val get : + Raw_context.t -> + Contract_repr.t -> + Signature.Public_key_hash.t option tzresult Lwt.t + +val registered : + Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t + +(** Updating the delegate of a contract. + + When calling this function on an "implicit contract" and setting + the delegate to the contract manager registers it as a delegate. One + cannot unregister a delegate for now. The associate contract is now + 'undeletable'. *) +val set : + Raw_context.t -> + Contract_repr.t -> + Signature.Public_key_hash.t option -> + Raw_context.t tzresult Lwt.t + +type error += + | No_deletion of Signature.Public_key_hash.t (* `Permanent *) + | Active_delegate (* `Temporary *) + | Current_delegate (* `Temporary *) + | Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *) + | Balance_too_low_for_deposit of { + delegate : Signature.Public_key_hash.t; + deposit : Tez_repr.t; + balance : Tez_repr.t; + } + +(* `Temporary *) + +(** Iterate on all registered delegates. *) +val fold : + Raw_context.t -> + init:'a -> + f:(Signature.Public_key_hash.t -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + +(** List all registered delegates. *) +val list : Raw_context.t -> Signature.Public_key_hash.t list Lwt.t + +(** Various functions to 'freeze' tokens. A frozen 'deposit' keeps its + associated rolls. When frozen, 'fees' may trigger new rolls + allocation. Rewards won't trigger new rolls allocation until + unfrozen. *) +val freeze_deposit : + Raw_context.t -> + Signature.Public_key_hash.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t + +val freeze_fees : + Raw_context.t -> + Signature.Public_key_hash.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t + +val freeze_rewards : + Raw_context.t -> + Signature.Public_key_hash.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t + +(** Trigger the context maintenance at the end of cycle 'n', i.e.: + unfreeze deposit/fees/rewards from 'n - preserved_cycle' ; punish the + provided unrevealed seeds (typically seed from cycle 'n - 1'). + Returns a list of account with the amount that was unfrozen for each + and the list of deactivated delegates. *) +val cycle_end : + Raw_context.t -> + Cycle_repr.t -> + Nonce_storage.unrevealed list -> + (Raw_context.t * balance_updates * Signature.Public_key_hash.t list) tzresult + Lwt.t + +(** Burn all then frozen deposit/fees/rewards for a delegate at a given + cycle. Returns the burned amounts. *) +val punish : + Raw_context.t -> + Signature.Public_key_hash.t -> + Cycle_repr.t -> + (Raw_context.t * frozen_balance) tzresult Lwt.t + +(** Has the given key some frozen tokens in its implicit contract? *) +val has_frozen_balance : + Raw_context.t -> + Signature.Public_key_hash.t -> + Cycle_repr.t -> + bool tzresult Lwt.t + +(** Returns the amount of frozen deposit, fees and rewards associated + to a given delegate. *) +val frozen_balance : + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t + +val frozen_balance_encoding : frozen_balance Data_encoding.t + +val frozen_balance_by_cycle_encoding : + frozen_balance Cycle_repr.Map.t Data_encoding.t + +(** Returns the amount of frozen deposit, fees and rewards associated + to a given delegate, indexed by the cycle by which at the end the + balance will be unfrozen. *) +val frozen_balance_by_cycle : + Raw_context.t -> + Signature.Public_key_hash.t -> + frozen_balance Cycle_repr.Map.t Lwt.t + +(** Returns the full 'balance' of the implicit contract associated to + a given key, i.e. the sum of the spendable balance and of the + frozen balance. *) +val full_balance : + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t + +val staking_balance : + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t + +(** Returns the list of contracts (implicit or originated) that delegated towards a given delegate *) +val delegated_contracts : + Raw_context.t -> Signature.Public_key_hash.t -> Contract_repr.t list Lwt.t + +val delegated_balance : + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t + +val deactivated : + Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t + +val grace_period : + Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t tzresult Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/dune b/src/proto_008_PtEdo2Zk/lib_protocol/dune new file mode 120000 index 0000000000000000000000000000000000000000..235c3740ecfc863528ec6353bbff8ea81e3f22e2 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/dune @@ -0,0 +1 @@ +../../lib_protocol_compiler/dune_protocol \ No newline at end of file diff --git a/src/proto_alpha/lib_mempool/dune-project b/src/proto_008_PtEdo2Zk/lib_protocol/dune-project similarity index 52% rename from src/proto_alpha/lib_mempool/dune-project rename to src/proto_008_PtEdo2Zk/lib_protocol/dune-project index bc94cade5507d0c943485da90119539302a6031c..27a2b60805676a5ae75598ee11b3bad39b723fe2 100644 --- a/src/proto_alpha/lib_mempool/dune-project +++ b/src/proto_008_PtEdo2Zk/lib_protocol/dune-project @@ -1,3 +1,3 @@ (lang dune 2.0) (formatting (enabled_for ocaml)) -(name tezos-mempool-alpha) +(name tezos-embedded-protocol-008-PtEdo2Zk) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/dune.inc b/src/proto_008_PtEdo2Zk/lib_protocol/dune.inc new file mode 100644 index 0000000000000000000000000000000000000000..2683fea268aeca125f48b0b5198ff3420536810d --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/dune.inc @@ -0,0 +1,502 @@ + + +; +; /!\ /!\ Do not modify this file /!\ /!\ +; +; but the original template in `tezos-protocol-compiler` +; + + +(rule + (targets environment.ml) + (action + (write-file %{targets} + "module Name = struct let name = \"008-PtEdo2Zk\" end +include Tezos_protocol_environment.MakeV1(Name)() +module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end +"))) + +(rule + (targets registerer.ml) + (deps + misc.mli misc.ml + storage_description.mli storage_description.ml + state_hash.ml + nonce_hash.ml + script_expr_hash.ml + contract_hash.ml + blinded_public_key_hash.mli blinded_public_key_hash.ml + tez_repr.mli tez_repr.ml + period_repr.mli period_repr.ml + time_repr.mli time_repr.ml + fixed_point_repr.mli fixed_point_repr.ml + gas_limit_repr.mli gas_limit_repr.ml + constants_repr.ml + fitness_repr.ml + raw_level_repr.mli raw_level_repr.ml + cycle_repr.mli cycle_repr.ml + level_repr.mli level_repr.ml + seed_repr.mli seed_repr.ml + voting_period_repr.mli voting_period_repr.ml + script_int_repr.mli script_int_repr.ml + script_timestamp_repr.mli script_timestamp_repr.ml + michelson_v1_primitives.mli michelson_v1_primitives.ml + script_repr.mli script_repr.ml + contract_repr.mli contract_repr.ml + roll_repr.mli roll_repr.ml + vote_repr.mli vote_repr.ml + block_header_repr.mli block_header_repr.ml + operation_repr.mli operation_repr.ml + manager_repr.mli manager_repr.ml + commitment_repr.mli commitment_repr.ml + parameters_repr.mli parameters_repr.ml + sapling_repr.ml + lazy_storage_kind.mli lazy_storage_kind.ml + raw_context.mli raw_context.ml + storage_costs.mli storage_costs.ml + storage_sigs.ml + storage_functors.mli storage_functors.ml + storage.mli storage.ml + constants_storage.ml + level_storage.mli level_storage.ml + nonce_storage.mli nonce_storage.ml + seed_storage.mli seed_storage.ml + roll_storage.mli roll_storage.ml + delegate_storage.mli delegate_storage.ml + sapling_storage.ml + lazy_storage_diff.mli lazy_storage_diff.ml + contract_storage.mli contract_storage.ml + bootstrap_storage.mli bootstrap_storage.ml + fitness_storage.ml + voting_period_storage.mli voting_period_storage.ml + vote_storage.mli vote_storage.ml + commitment_storage.mli commitment_storage.ml + init_storage.ml + fees_storage.mli fees_storage.ml + sapling_validator.ml + alpha_context.mli alpha_context.ml + script_typed_ir.ml + script_tc_errors.ml + michelson_v1_gas.mli michelson_v1_gas.ml + script_ir_annot.mli script_ir_annot.ml + script_ir_translator.mli script_ir_translator.ml + script_tc_errors_registration.ml + script_interpreter.mli script_interpreter.ml + baking.mli baking.ml + amendment.mli amendment.ml + apply_results.mli apply_results.ml + apply.ml + services_registration.ml + constants_services.mli constants_services.ml + sapling_services.ml + contract_services.mli contract_services.ml + delegate_services.mli delegate_services.ml + helpers_services.mli helpers_services.ml + voting_services.mli voting_services.ml + alpha_services.mli alpha_services.ml + main.mli main.ml + (:src_dir TEZOS_PROTOCOL)) + (action + (with-stdout-to %{targets} + (chdir %{workspace_root} (run %{bin:tezos-embedded-protocol-packer} "%{src_dir}" "008_PtEdo2Zk"))))) + +(rule + (targets functor.ml) + (deps + misc.mli misc.ml + storage_description.mli storage_description.ml + state_hash.ml + nonce_hash.ml + script_expr_hash.ml + contract_hash.ml + blinded_public_key_hash.mli blinded_public_key_hash.ml + tez_repr.mli tez_repr.ml + period_repr.mli period_repr.ml + time_repr.mli time_repr.ml + fixed_point_repr.mli fixed_point_repr.ml + gas_limit_repr.mli gas_limit_repr.ml + constants_repr.ml + fitness_repr.ml + raw_level_repr.mli raw_level_repr.ml + cycle_repr.mli cycle_repr.ml + level_repr.mli level_repr.ml + seed_repr.mli seed_repr.ml + voting_period_repr.mli voting_period_repr.ml + script_int_repr.mli script_int_repr.ml + script_timestamp_repr.mli script_timestamp_repr.ml + michelson_v1_primitives.mli michelson_v1_primitives.ml + script_repr.mli script_repr.ml + contract_repr.mli contract_repr.ml + roll_repr.mli roll_repr.ml + vote_repr.mli vote_repr.ml + block_header_repr.mli block_header_repr.ml + operation_repr.mli operation_repr.ml + manager_repr.mli manager_repr.ml + commitment_repr.mli commitment_repr.ml + parameters_repr.mli parameters_repr.ml + sapling_repr.ml + lazy_storage_kind.mli lazy_storage_kind.ml + raw_context.mli raw_context.ml + storage_costs.mli storage_costs.ml + storage_sigs.ml + storage_functors.mli storage_functors.ml + storage.mli storage.ml + constants_storage.ml + level_storage.mli level_storage.ml + nonce_storage.mli nonce_storage.ml + seed_storage.mli seed_storage.ml + roll_storage.mli roll_storage.ml + delegate_storage.mli delegate_storage.ml + sapling_storage.ml + lazy_storage_diff.mli lazy_storage_diff.ml + contract_storage.mli contract_storage.ml + bootstrap_storage.mli bootstrap_storage.ml + fitness_storage.ml + voting_period_storage.mli voting_period_storage.ml + vote_storage.mli vote_storage.ml + commitment_storage.mli commitment_storage.ml + init_storage.ml + fees_storage.mli fees_storage.ml + sapling_validator.ml + alpha_context.mli alpha_context.ml + script_typed_ir.ml + script_tc_errors.ml + michelson_v1_gas.mli michelson_v1_gas.ml + script_ir_annot.mli script_ir_annot.ml + script_ir_translator.mli script_ir_translator.ml + script_tc_errors_registration.ml + script_interpreter.mli script_interpreter.ml + baking.mli baking.ml + amendment.mli amendment.ml + apply_results.mli apply_results.ml + apply.ml + services_registration.ml + constants_services.mli constants_services.ml + sapling_services.ml + contract_services.mli contract_services.ml + delegate_services.mli delegate_services.ml + helpers_services.mli helpers_services.ml + voting_services.mli voting_services.ml + alpha_services.mli alpha_services.ml + main.mli main.ml + (:src_dir TEZOS_PROTOCOL)) + (action (with-stdout-to %{targets} + (chdir %{workspace_root} + (run %{bin:tezos-protocol-compiler.tezos-protocol-packer} %{src_dir}))))) + +(rule + (targets protocol.ml) + (deps + misc.mli misc.ml + storage_description.mli storage_description.ml + state_hash.ml + nonce_hash.ml + script_expr_hash.ml + contract_hash.ml + blinded_public_key_hash.mli blinded_public_key_hash.ml + tez_repr.mli tez_repr.ml + period_repr.mli period_repr.ml + time_repr.mli time_repr.ml + fixed_point_repr.mli fixed_point_repr.ml + gas_limit_repr.mli gas_limit_repr.ml + constants_repr.ml + fitness_repr.ml + raw_level_repr.mli raw_level_repr.ml + cycle_repr.mli cycle_repr.ml + level_repr.mli level_repr.ml + seed_repr.mli seed_repr.ml + voting_period_repr.mli voting_period_repr.ml + script_int_repr.mli script_int_repr.ml + script_timestamp_repr.mli script_timestamp_repr.ml + michelson_v1_primitives.mli michelson_v1_primitives.ml + script_repr.mli script_repr.ml + contract_repr.mli contract_repr.ml + roll_repr.mli roll_repr.ml + vote_repr.mli vote_repr.ml + block_header_repr.mli block_header_repr.ml + operation_repr.mli operation_repr.ml + manager_repr.mli manager_repr.ml + commitment_repr.mli commitment_repr.ml + parameters_repr.mli parameters_repr.ml + sapling_repr.ml + lazy_storage_kind.mli lazy_storage_kind.ml + raw_context.mli raw_context.ml + storage_costs.mli storage_costs.ml + storage_sigs.ml + storage_functors.mli storage_functors.ml + storage.mli storage.ml + constants_storage.ml + level_storage.mli level_storage.ml + nonce_storage.mli nonce_storage.ml + seed_storage.mli seed_storage.ml + roll_storage.mli roll_storage.ml + delegate_storage.mli delegate_storage.ml + sapling_storage.ml + lazy_storage_diff.mli lazy_storage_diff.ml + contract_storage.mli contract_storage.ml + bootstrap_storage.mli bootstrap_storage.ml + fitness_storage.ml + voting_period_storage.mli voting_period_storage.ml + vote_storage.mli vote_storage.ml + commitment_storage.mli commitment_storage.ml + init_storage.ml + fees_storage.mli fees_storage.ml + sapling_validator.ml + alpha_context.mli alpha_context.ml + script_typed_ir.ml + script_tc_errors.ml + michelson_v1_gas.mli michelson_v1_gas.ml + script_ir_annot.mli script_ir_annot.ml + script_ir_translator.mli script_ir_translator.ml + script_tc_errors_registration.ml + script_interpreter.mli script_interpreter.ml + baking.mli baking.ml + amendment.mli amendment.ml + apply_results.mli apply_results.ml + apply.ml + services_registration.ml + constants_services.mli constants_services.ml + sapling_services.ml + contract_services.mli contract_services.ml + delegate_services.mli delegate_services.ml + helpers_services.mli helpers_services.ml + voting_services.mli voting_services.ml + alpha_services.mli alpha_services.ml + main.mli main.ml) + (action + (write-file %{targets} + "module Environment = Tezos_protocol_environment_008_PtEdo2Zk.Environment +let hash = Tezos_crypto.Protocol_hash.of_b58check_exn \"PtEdo2ZkT9oKpimTah6x2embF25oss54njMuPzkJTEi5RqfdZFA\" +let name = Environment.Name.name +include Tezos_raw_protocol_008_PtEdo2Zk +include Tezos_raw_protocol_008_PtEdo2Zk.Main +"))) + +(library + (name tezos_protocol_environment_008_PtEdo2Zk) + (public_name tezos-protocol-008-PtEdo2Zk.environment) + (library_flags (:standard -linkall)) + (libraries tezos-protocol-environment) + (modules Environment)) + +(library + (name tezos_raw_protocol_008_PtEdo2Zk) + (public_name tezos-protocol-008-PtEdo2Zk.raw) + (libraries tezos_protocol_environment_008_PtEdo2Zk) + (library_flags (:standard -linkall)) + (flags (:standard -nopervasives -nostdlib + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 + -warn-error +a + -open Tezos_protocol_environment_008_PtEdo2Zk__Environment + -open Pervasives + -open Error_monad)) + (modules + Misc + Storage_description + State_hash + Nonce_hash + Script_expr_hash + Contract_hash + Blinded_public_key_hash + Tez_repr + Period_repr + Time_repr + Fixed_point_repr + Gas_limit_repr + Constants_repr + Fitness_repr + Raw_level_repr + Cycle_repr + Level_repr + Seed_repr + Voting_period_repr + Script_int_repr + Script_timestamp_repr + Michelson_v1_primitives + Script_repr + Contract_repr + Roll_repr + Vote_repr + Block_header_repr + Operation_repr + Manager_repr + Commitment_repr + Parameters_repr + Sapling_repr + Lazy_storage_kind + Raw_context + Storage_costs + Storage_sigs + Storage_functors + Storage + Constants_storage + Level_storage + Nonce_storage + Seed_storage + Roll_storage + Delegate_storage + Sapling_storage + Lazy_storage_diff + Contract_storage + Bootstrap_storage + Fitness_storage + Voting_period_storage + Vote_storage + Commitment_storage + Init_storage + Fees_storage + Sapling_validator + Alpha_context + Script_typed_ir + Script_tc_errors + Michelson_v1_gas + Script_ir_annot + Script_ir_translator + Script_tc_errors_registration + Script_interpreter + Baking + Amendment + Apply_results + Apply + Services_registration + Constants_services + Sapling_services + Contract_services + Delegate_services + Helpers_services + Voting_services + Alpha_services + Main)) + +(install + (section lib) + (package tezos-protocol-008-PtEdo2Zk) + (files (TEZOS_PROTOCOL as raw/TEZOS_PROTOCOL))) + +(library + (name tezos_protocol_008_PtEdo2Zk) + (public_name tezos-protocol-008-PtEdo2Zk) + (libraries + tezos-protocol-environment + tezos-protocol-environment-sigs + tezos_raw_protocol_008_PtEdo2Zk) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" + -warn-error "+a" + -nopervasives) + (modules Protocol)) + +(library + (name tezos_protocol_008_PtEdo2Zk_functor) + (public_name tezos-protocol-functor-008-PtEdo2Zk) + (libraries + tezos-protocol-environment + tezos-protocol-environment-sigs + tezos-protocol-008-PtEdo2Zk.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" + -warn-error "+a" + -nopervasives) + (modules Functor)) + +(library + (name tezos_embedded_protocol_008_PtEdo2Zk) + (public_name tezos-embedded-protocol-008-PtEdo2Zk) + (library_flags (:standard -linkall)) + (libraries tezos-protocol-008-PtEdo2Zk + tezos-protocol-updater + tezos-protocol-environment) + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 + -warn-error +a)) + (modules Registerer)) + +(rule + (alias runtest_compile_protocol) + (deps + misc.mli misc.ml + storage_description.mli storage_description.ml + state_hash.ml + nonce_hash.ml + script_expr_hash.ml + contract_hash.ml + blinded_public_key_hash.mli blinded_public_key_hash.ml + tez_repr.mli tez_repr.ml + period_repr.mli period_repr.ml + time_repr.mli time_repr.ml + fixed_point_repr.mli fixed_point_repr.ml + gas_limit_repr.mli gas_limit_repr.ml + constants_repr.ml + fitness_repr.ml + raw_level_repr.mli raw_level_repr.ml + cycle_repr.mli cycle_repr.ml + level_repr.mli level_repr.ml + seed_repr.mli seed_repr.ml + voting_period_repr.mli voting_period_repr.ml + script_int_repr.mli script_int_repr.ml + script_timestamp_repr.mli script_timestamp_repr.ml + michelson_v1_primitives.mli michelson_v1_primitives.ml + script_repr.mli script_repr.ml + contract_repr.mli contract_repr.ml + roll_repr.mli roll_repr.ml + vote_repr.mli vote_repr.ml + block_header_repr.mli block_header_repr.ml + operation_repr.mli operation_repr.ml + manager_repr.mli manager_repr.ml + commitment_repr.mli commitment_repr.ml + parameters_repr.mli parameters_repr.ml + sapling_repr.ml + lazy_storage_kind.mli lazy_storage_kind.ml + raw_context.mli raw_context.ml + storage_costs.mli storage_costs.ml + storage_sigs.ml + storage_functors.mli storage_functors.ml + storage.mli storage.ml + constants_storage.ml + level_storage.mli level_storage.ml + nonce_storage.mli nonce_storage.ml + seed_storage.mli seed_storage.ml + roll_storage.mli roll_storage.ml + delegate_storage.mli delegate_storage.ml + sapling_storage.ml + lazy_storage_diff.mli lazy_storage_diff.ml + contract_storage.mli contract_storage.ml + bootstrap_storage.mli bootstrap_storage.ml + fitness_storage.ml + voting_period_storage.mli voting_period_storage.ml + vote_storage.mli vote_storage.ml + commitment_storage.mli commitment_storage.ml + init_storage.ml + fees_storage.mli fees_storage.ml + sapling_validator.ml + alpha_context.mli alpha_context.ml + script_typed_ir.ml + script_tc_errors.ml + michelson_v1_gas.mli michelson_v1_gas.ml + script_ir_annot.mli script_ir_annot.ml + script_ir_translator.mli script_ir_translator.ml + script_tc_errors_registration.ml + script_interpreter.mli script_interpreter.ml + baking.mli baking.ml + amendment.mli amendment.ml + apply_results.mli apply_results.ml + apply.ml + services_registration.ml + constants_services.mli constants_services.ml + sapling_services.ml + contract_services.mli contract_services.ml + delegate_services.mli delegate_services.ml + helpers_services.mli helpers_services.ml + voting_services.mli voting_services.ml + alpha_services.mli alpha_services.ml + main.mli main.ml + (:src_dir TEZOS_PROTOCOL)) + (action (run %{bin:tezos-protocol-compiler} .))) + +(rule + (alias runtest_sandbox) + (deps .tezos_protocol_008_PtEdo2Zk.objs/native/tezos_protocol_008_PtEdo2Zk.cmx) + (action (progn))) + +(rule + (alias runtest) + (package tezos-protocol-008-PtEdo2Zk) + (deps (alias runtest_sandbox)) + (action (progn))) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/fees_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/fees_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..ddd82707c321e9697eda35863457b0354a79506b --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/fees_storage.ml @@ -0,0 +1,121 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += Cannot_pay_storage_fee (* `Temporary *) + +type error += Operation_quota_exceeded (* `Temporary *) + +type error += Storage_limit_too_high (* `Permanent *) + +let () = + let open Data_encoding in + register_error_kind + `Temporary + ~id:"contract.cannot_pay_storage_fee" + ~title:"Cannot pay storage fee" + ~description:"The storage fee is higher than the contract balance" + ~pp:(fun ppf () -> Format.fprintf ppf "Cannot pay storage storage fee") + Data_encoding.empty + (function Cannot_pay_storage_fee -> Some () | _ -> None) + (fun () -> Cannot_pay_storage_fee) ; + register_error_kind + `Temporary + ~id:"storage_exhausted.operation" + ~title:"Storage quota exceeded for the operation" + ~description: + "A script or one of its callee wrote more bytes than the operation said \ + it would" + Data_encoding.empty + (function Operation_quota_exceeded -> Some () | _ -> None) + (fun () -> Operation_quota_exceeded) ; + register_error_kind + `Permanent + ~id:"storage_limit_too_high" + ~title:"Storage limit out of protocol hard bounds" + ~description:"A transaction tried to exceed the hard limit on storage" + empty + (function Storage_limit_too_high -> Some () | _ -> None) + (fun () -> Storage_limit_too_high) + +let origination_burn c = + let origination_size = Constants_storage.origination_size c in + let cost_per_byte = Constants_storage.cost_per_byte c in + (* the origination burn, measured in bytes *) + Tez_repr.(cost_per_byte *? Int64.of_int origination_size) + >|? fun to_be_paid -> + (Raw_context.update_allocated_contracts_count c, to_be_paid) + +let record_paid_storage_space c contract = + Contract_storage.used_storage_space c contract + >>=? fun size -> + Contract_storage.set_paid_storage_space_and_return_fees_to_pay + c + contract + size + >>=? fun (to_be_paid, c) -> + let c = Raw_context.update_storage_space_to_pay c to_be_paid in + let cost_per_byte = Constants_storage.cost_per_byte c in + Lwt.return + ( Tez_repr.(cost_per_byte *? Z.to_int64 to_be_paid) + >|? fun to_burn -> (c, size, to_be_paid, to_burn) ) + +let burn_storage_fees c ~storage_limit ~payer = + let origination_size = Constants_storage.origination_size c in + let (c, storage_space_to_pay, allocated_contracts) = + Raw_context.clear_storage_space_to_pay c + in + let storage_space_for_allocated_contracts = + Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size) + in + let consumed = + Z.add storage_space_to_pay storage_space_for_allocated_contracts + in + let remaining = Z.sub storage_limit consumed in + if Compare.Z.(remaining < Z.zero) then fail Operation_quota_exceeded + else + let cost_per_byte = Constants_storage.cost_per_byte c in + Tez_repr.(cost_per_byte *? Z.to_int64 consumed) + >>?= fun to_burn -> + (* Burning the fees... *) + if Tez_repr.(to_burn = Tez_repr.zero) then + (* If the payer was was deleted by transferring all its balance, and no space was used, + burning zero would fail *) + return c + else + trace + Cannot_pay_storage_fee + ( Contract_storage.must_exist c payer + >>=? fun () -> Contract_storage.spend c payer to_burn ) + +let check_storage_limit c ~storage_limit = + if + Compare.Z.( + storage_limit + > (Raw_context.constants c).hard_storage_limit_per_operation) + || Compare.Z.(storage_limit < Z.zero) + then error Storage_limit_too_high + else ok_unit + +let start_counting_storage_fees c = Raw_context.init_storage_space_to_pay c diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/fees_storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/fees_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..8e6a417c63932313b8bd0883666726b3ce43527e --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/fees_storage.mli @@ -0,0 +1,49 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += Cannot_pay_storage_fee (* `Temporary *) + +type error += Operation_quota_exceeded (* `Temporary *) + +type error += Storage_limit_too_high (* `Permanent *) + +(** Does not burn, only adds the burn to storage space to be paid *) +val origination_burn : Raw_context.t -> (Raw_context.t * Tez_repr.t) tzresult + +(** The returned Tez quantity is for logging purpose only *) +val record_paid_storage_space : + Raw_context.t -> + Contract_repr.t -> + (Raw_context.t * Z.t * Z.t * Tez_repr.t) tzresult Lwt.t + +val check_storage_limit : Raw_context.t -> storage_limit:Z.t -> unit tzresult + +val start_counting_storage_fees : Raw_context.t -> Raw_context.t + +val burn_storage_fees : + Raw_context.t -> + storage_limit:Z.t -> + payer:Contract_repr.t -> + Raw_context.t tzresult Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/fitness_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/fitness_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..cbcb5d1cd2f413dadea702308e7c9a938098eb42 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/fitness_repr.ml @@ -0,0 +1,62 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += Invalid_fitness (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"invalid_fitness" + ~title:"Invalid fitness" + ~description:"Fitness representation should be exactly 8 bytes long." + ~pp:(fun ppf () -> Format.fprintf ppf "Invalid fitness") + Data_encoding.empty + (function Invalid_fitness -> Some () | _ -> None) + (fun () -> Invalid_fitness) + +let int64_to_bytes i = + let b = Bytes.make 8 '0' in + TzEndian.set_int64 b 0 i ; b + +let int64_of_bytes b = + if Compare.Int.(Bytes.length b <> 8) then error Invalid_fitness + else ok (TzEndian.get_int64 b 0) + +let from_int64 fitness = + [Bytes.of_string Constants_repr.version_number; int64_to_bytes fitness] + +let to_int64 = function + | [version; fitness] + when Compare.String.( + Bytes.to_string version = Constants_repr.version_number) -> + int64_of_bytes fitness + | [version; _fitness (* ignored since higher version takes priority *)] + when Compare.String.( + Bytes.to_string version = Constants_repr.version_number_004) -> + ok 0L + | [] -> + ok 0L + | _ -> + error Invalid_fitness diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/fitness_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/fitness_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..26d1478fc1fd147354fd91b35fe9502bcee8485a --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/fitness_storage.ml @@ -0,0 +1,30 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let current = Raw_context.current_fitness + +let increase ctxt = + let fitness = current ctxt in + Raw_context.set_current_fitness ctxt (Int64.succ fitness) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/fixed_point_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/fixed_point_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..2dbc526e4aa68ee952825b8cf32f0afcc51947f2 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/fixed_point_repr.ml @@ -0,0 +1,176 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type fp_tag (* Tag for fixed point computations *) + +type integral_tag (* Tag for integral computations *) + +module type Safe = sig + type 'a t + + type fp = fp_tag t + + type integral = integral_tag t + + val integral : Z.t -> integral + + val integral_of_int : int -> integral + + val integral_to_z : integral -> Z.t + + val zero : 'a t + + val add : 'a t -> 'a t -> 'a t + + val sub : 'a t -> 'a t -> 'a t + + val ceil : fp -> integral + + val floor : fp -> integral + + val fp : 'a t -> fp + + val ( = ) : 'a t -> 'b t -> bool + + val ( <> ) : 'a t -> 'b t -> bool + + val ( < ) : 'a t -> 'b t -> bool + + val ( <= ) : 'a t -> 'b t -> bool + + val ( >= ) : 'a t -> 'b t -> bool + + val ( > ) : 'a t -> 'b t -> bool + + val compare : 'a t -> 'b t -> int + + val equal : 'a t -> 'b t -> bool + + val max : 'a t -> 'a t -> 'a t + + val min : 'a t -> 'a t -> 'a t + + val pp : Format.formatter -> 'a t -> unit + + val pp_integral : Format.formatter -> integral -> unit + + val n_fp_encoding : fp Data_encoding.t + + val n_integral_encoding : integral Data_encoding.t + + val z_fp_encoding : fp Data_encoding.t + + val z_integral_encoding : integral Data_encoding.t +end + +module type Full = sig + include Safe + + val unsafe_fp : Z.t -> fp +end + +module type Decimals = sig + val decimals : int +end + +module Make (Arg : Decimals) : Full = struct + let () = assert (Compare.Int.(Arg.decimals >= 0)) + + type 'a t = Z.t + + let scaling_factor = Z.pow (Z.of_int 10) Arg.decimals + + type fp = fp_tag t + + type integral = integral_tag t + + let integral z = Z.mul z scaling_factor + + let integral_of_int int = integral @@ Z.of_int int + + let integral_to_z x = Z.ediv x scaling_factor + + let unsafe_fp x = x + + let zero = Z.zero + + let add = Z.add + + let sub = Z.sub + + let ceil x = + let r = Z.erem x scaling_factor in + if Z.equal r Z.zero then x else Z.add x (Z.sub scaling_factor r) + + let floor x = + let r = Z.ediv_rem x scaling_factor |> snd in + if Z.equal r Z.zero then x else Z.sub x r + + let fp x = x + + let ( = ) = Compare.Z.( = ) + + let ( <> ) = Compare.Z.( <> ) + + let ( < ) = Compare.Z.( < ) + + let ( <= ) = Compare.Z.( <= ) + + let ( >= ) = Compare.Z.( >= ) + + let ( > ) = Compare.Z.( > ) + + let compare = Z.compare + + let equal = Z.equal + + let max = Compare.Z.max + + let min = Compare.Z.min + + let pp_positive_fp fmtr milligas = + if Compare.Int.(Arg.decimals <> 3) then + Format.fprintf fmtr "pp_positive_fp: cannot print (decimals <> 3)" + else + let (q, r) = Z.ediv_rem milligas scaling_factor in + if Z.equal r Z.zero then Z.pp_print fmtr q + else Format.fprintf fmtr "%a.%03d" Z.pp_print q (Z.to_int r) + + let pp fmtr fp = + if Compare.Z.(fp >= Z.zero) then pp_positive_fp fmtr fp + else Format.fprintf fmtr "-%a" pp_positive_fp (Z.neg fp) + + let pp_integral = pp + + let n_fp_encoding : fp Data_encoding.t = Data_encoding.n + + let z_fp_encoding : fp Data_encoding.t = Data_encoding.z + + let n_integral_encoding : integral Data_encoding.t = + Data_encoding.conv integral_to_z integral Data_encoding.n + + let z_integral_encoding : integral Data_encoding.t = + Data_encoding.conv integral_to_z integral Data_encoding.z +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/fixed_point_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/fixed_point_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..ede7d603a9a8132eebc410184da4003a931a230e --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/fixed_point_repr.mli @@ -0,0 +1,98 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type fp_tag (* Tag for fixed point computations *) + +type integral_tag (* Tag for integral computations *) + +module type Safe = sig + type 'a t + + type fp = fp_tag t + + type integral = integral_tag t + + val integral : Z.t -> integral + + val integral_of_int : int -> integral + + val integral_to_z : integral -> Z.t + + val zero : 'a t + + val add : 'a t -> 'a t -> 'a t + + val sub : 'a t -> 'a t -> 'a t + + val ceil : fp -> integral + + val floor : fp -> integral + + val fp : 'a t -> fp + + val ( = ) : 'a t -> 'b t -> bool + + val ( <> ) : 'a t -> 'b t -> bool + + val ( < ) : 'a t -> 'b t -> bool + + val ( <= ) : 'a t -> 'b t -> bool + + val ( >= ) : 'a t -> 'b t -> bool + + val ( > ) : 'a t -> 'b t -> bool + + val compare : 'a t -> 'b t -> int + + val equal : 'a t -> 'b t -> bool + + val max : 'a t -> 'a t -> 'a t + + val min : 'a t -> 'a t -> 'a t + + val pp : Format.formatter -> 'a t -> unit + + val pp_integral : Format.formatter -> integral -> unit + + val n_fp_encoding : fp Data_encoding.t + + val n_integral_encoding : integral Data_encoding.t + + val z_fp_encoding : fp Data_encoding.t + + val z_integral_encoding : integral Data_encoding.t +end + +module type Full = sig + include Safe + + val unsafe_fp : Z.t -> fp +end + +module type Decimals = sig + val decimals : int +end + +module Make (Arg : Decimals) : Full diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/gas_limit_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/gas_limit_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..d1fd63281d4fe780291814b2a7f5666574f06fa6 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/gas_limit_repr.ml @@ -0,0 +1,141 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let scaling_factor = 1000 + +let decimals = 3 + +module Arith = Fixed_point_repr.Make (struct + let decimals = decimals +end) + +type t = Unaccounted | Limited of {remaining : Arith.fp} + +type cost = Z.t + +let encoding = + let open Data_encoding in + union + [ case + (Tag 0) + ~title:"Limited" + Arith.z_fp_encoding + (function Limited {remaining} -> Some remaining | _ -> None) + (fun remaining -> Limited {remaining}); + case + (Tag 1) + ~title:"Unaccounted" + (constant "unaccounted") + (function Unaccounted -> Some () | _ -> None) + (fun () -> Unaccounted) ] + +let pp ppf = function + | Unaccounted -> + Format.fprintf ppf "unaccounted" + | Limited {remaining} -> + Format.fprintf ppf "%a units remaining" Arith.pp remaining + +let cost_encoding = Data_encoding.z + +let pp_cost fmt z = Z.pp_print fmt z + +type error += Block_quota_exceeded (* `Temporary *) + +type error += Operation_quota_exceeded (* `Temporary *) + +let allocation_weight = Z.of_int (scaling_factor * 2) + +let step_weight = Z.of_int scaling_factor + +let read_base_weight = Z.of_int (scaling_factor * 100) + +let write_base_weight = Z.of_int (scaling_factor * 160) + +let byte_read_weight = Z.of_int (scaling_factor * 10) + +let byte_written_weight = Z.of_int (scaling_factor * 15) + +let cost_to_milligas (cost : cost) : Arith.fp = Arith.unsafe_fp cost + +let raw_consume block_gas operation_gas cost = + match operation_gas with + | Unaccounted -> + ok (block_gas, Unaccounted) + | Limited {remaining} -> + let gas = cost_to_milligas cost in + if Arith.(gas > zero) then + let remaining = Arith.sub remaining gas in + let block_remaining = Arith.sub block_gas gas in + if Arith.(remaining < zero) then error Operation_quota_exceeded + else if Arith.(block_remaining < zero) then error Block_quota_exceeded + else ok (block_remaining, Limited {remaining}) + else ok (block_gas, operation_gas) + +let raw_check_enough block_gas operation_gas cost = + raw_consume block_gas operation_gas cost + >|? fun (_block_remaining, _remaining) -> () + +let alloc_cost n = Z.mul allocation_weight (Z.succ n) + +let alloc_bytes_cost n = alloc_cost (Z.of_int ((n + 7) / 8)) + +let atomic_step_cost n = n + +let step_cost n = Z.mul step_weight n + +let free = Z.zero + +let read_bytes_cost n = Z.add read_base_weight (Z.mul byte_read_weight n) + +let write_bytes_cost n = Z.add write_base_weight (Z.mul byte_written_weight n) + +let ( +@ ) x y = Z.add x y + +let ( *@ ) x y = Z.mul x y + +let alloc_mbytes_cost n = alloc_cost (Z.of_int 12) +@ alloc_bytes_cost n + +let () = + let open Data_encoding in + register_error_kind + `Temporary + ~id:"gas_exhausted.operation" + ~title:"Gas quota exceeded for the operation" + ~description: + "A script or one of its callee took more time than the operation said \ + it would" + empty + (function Operation_quota_exceeded -> Some () | _ -> None) + (fun () -> Operation_quota_exceeded) ; + register_error_kind + `Temporary + ~id:"gas_exhausted.block" + ~title:"Gas quota exceeded for the block" + ~description: + "The sum of gas consumed by all the operations in the block exceeds the \ + hard gas limit per block" + empty + (function Block_quota_exceeded -> Some () | _ -> None) + (fun () -> Block_quota_exceeded) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/gas_limit_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/gas_limit_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..d4668cae0ee891afb6d33bd381821cd398537228 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/gas_limit_repr.mli @@ -0,0 +1,66 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Arith : Fixed_point_repr.Full + +type t = Unaccounted | Limited of {remaining : Arith.fp} + +val encoding : t Data_encoding.encoding + +val pp : Format.formatter -> t -> unit + +type cost = Z.t + +val cost_encoding : cost Data_encoding.encoding + +val pp_cost : Format.formatter -> cost -> unit + +type error += Block_quota_exceeded (* `Temporary *) + +type error += Operation_quota_exceeded (* `Temporary *) + +val raw_consume : Arith.fp -> t -> cost -> (Arith.fp * t) tzresult + +val raw_check_enough : Arith.fp -> t -> cost -> unit tzresult + +val free : cost + +val atomic_step_cost : Z.t -> cost + +val step_cost : Z.t -> cost + +val alloc_cost : Z.t -> cost + +val alloc_bytes_cost : int -> cost + +val alloc_mbytes_cost : int -> cost + +val read_bytes_cost : Z.t -> cost + +val write_bytes_cost : Z.t -> cost + +val ( *@ ) : Z.t -> cost -> cost + +val ( +@ ) : cost -> cost -> cost diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/helpers_services.ml b/src/proto_008_PtEdo2Zk/lib_protocol/helpers_services.ml new file mode 100644 index 0000000000000000000000000000000000000000..ce2e41ce585778382f468e2602d5344509f52707 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/helpers_services.ml @@ -0,0 +1,1079 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +type error += Cannot_parse_operation (* `Branch *) + +let () = + register_error_kind + `Branch + ~id:"operation.cannot_parse" + ~title:"Cannot parse operation" + ~description:"The operation is ill-formed or for another protocol version" + ~pp:(fun ppf () -> Format.fprintf ppf "The operation cannot be parsed") + Data_encoding.unit + (function Cannot_parse_operation -> Some () | _ -> None) + (fun () -> Cannot_parse_operation) + +let parse_operation (op : Operation.raw) = + match + Data_encoding.Binary.of_bytes Operation.protocol_data_encoding op.proto + with + | Some protocol_data -> + ok {shell = op.shell; protocol_data} + | None -> + error Cannot_parse_operation + +let path = RPC_path.(open_root / "helpers") + +module Scripts = struct + module S = struct + open Data_encoding + + let path = RPC_path.(path / "scripts") + + let run_code_input_encoding = + obj10 + (req "script" Script.expr_encoding) + (req "storage" Script.expr_encoding) + (req "input" Script.expr_encoding) + (req "amount" Tez.encoding) + (req "balance" Tez.encoding) + (req "chain_id" Chain_id.encoding) + (opt "source" Contract.encoding) + (opt "payer" Contract.encoding) + (opt "gas" Gas.Arith.z_integral_encoding) + (dft "entrypoint" string "default") + + let trace_encoding = + def "scripted.trace" @@ list + @@ obj3 + (req "location" Script.location_encoding) + (req "gas" Gas.encoding) + (req + "stack" + (list + (obj2 (req "item" Script.expr_encoding) (opt "annot" string)))) + + let run_code = + RPC_service.post_service + ~description:"Run a piece of code in the current context" + ~query:RPC_query.empty + ~input:run_code_input_encoding + ~output: + (conv + (fun (storage, operations, lazy_storage_diff) -> + (storage, operations, lazy_storage_diff, lazy_storage_diff)) + (fun ( storage, + operations, + legacy_lazy_storage_diff, + lazy_storage_diff ) -> + let lazy_storage_diff = + Option.first_some lazy_storage_diff legacy_lazy_storage_diff + in + (storage, operations, lazy_storage_diff)) + (obj4 + (req "storage" Script.expr_encoding) + (req "operations" (list Operation.internal_operation_encoding)) + (opt "big_map_diff" Lazy_storage.legacy_big_map_diff_encoding) + (opt "lazy_storage_diff" Lazy_storage.encoding))) + RPC_path.(path / "run_code") + + let trace_code = + RPC_service.post_service + ~description: + "Run a piece of code in the current context, keeping a trace" + ~query:RPC_query.empty + ~input:run_code_input_encoding + ~output: + (conv + (fun (storage, operations, trace, lazy_storage_diff) -> + ( storage, + operations, + trace, + lazy_storage_diff, + lazy_storage_diff )) + (fun ( storage, + operations, + trace, + legacy_lazy_storage_diff, + lazy_storage_diff ) -> + let lazy_storage_diff = + Option.first_some lazy_storage_diff legacy_lazy_storage_diff + in + (storage, operations, trace, lazy_storage_diff)) + (obj5 + (req "storage" Script.expr_encoding) + (req "operations" (list Operation.internal_operation_encoding)) + (req "trace" trace_encoding) + (opt "big_map_diff" Lazy_storage.legacy_big_map_diff_encoding) + (opt "lazy_storage_diff" Lazy_storage.encoding))) + RPC_path.(path / "trace_code") + + let typecheck_code = + RPC_service.post_service + ~description:"Typecheck a piece of code in the current context" + ~query:RPC_query.empty + ~input: + (obj3 + (req "program" Script.expr_encoding) + (opt "gas" Gas.Arith.z_integral_encoding) + (opt "legacy" bool)) + ~output: + (obj2 + (req "type_map" Script_tc_errors_registration.type_map_enc) + (req "gas" Gas.encoding)) + RPC_path.(path / "typecheck_code") + + let typecheck_data = + RPC_service.post_service + ~description: + "Check that some data expression is well formed and of a given type \ + in the current context" + ~query:RPC_query.empty + ~input: + (obj4 + (req "data" Script.expr_encoding) + (req "type" Script.expr_encoding) + (opt "gas" Gas.Arith.z_integral_encoding) + (opt "legacy" bool)) + ~output:(obj1 (req "gas" Gas.encoding)) + RPC_path.(path / "typecheck_data") + + let pack_data = + RPC_service.post_service + ~description: + "Computes the serialized version of some data expression using the \ + same algorithm as script instruction PACK" + ~input: + (obj3 + (req "data" Script.expr_encoding) + (req "type" Script.expr_encoding) + (opt "gas" Gas.Arith.z_integral_encoding)) + ~output:(obj2 (req "packed" bytes) (req "gas" Gas.encoding)) + ~query:RPC_query.empty + RPC_path.(path / "pack_data") + + let run_operation = + RPC_service.post_service + ~description:"Run an operation without signature checks" + ~query:RPC_query.empty + ~input: + (obj2 + (req "operation" Operation.encoding) + (req "chain_id" Chain_id.encoding)) + ~output:Apply_results.operation_data_and_metadata_encoding + RPC_path.(path / "run_operation") + + let entrypoint_type = + RPC_service.post_service + ~description:"Return the type of the given entrypoint" + ~query:RPC_query.empty + ~input: + (obj2 + (req "script" Script.expr_encoding) + (dft "entrypoint" string "default")) + ~output:(obj1 (req "entrypoint_type" Script.expr_encoding)) + RPC_path.(path / "entrypoint") + + let list_entrypoints = + RPC_service.post_service + ~description:"Return the list of entrypoints of the given script" + ~query:RPC_query.empty + ~input:(obj1 (req "script" Script.expr_encoding)) + ~output: + (obj2 + (dft + "unreachable" + (Data_encoding.list + (obj1 + (req + "path" + (Data_encoding.list + Michelson_v1_primitives.prim_encoding)))) + []) + (req "entrypoints" (assoc Script.expr_encoding))) + RPC_path.(path / "entrypoints") + end + + module Traced_interpreter = struct + type error += Cannot_serialize_log + + let () = + (* Cannot serialize log *) + register_error_kind + `Temporary + ~id:"michelson_v1.cannot_serialize_log" + ~title:"Not enough gas to serialize execution trace" + ~description: + "Execution trace with stacks was to big to be serialized with the \ + provided gas" + Data_encoding.empty + (function Cannot_serialize_log -> Some () | _ -> None) + (fun () -> Cannot_serialize_log) + + type log_element = + | Log : + context * Script.location * 'a * 'a Script_typed_ir.stack_ty + -> log_element + + let unparse_stack ctxt (stack, stack_ty) = + (* We drop the gas limit as this function is only used for debugging/errors. *) + let ctxt = Gas.set_unlimited ctxt in + let rec unparse_stack : + type a. + a Script_typed_ir.stack_ty * a -> + (Script.expr * string option) list tzresult Lwt.t = function + | (Empty_t, ()) -> + return_nil + | (Item_t (ty, rest_ty, annot), (v, rest)) -> + Script_ir_translator.unparse_data ctxt Readable ty v + >>=? fun (data, _ctxt) -> + unparse_stack (rest_ty, rest) + >|=? fun rest -> + let annot = + match Script_ir_annot.unparse_var_annot annot with + | [] -> + None + | [a] -> + Some a + | _ -> + assert false + in + let data = Micheline.strip_locations data in + (data, annot) :: rest + in + unparse_stack (stack_ty, stack) + + module Trace_logger () : Script_interpreter.STEP_LOGGER = struct + let log : log_element list ref = ref [] + + let log_interp ctxt (descr : (_, _) Script_typed_ir.descr) stack = + log := Log (ctxt, descr.loc, stack, descr.bef) :: !log + + let log_entry _ctxt _descr _stack = () + + let log_exit ctxt (descr : (_, _) Script_typed_ir.descr) stack = + log := Log (ctxt, descr.loc, stack, descr.aft) :: !log + + let get_log () = + map_s + (fun (Log (ctxt, loc, stack, stack_ty)) -> + trace Cannot_serialize_log (unparse_stack ctxt (stack, stack_ty)) + >>=? fun stack -> return (loc, Gas.level ctxt, stack)) + !log + >>=? fun res -> return (Some (List.rev res)) + end + + let execute ctxt mode step_constants ~script ~entrypoint ~parameter = + let module Logger = Trace_logger () in + let open Script_interpreter in + let logger = (module Logger : STEP_LOGGER) in + execute + ~logger + ctxt + mode + step_constants + ~script + ~entrypoint + ~parameter + ~internal:true + >>=? fun {ctxt; storage; lazy_storage_diff; operations} -> + Logger.get_log () + >|=? fun trace -> + let trace = Option.value ~default:[] trace in + ({ctxt; storage; lazy_storage_diff; operations}, trace) + end + + let typecheck_data : + legacy:bool -> + context -> + Script.expr * Script.expr -> + context tzresult Lwt.t = + fun ~legacy ctxt (data, exp_ty) -> + record_trace + (Script_tc_errors.Ill_formed_type (None, exp_ty, 0)) + (Script_ir_translator.parse_parameter_ty + ctxt + ~legacy + (Micheline.root exp_ty)) + >>?= fun (Ex_ty exp_ty, ctxt) -> + trace_eval + (fun () -> + Lwt.return + ( Script_ir_translator.serialize_ty_for_error ctxt exp_ty + >|? fun (exp_ty, _ctxt) -> + Script_tc_errors.Ill_typed_data (None, data, exp_ty) )) + (let allow_forged = + true + (* Safe since we ignore the value afterwards. *) + in + Script_ir_translator.parse_data + ctxt + ~legacy + ~allow_forged + exp_ty + (Micheline.root data)) + >|=? fun (_, ctxt) -> ctxt + + let register () = + let open Services_registration in + let originate_dummy_contract ctxt script balance = + let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in + Lwt.return (Contract.fresh_contract_from_current_nonce ctxt) + >>=? fun (ctxt, dummy_contract) -> + Contract.originate + ctxt + dummy_contract + ~balance + ~delegate:None + ~script:(script, None) + >>=? fun ctxt -> return (ctxt, dummy_contract) + in + register0 + S.run_code + (fun ctxt + () + ( code, + storage, + parameter, + amount, + balance, + chain_id, + source, + payer, + gas, + entrypoint ) + -> + let storage = Script.lazy_expr storage in + let code = Script.lazy_expr code in + originate_dummy_contract ctxt {storage; code} balance + >>=? fun (ctxt, dummy_contract) -> + let (source, payer) = + match (source, payer) with + | (Some source, Some payer) -> + (source, payer) + | (Some source, None) -> + (source, source) + | (None, Some payer) -> + (payer, payer) + | (None, None) -> + (dummy_contract, dummy_contract) + in + let gas = + match gas with + | Some gas -> + gas + | None -> + Constants.hard_gas_limit_per_operation ctxt + in + let ctxt = Gas.set_limit ctxt gas in + let step_constants = + let open Script_interpreter in + {source; payer; self = dummy_contract; amount; chain_id} + in + Script_interpreter.execute + ctxt + Readable + step_constants + ~script:{storage; code} + ~entrypoint + ~parameter + ~internal:true + >|=? fun {Script_interpreter.storage; operations; lazy_storage_diff; _} -> + (storage, operations, lazy_storage_diff)) ; + register0 + S.trace_code + (fun ctxt + () + ( code, + storage, + parameter, + amount, + balance, + chain_id, + source, + payer, + gas, + entrypoint ) + -> + let storage = Script.lazy_expr storage in + let code = Script.lazy_expr code in + originate_dummy_contract ctxt {storage; code} balance + >>=? fun (ctxt, dummy_contract) -> + let (source, payer) = + match (source, payer) with + | (Some source, Some payer) -> + (source, payer) + | (Some source, None) -> + (source, source) + | (None, Some payer) -> + (payer, payer) + | (None, None) -> + (dummy_contract, dummy_contract) + in + let gas = + match gas with + | Some gas -> + gas + | None -> + Constants.hard_gas_limit_per_operation ctxt + in + let ctxt = Gas.set_limit ctxt gas in + let step_constants = + let open Script_interpreter in + {source; payer; self = dummy_contract; amount; chain_id} + in + Traced_interpreter.execute + ctxt + Readable + step_constants + ~script:{storage; code} + ~entrypoint + ~parameter + >|=? fun ( { Script_interpreter.storage; + operations; + lazy_storage_diff; + _ }, + trace ) -> + (storage, operations, trace, lazy_storage_diff)) ; + register0 S.typecheck_code (fun ctxt () (expr, maybe_gas, legacy) -> + let legacy = Option.value ~default:false legacy in + let ctxt = + match maybe_gas with + | None -> + Gas.set_unlimited ctxt + | Some gas -> + Gas.set_limit ctxt gas + in + Script_ir_translator.typecheck_code ~legacy ctxt expr + >|=? fun (res, ctxt) -> (res, Gas.level ctxt)) ; + register0 S.typecheck_data (fun ctxt () (data, ty, maybe_gas, legacy) -> + let legacy = Option.value ~default:false legacy in + let ctxt = + match maybe_gas with + | None -> + Gas.set_unlimited ctxt + | Some gas -> + Gas.set_limit ctxt gas + in + typecheck_data ~legacy ctxt (data, ty) >|=? fun ctxt -> Gas.level ctxt) ; + register0 S.pack_data (fun ctxt () (expr, typ, maybe_gas) -> + let open Script_ir_translator in + let ctxt = + match maybe_gas with + | None -> + Gas.set_unlimited ctxt + | Some gas -> + Gas.set_limit ctxt gas + in + parse_packable_ty ctxt ~legacy:true (Micheline.root typ) + >>?= fun (Ex_ty typ, ctxt) -> + parse_data + ctxt + ~legacy:true + ~allow_forged:true + typ + (Micheline.root expr) + >>=? fun (data, ctxt) -> + Script_ir_translator.pack_data ctxt typ data + >|=? fun (bytes, ctxt) -> (bytes, Gas.level ctxt)) ; + register0 + S.run_operation + (fun ctxt + () + ({shell; protocol_data = Operation_data protocol_data}, chain_id) + -> + (* this code is a duplicate of Apply without signature check *) + let partial_precheck_manager_contents (type kind) ctxt + (op : kind Kind.manager contents) : context tzresult Lwt.t = + let (Manager_operation + {source; fee; counter; operation; gas_limit; storage_limit}) = + op + in + Gas.check_limit ctxt gas_limit + >>?= fun () -> + let ctxt = Gas.set_limit ctxt gas_limit in + Fees.check_storage_limit ctxt storage_limit + >>?= fun () -> + Contract.must_be_allocated ctxt (Contract.implicit_contract source) + >>=? fun () -> + Contract.check_counter_increment ctxt source counter + >>=? fun () -> + ( match operation with + | Reveal pk -> + Contract.reveal_manager_key ctxt source pk + | Transaction {parameters; _} -> + (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *) + let arg_bytes = + Data_encoding.Binary.to_bytes_exn + Script.lazy_expr_encoding + parameters + in + let arg = + match + Data_encoding.Binary.of_bytes + Script.lazy_expr_encoding + arg_bytes + with + | Some arg -> + arg + | None -> + assert false + in + (* Fail quickly if not enough gas for minimal deserialization cost *) + Lwt.return + @@ record_trace Apply.Gas_quota_exceeded_init_deserialize + @@ ( Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) + >>? fun () -> + (* Fail if not enough gas for complete deserialization cost *) + Script.force_decode_in_context ctxt arg + >|? fun (_arg, ctxt) -> ctxt ) + | Origination {script; _} -> + (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *) + let script_bytes = + Data_encoding.Binary.to_bytes_exn Script.encoding script + in + let script = + match + Data_encoding.Binary.of_bytes Script.encoding script_bytes + with + | Some script -> + script + | None -> + assert false + in + Lwt.return + @@ record_trace Apply.Gas_quota_exceeded_init_deserialize + @@ ( Gas.( + check_enough + (* Fail quickly if not enough gas for minimal deserialization cost *) + ctxt + ( Script.minimal_deserialize_cost script.code + +@ Script.minimal_deserialize_cost script.storage )) + >>? fun () -> + (* Fail if not enough gas for complete deserialization cost *) + Script.force_decode_in_context ctxt script.code + >>? fun (_code, ctxt) -> + Script.force_decode_in_context ctxt script.storage + >|? fun (_storage, ctxt) -> ctxt ) + | _ -> + return ctxt ) + >>=? fun ctxt -> + Contract.get_manager_key ctxt source + >>=? fun _public_key -> + (* signature check unplugged from here *) + Contract.increment_counter ctxt source + >>=? fun ctxt -> + Contract.spend ctxt (Contract.implicit_contract source) fee + in + let rec partial_precheck_manager_contents_list : + type kind. + Alpha_context.t -> + kind Kind.manager contents_list -> + context tzresult Lwt.t = + fun ctxt contents_list -> + match contents_list with + | Single (Manager_operation _ as op) -> + partial_precheck_manager_contents ctxt op + | Cons ((Manager_operation _ as op), rest) -> + partial_precheck_manager_contents ctxt op + >>=? fun ctxt -> partial_precheck_manager_contents_list ctxt rest + in + let ret contents = + ( Operation_data protocol_data, + Apply_results.Operation_metadata {contents} ) + in + let operation : _ operation = {shell; protocol_data} in + let hash = Operation.hash {shell; protocol_data} in + let ctxt = Contract.init_origination_nonce ctxt hash in + let baker = Signature.Public_key_hash.zero in + match protocol_data.contents with + | Single (Manager_operation _) as op -> + partial_precheck_manager_contents_list ctxt op + >>=? fun ctxt -> + Apply.apply_manager_contents_list ctxt Optimized baker chain_id op + >|= fun (_ctxt, result) -> ok @@ ret result + | Cons (Manager_operation _, _) as op -> + partial_precheck_manager_contents_list ctxt op + >>=? fun ctxt -> + Apply.apply_manager_contents_list ctxt Optimized baker chain_id op + >|= fun (_ctxt, result) -> ok @@ ret result + | _ -> + Apply.apply_contents_list + ctxt + chain_id + Optimized + shell.branch + baker + operation + operation.protocol_data.contents + >|=? fun (_ctxt, result) -> ret result) ; + register0 S.entrypoint_type (fun ctxt () (expr, entrypoint) -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = false in + let open Script_ir_translator in + Lwt.return + ( parse_toplevel ~legacy expr + >>? (fun (arg_type, _, _, root_name) -> + parse_parameter_ty ctxt ~legacy arg_type + >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.find_entrypoint + ~root_name + arg_type + entrypoint) + >>? fun (_f, Ex_ty ty) -> + unparse_ty ctxt ty + >|? fun (ty_node, _) -> Micheline.strip_locations ty_node )) ; + register0 S.list_entrypoints (fun ctxt () expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = false in + let open Script_ir_translator in + Lwt.return + ( parse_toplevel ~legacy expr + >>? fun (arg_type, _, _, root_name) -> + parse_parameter_ty ctxt ~legacy arg_type + >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.list_entrypoints ~root_name arg_type ctxt + >|? fun (unreachable_entrypoint, map) -> + ( unreachable_entrypoint, + Entrypoints_map.fold + (fun entry (_, ty) acc -> + (entry, Micheline.strip_locations ty) :: acc) + map + [] ) )) + + let run_code ctxt block ?gas ?(entrypoint = "default") ~script ~storage + ~input ~amount ~balance ~chain_id ~source ~payer = + RPC_context.make_call0 + S.run_code + ctxt + block + () + ( script, + storage, + input, + amount, + balance, + chain_id, + source, + payer, + gas, + entrypoint ) + + let trace_code ctxt block ?gas ?(entrypoint = "default") ~script ~storage + ~input ~amount ~balance ~chain_id ~source ~payer = + RPC_context.make_call0 + S.trace_code + ctxt + block + () + ( script, + storage, + input, + amount, + balance, + chain_id, + source, + payer, + gas, + entrypoint ) + + let typecheck_code ctxt block ?gas ?legacy ~script = + RPC_context.make_call0 S.typecheck_code ctxt block () (script, gas, legacy) + + let typecheck_data ctxt block ?gas ?legacy ~data ~ty = + RPC_context.make_call0 + S.typecheck_data + ctxt + block + () + (data, ty, gas, legacy) + + let pack_data ctxt block ?gas ~data ~ty = + RPC_context.make_call0 S.pack_data ctxt block () (data, ty, gas) + + let run_operation ctxt block ~op ~chain_id = + RPC_context.make_call0 S.run_operation ctxt block () (op, chain_id) + + let entrypoint_type ctxt block ~script ~entrypoint = + RPC_context.make_call0 S.entrypoint_type ctxt block () (script, entrypoint) + + let list_entrypoints ctxt block ~script = + RPC_context.make_call0 S.list_entrypoints ctxt block () script +end + +module Forge = struct + module S = struct + open Data_encoding + + let path = RPC_path.(path / "forge") + + let operations = + RPC_service.post_service + ~description:"Forge an operation" + ~query:RPC_query.empty + ~input:Operation.unsigned_encoding + ~output:bytes + RPC_path.(path / "operations") + + let empty_proof_of_work_nonce = + Bytes.make Constants_repr.proof_of_work_nonce_size '\000' + + let protocol_data = + RPC_service.post_service + ~description:"Forge the protocol-specific part of a block header" + ~query:RPC_query.empty + ~input: + (obj3 + (req "priority" uint16) + (opt "nonce_hash" Nonce_hash.encoding) + (dft + "proof_of_work_nonce" + (Fixed.bytes Alpha_context.Constants.proof_of_work_nonce_size) + empty_proof_of_work_nonce)) + ~output:(obj1 (req "protocol_data" bytes)) + RPC_path.(path / "protocol_data") + end + + let register () = + let open Services_registration in + register0_noctxt S.operations (fun () (shell, proto) -> + return + (Data_encoding.Binary.to_bytes_exn + Operation.unsigned_encoding + (shell, proto))) ; + register0_noctxt + S.protocol_data + (fun () (priority, seed_nonce_hash, proof_of_work_nonce) -> + return + (Data_encoding.Binary.to_bytes_exn + Block_header.contents_encoding + {priority; seed_nonce_hash; proof_of_work_nonce})) + + module Manager = struct + let operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee + ~gas_limit ~storage_limit operations = + Contract_services.manager_key ctxt block source + >>= function + | Error _ as e -> + Lwt.return e + | Ok revealed -> + let ops = + List.map + (fun (Manager operation) -> + Contents + (Manager_operation + { + source; + counter; + operation; + fee; + gas_limit; + storage_limit; + })) + operations + in + let ops = + match (sourcePubKey, revealed) with + | (None, _) | (_, Some _) -> + ops + | (Some pk, None) -> + let operation = Reveal pk in + Contents + (Manager_operation + { + source; + counter; + operation; + fee; + gas_limit; + storage_limit; + }) + :: ops + in + RPC_context.make_call0 + S.operations + ctxt + block + () + ({branch}, Operation.of_list ops) + + let reveal ctxt block ~branch ~source ~sourcePubKey ~counter ~fee () = + operations + ctxt + block + ~branch + ~source + ~sourcePubKey + ~counter + ~fee + ~gas_limit:Gas.Arith.zero + ~storage_limit:Z.zero + [] + + let transaction ctxt block ~branch ~source ?sourcePubKey ~counter ~amount + ~destination ?(entrypoint = "default") ?parameters ~gas_limit + ~storage_limit ~fee () = + let parameters = + Option.fold + ~some:Script.lazy_expr + ~none:Script.unit_parameter + parameters + in + operations + ctxt + block + ~branch + ~source + ?sourcePubKey + ~counter + ~fee + ~gas_limit + ~storage_limit + [Manager (Transaction {amount; parameters; destination; entrypoint})] + + let origination ctxt block ~branch ~source ?sourcePubKey ~counter ~balance + ?delegatePubKey ~script ~gas_limit ~storage_limit ~fee () = + operations + ctxt + block + ~branch + ~source + ?sourcePubKey + ~counter + ~fee + ~gas_limit + ~storage_limit + [ Manager + (Origination + { + delegate = delegatePubKey; + script; + credit = balance; + preorigination = None; + }) ] + + let delegation ctxt block ~branch ~source ?sourcePubKey ~counter ~fee + delegate = + operations + ctxt + block + ~branch + ~source + ?sourcePubKey + ~counter + ~fee + ~gas_limit:Gas.Arith.zero + ~storage_limit:Z.zero + [Manager (Delegation delegate)] + end + + let operation ctxt block ~branch operation = + RPC_context.make_call0 + S.operations + ctxt + block + () + ({branch}, Contents_list (Single operation)) + + let endorsement ctxt b ~branch ~level () = + operation ctxt b ~branch (Endorsement {level}) + + let proposals ctxt b ~branch ~source ~period ~proposals () = + operation ctxt b ~branch (Proposals {source; period; proposals}) + + let ballot ctxt b ~branch ~source ~period ~proposal ~ballot () = + operation ctxt b ~branch (Ballot {source; period; proposal; ballot}) + + let seed_nonce_revelation ctxt block ~branch ~level ~nonce () = + operation ctxt block ~branch (Seed_nonce_revelation {level; nonce}) + + let double_baking_evidence ctxt block ~branch ~bh1 ~bh2 () = + operation ctxt block ~branch (Double_baking_evidence {bh1; bh2}) + + let double_endorsement_evidence ctxt block ~branch ~op1 ~op2 () = + operation ctxt block ~branch (Double_endorsement_evidence {op1; op2}) + + let empty_proof_of_work_nonce = + Bytes.make Constants_repr.proof_of_work_nonce_size '\000' + + let protocol_data ctxt block ~priority ?seed_nonce_hash + ?(proof_of_work_nonce = empty_proof_of_work_nonce) () = + RPC_context.make_call0 + S.protocol_data + ctxt + block + () + (priority, seed_nonce_hash, proof_of_work_nonce) +end + +module Parse = struct + module S = struct + open Data_encoding + + let path = RPC_path.(path / "parse") + + let operations = + RPC_service.post_service + ~description:"Parse operations" + ~query:RPC_query.empty + ~input: + (obj2 + (req "operations" (list (dynamic_size Operation.raw_encoding))) + (opt "check_signature" bool)) + ~output:(list (dynamic_size Operation.encoding)) + RPC_path.(path / "operations") + + let block = + RPC_service.post_service + ~description:"Parse a block" + ~query:RPC_query.empty + ~input:Block_header.raw_encoding + ~output:Block_header.protocol_data_encoding + RPC_path.(path / "block") + end + + let parse_protocol_data protocol_data = + match + Data_encoding.Binary.of_bytes + Block_header.protocol_data_encoding + protocol_data + with + | None -> + failwith "Cant_parse_protocol_data" + | Some protocol_data -> + protocol_data + + let register () = + let open Services_registration in + register0 S.operations (fun _ctxt () (operations, check) -> + map_s + (fun raw -> + parse_operation raw + >>?= fun op -> + ( match check with + | Some true -> + return_unit (* FIXME *) + (* I.check_signature ctxt *) + (* op.protocol_data.signature op.shell op.protocol_data.contents *) + | Some false | None -> + return_unit ) + >|=? fun () -> op) + operations) ; + register0_noctxt S.block (fun () raw_block -> + return @@ parse_protocol_data raw_block.protocol_data) + + let operations ctxt block ?check operations = + RPC_context.make_call0 S.operations ctxt block () (operations, check) + + let block ctxt block shell protocol_data = + RPC_context.make_call0 + S.block + ctxt + block + () + ({shell; protocol_data} : Block_header.raw) +end + +module S = struct + open Data_encoding + + type level_query = {offset : int32} + + let level_query : level_query RPC_query.t = + let open RPC_query in + query (fun offset -> {offset}) + |+ field "offset" RPC_arg.int32 0l (fun t -> t.offset) + |> seal + + let current_level = + RPC_service.get_service + ~description: + "Returns the level of the interrogated block, or the one of a block \ + located `offset` blocks after in the chain (or before when \ + negative). For instance, the next block if `offset` is 1." + ~query:level_query + ~output:Level.compat_encoding + RPC_path.(path / "current_level") + + let levels_in_current_cycle = + RPC_service.get_service + ~description:"Levels of a cycle" + ~query:level_query + ~output: + (obj2 (req "first" Raw_level.encoding) (req "last" Raw_level.encoding)) + RPC_path.(path / "levels_in_current_cycle") +end + +let register () = + Scripts.register () ; + Forge.register () ; + Parse.register () ; + let open Services_registration in + register0 S.current_level (fun ctxt q () -> + let level = + Level.from_raw ctxt ~offset:q.offset (Level.current ctxt).level + in + Alpha_context.Voting_period.get_rpc_fixed_current_info ctxt + >|=? fun {voting_period; remaining; _} -> + let blocks_per_voting_period = Constants.blocks_per_voting_period ctxt in + let div_rem = Int32.(rem q.offset blocks_per_voting_period) in + let index_offset = + Int32.( + add + (div q.offset blocks_per_voting_period) + (if Compare.Int32.(div_rem > remaining) then 1l else 0l)) + in + let voting_period_index = Int32.add voting_period.index index_offset in + let start_position = + Int32.( + add + voting_period.start_position + (mul index_offset blocks_per_voting_period)) + in + let voting_period_position = + Int32.(sub level.level_position start_position) + in + Level.to_deprecated_type + level + ~voting_period_index + ~voting_period_position) ; + register0 S.levels_in_current_cycle (fun ctxt q () -> + let levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in + match levels with + | [] -> + raise Not_found + | _ -> + let first = List.hd (List.rev levels) in + let last = List.hd levels in + return (first.level, last.level)) + +let current_level ctxt ?(offset = 0l) block = + RPC_context.make_call0 S.current_level ctxt block {offset} () + +let levels_in_current_cycle ctxt ?(offset = 0l) block = + RPC_context.make_call0 S.levels_in_current_cycle ctxt block {offset} () diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/helpers_services.mli b/src/proto_008_PtEdo2Zk/lib_protocol/helpers_services.mli new file mode 100644 index 0000000000000000000000000000000000000000..8e8a99232957cd6620a02b7d9148c4dbb90171c7 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/helpers_services.mli @@ -0,0 +1,287 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +type error += Cannot_parse_operation (* `Branch *) + +val current_level : + 'a #RPC_context.simple -> + ?offset:int32 -> + 'a -> + Level.compat_t shell_tzresult Lwt.t + +val levels_in_current_cycle : + 'a #RPC_context.simple -> + ?offset:int32 -> + 'a -> + (Raw_level.t * Raw_level.t) shell_tzresult Lwt.t + +module Scripts : sig + module Traced_interpreter : sig + type error += Cannot_serialize_log + end + + val run_code : + 'a #RPC_context.simple -> + 'a -> + ?gas:Gas.Arith.integral -> + ?entrypoint:string -> + script:Script.expr -> + storage:Script.expr -> + input:Script.expr -> + amount:Tez.t -> + balance:Tez.t -> + chain_id:Chain_id.t -> + source:Contract.t option -> + payer:Contract.t option -> + (Script.expr * packed_internal_operation list * Lazy_storage.diffs option) + shell_tzresult + Lwt.t + + val trace_code : + 'a #RPC_context.simple -> + 'a -> + ?gas:Gas.Arith.integral -> + ?entrypoint:string -> + script:Script.expr -> + storage:Script.expr -> + input:Script.expr -> + amount:Tez.t -> + balance:Tez.t -> + chain_id:Chain_id.t -> + source:Contract.t option -> + payer:Contract.t option -> + ( Script.expr + * packed_internal_operation list + * Script_interpreter.execution_trace + * Lazy_storage.diffs option ) + shell_tzresult + Lwt.t + + val typecheck_code : + 'a #RPC_context.simple -> + 'a -> + ?gas:Gas.Arith.integral -> + ?legacy:bool -> + script:Script.expr -> + (Script_tc_errors.type_map * Gas.t) shell_tzresult Lwt.t + + val typecheck_data : + 'a #RPC_context.simple -> + 'a -> + ?gas:Gas.Arith.integral -> + ?legacy:bool -> + data:Script.expr -> + ty:Script.expr -> + Gas.t shell_tzresult Lwt.t + + val pack_data : + 'a #RPC_context.simple -> + 'a -> + ?gas:Gas.Arith.integral -> + data:Script.expr -> + ty:Script.expr -> + (bytes * Gas.t) shell_tzresult Lwt.t + + val run_operation : + 'a #RPC_context.simple -> + 'a -> + op:packed_operation -> + chain_id:Chain_id.t -> + (packed_protocol_data * Apply_results.packed_operation_metadata) + shell_tzresult + Lwt.t + + val entrypoint_type : + 'a #RPC_context.simple -> + 'a -> + script:Script.expr -> + entrypoint:string -> + Script.expr shell_tzresult Lwt.t + + val list_entrypoints : + 'a #RPC_context.simple -> + 'a -> + script:Script.expr -> + (Michelson_v1_primitives.prim list list * (string * Script.expr) list) + shell_tzresult + Lwt.t +end + +module Forge : sig + module Manager : sig + val operations : + 'a #RPC_context.simple -> + 'a -> + branch:Block_hash.t -> + source:public_key_hash -> + ?sourcePubKey:public_key -> + counter:counter -> + fee:Tez.t -> + gas_limit:Gas.Arith.integral -> + storage_limit:Z.t -> + packed_manager_operation list -> + bytes shell_tzresult Lwt.t + + val reveal : + 'a #RPC_context.simple -> + 'a -> + branch:Block_hash.t -> + source:public_key_hash -> + sourcePubKey:public_key -> + counter:counter -> + fee:Tez.t -> + unit -> + bytes shell_tzresult Lwt.t + + val transaction : + 'a #RPC_context.simple -> + 'a -> + branch:Block_hash.t -> + source:public_key_hash -> + ?sourcePubKey:public_key -> + counter:counter -> + amount:Tez.t -> + destination:Contract.t -> + ?entrypoint:string -> + ?parameters:Script.expr -> + gas_limit:Gas.Arith.integral -> + storage_limit:Z.t -> + fee:Tez.t -> + unit -> + bytes shell_tzresult Lwt.t + + val origination : + 'a #RPC_context.simple -> + 'a -> + branch:Block_hash.t -> + source:public_key_hash -> + ?sourcePubKey:public_key -> + counter:counter -> + balance:Tez.t -> + ?delegatePubKey:public_key_hash -> + script:Script.t -> + gas_limit:Gas.Arith.integral -> + storage_limit:Z.t -> + fee:Tez.t -> + unit -> + bytes shell_tzresult Lwt.t + + val delegation : + 'a #RPC_context.simple -> + 'a -> + branch:Block_hash.t -> + source:public_key_hash -> + ?sourcePubKey:public_key -> + counter:counter -> + fee:Tez.t -> + public_key_hash option -> + bytes shell_tzresult Lwt.t + end + + val endorsement : + 'a #RPC_context.simple -> + 'a -> + branch:Block_hash.t -> + level:Raw_level.t -> + unit -> + bytes shell_tzresult Lwt.t + + val proposals : + 'a #RPC_context.simple -> + 'a -> + branch:Block_hash.t -> + source:public_key_hash -> + period:int32 -> + proposals:Protocol_hash.t list -> + unit -> + bytes shell_tzresult Lwt.t + + val ballot : + 'a #RPC_context.simple -> + 'a -> + branch:Block_hash.t -> + source:public_key_hash -> + period:int32 -> + proposal:Protocol_hash.t -> + ballot:Vote.ballot -> + unit -> + bytes shell_tzresult Lwt.t + + val seed_nonce_revelation : + 'a #RPC_context.simple -> + 'a -> + branch:Block_hash.t -> + level:Raw_level.t -> + nonce:Nonce.t -> + unit -> + bytes shell_tzresult Lwt.t + + val double_baking_evidence : + 'a #RPC_context.simple -> + 'a -> + branch:Block_hash.t -> + bh1:Block_header.t -> + bh2:Block_header.t -> + unit -> + bytes shell_tzresult Lwt.t + + val double_endorsement_evidence : + 'a #RPC_context.simple -> + 'a -> + branch:Block_hash.t -> + op1:Kind.endorsement operation -> + op2:Kind.endorsement operation -> + unit -> + bytes shell_tzresult Lwt.t + + val protocol_data : + 'a #RPC_context.simple -> + 'a -> + priority:int -> + ?seed_nonce_hash:Nonce_hash.t -> + ?proof_of_work_nonce:bytes -> + unit -> + bytes shell_tzresult Lwt.t +end + +module Parse : sig + val operations : + 'a #RPC_context.simple -> + 'a -> + ?check:bool -> + Operation.raw list -> + Operation.packed list shell_tzresult Lwt.t + + val block : + 'a #RPC_context.simple -> + 'a -> + Block_header.shell_header -> + bytes -> + Block_header.protocol_data shell_tzresult Lwt.t +end + +val register : unit -> unit diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/init_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/init_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..c94892f65a3132b8b000e331795a4d9e03ab7d61 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/init_storage.ml @@ -0,0 +1,73 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* This is the genesis protocol: initialise the state *) +let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness = + Raw_context.prepare_first_block ~level ~timestamp ~fitness ctxt + >>=? fun (previous_protocol, ctxt, prev_blocks_per_voting_period) -> + match previous_protocol with + | Genesis param -> + Commitment_storage.init ctxt param.commitments + >>=? fun ctxt -> + Roll_storage.init ctxt + >>=? fun ctxt -> + Seed_storage.init ctxt + >>=? fun ctxt -> + Contract_storage.init ctxt + >>=? fun ctxt -> + Bootstrap_storage.init + ctxt + ~typecheck + ?ramp_up_cycles:param.security_deposit_ramp_up_cycles + ?no_reward_cycles:param.no_reward_cycles + param.bootstrap_accounts + param.bootstrap_contracts + >>=? fun ctxt -> + Roll_storage.init_first_cycles ctxt + >>=? fun ctxt -> + Vote_storage.init + ctxt + ~start_position:(Level_storage.current ctxt).level_position + >>=? fun ctxt -> + Storage.Block_priority.init ctxt 0 + >>=? fun ctxt -> Vote_storage.update_listings ctxt + | Delphi_007 -> + Storage.Vote.Current_period_kind_007.delete ctxt + >>=? fun ctxt -> + let level_position = (Level_storage.current ctxt).level_position in + let voting_period_index = + Int32.(div (succ level_position) prev_blocks_per_voting_period) + in + let start_position = level_position in + Storage.Vote.Current_period.init + ctxt + {index = voting_period_index; kind = Proposal; start_position} + >>=? fun ctxt -> + Storage.Vote.Pred_period_kind.init ctxt Promotion_vote + >>=? fun ctxt -> Storage.Sapling.Next.init ctxt + +let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness = + Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_diff.ml b/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_diff.ml new file mode 100644 index 0000000000000000000000000000000000000000..85a286264c0007f5f554ef6b63e90958136024bc --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_diff.ml @@ -0,0 +1,393 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module type Next = sig + type id + + val init : Raw_context.t -> Raw_context.t tzresult Lwt.t + + val incr : Raw_context.t -> (Raw_context.t * id) tzresult Lwt.t +end + +module type Total_bytes = sig + type id + + val init : Raw_context.t -> id -> Z.t -> Raw_context.t tzresult Lwt.t + + val get : Raw_context.t -> id -> Z.t tzresult Lwt.t + + val set : Raw_context.t -> id -> Z.t -> Raw_context.t tzresult Lwt.t +end + +(** Operations to be defined on a lazy storage type. *) +module type OPS = sig + module Id : Lazy_storage_kind.ID + + type alloc + + type updates + + val title : string + + val alloc_encoding : alloc Data_encoding.t + + val updates_encoding : updates Data_encoding.t + + val bytes_size_for_empty : Z.t + + val alloc : Raw_context.t -> id:Id.t -> alloc -> Raw_context.t tzresult Lwt.t + + val apply_updates : + Raw_context.t -> id:Id.t -> updates -> (Raw_context.t * Z.t) tzresult Lwt.t + + module Next : Next with type id := Id.t + + module Total_bytes : Total_bytes with type id := Id.t + + (** Deep copy. *) + val copy : + Raw_context.t -> from:Id.t -> to_:Id.t -> Raw_context.t tzresult Lwt.t + + (** Deep deletion. *) + val remove_rec : Raw_context.t -> Id.t -> Raw_context.t Lwt.t +end + +module Big_map = struct + include Lazy_storage_kind.Big_map + + let bytes_size_for_big_map_key = 65 + + let bytes_size_for_empty = + let bytes_size_for_big_map = 33 in + Z.of_int bytes_size_for_big_map + + let alloc ctxt ~id {key_type; value_type} = + (* Annotations are erased to allow sharing on [Copy]. The types from the + contract code are used, these ones are only used to make sure they are + compatible during transmissions between contracts, and only need to be + compatible, annotations notwithstanding. *) + let key_type = + Micheline.strip_locations + (Script_repr.strip_annotations (Micheline.root key_type)) + in + let value_type = + Micheline.strip_locations + (Script_repr.strip_annotations (Micheline.root value_type)) + in + Storage.Big_map.Key_type.init ctxt id key_type + >>=? fun ctxt -> Storage.Big_map.Value_type.init ctxt id value_type + + let apply_update ctxt ~id + { key = _key_is_shown_only_on_the_receipt_in_print_big_map_diff; + key_hash; + value } = + match value with + | None -> + Storage.Big_map.Contents.remove (ctxt, id) key_hash + >|=? fun (ctxt, freed, existed) -> + let freed = + if existed then freed + bytes_size_for_big_map_key else freed + in + (ctxt, Z.of_int ~-freed) + | Some v -> + Storage.Big_map.Contents.init_set (ctxt, id) key_hash v + >|=? fun (ctxt, size_diff, existed) -> + let size_diff = + if existed then size_diff else size_diff + bytes_size_for_big_map_key + in + (ctxt, Z.of_int size_diff) + + let apply_updates ctxt ~id updates = + fold_left_s + (fun (ctxt, size) update -> + apply_update ctxt ~id update + >|=? fun (ctxt, added_size) -> (ctxt, Z.add size added_size)) + (ctxt, Z.zero) + updates + + include Storage.Big_map +end + +type ('id, 'alloc, 'updates) ops = + (module OPS + with type Id.t = 'id + and type alloc = 'alloc + and type updates = 'updates) + +module Sapling_state = struct + include Lazy_storage_kind.Sapling_state + + let bytes_size_for_empty = Z.of_int 33 + + let alloc ctxt ~id {memo_size} = Sapling_storage.init ctxt id ~memo_size + + let apply_updates ctxt ~id updates = + Sapling_storage.apply_diff ctxt id updates + + include Storage.Sapling +end + +(* + To add a new lazy storage kind here, you only need to create a module similar + to [Big_map] above and add a case to [get_ops] below. +*) + +let get_ops : type i a u. (i, a, u) Lazy_storage_kind.t -> (i, a, u) ops = + function + | Big_map -> + (module Big_map) + | Sapling_state -> + (module Sapling_state) + [@@coq_axiom "gadt"] + +type ('id, 'alloc) init = Existing | Copy of {src : 'id} | Alloc of 'alloc + +type ('id, 'alloc, 'updates) diff = + | Remove + | Update of {init : ('id, 'alloc) init; updates : 'updates} + +let diff_encoding : type i a u. (i, a, u) ops -> (i, a, u) diff Data_encoding.t + = + fun (module OPS) -> + let open Data_encoding in + union + [ case + (Tag 0) + ~title:"update" + (obj2 + (req "action" (constant "update")) + (req "updates" OPS.updates_encoding)) + (function + | Update {init = Existing; updates} -> Some ((), updates) | _ -> None) + (fun ((), updates) -> Update {init = Existing; updates}); + case + (Tag 1) + ~title:"remove" + (obj1 (req "action" (constant "remove"))) + (function Remove -> Some () | _ -> None) + (fun () -> Remove); + case + (Tag 2) + ~title:"copy" + (obj3 + (req "action" (constant "copy")) + (req "source" OPS.Id.encoding) + (req "updates" OPS.updates_encoding)) + (function + | Update {init = Copy {src}; updates} -> + Some ((), src, updates) + | _ -> + None) + (fun ((), src, updates) -> Update {init = Copy {src}; updates}); + case + (Tag 3) + ~title:"alloc" + (merge_objs + (obj2 + (req "action" (constant "alloc")) + (req "updates" OPS.updates_encoding)) + OPS.alloc_encoding) + (function + | Update {init = Alloc alloc; updates} -> + Some (((), updates), alloc) + | _ -> + None) + (fun (((), updates), alloc) -> Update {init = Alloc alloc; updates}) ] + +(** + [apply_updates ctxt ops ~id init] applies the updates [updates] on lazy + storage [id] on storage context [ctxt] using operations [ops] and returns the + updated storage context and the added size in bytes (may be negative). +*) +let apply_updates : + type i a u. + Raw_context.t -> + (i, a, u) ops -> + id:i -> + u -> + (Raw_context.t * Z.t) tzresult Lwt.t = + fun ctxt (module OPS) ~id updates -> + OPS.apply_updates ctxt ~id updates + >>=? fun (ctxt, updates_size) -> + if Z.(equal updates_size zero) then return (ctxt, updates_size) + else + OPS.Total_bytes.get ctxt id + >>=? fun size -> + OPS.Total_bytes.set ctxt id (Z.add size updates_size) + >|=? fun ctxt -> (ctxt, updates_size) + +(** + [apply_init ctxt ops ~id init] applies the initialization [init] on lazy + storage [id] on storage context [ctxt] using operations [ops] and returns the + updated storage context and the added size in bytes (may be negative). + + If [id] represents a temporary lazy storage, the added size may be wrong. +*) +let apply_init : + type i a u. + Raw_context.t -> + (i, a, u) ops -> + id:i -> + (i, a) init -> + (Raw_context.t * Z.t) tzresult Lwt.t = + fun ctxt (module OPS) ~id init -> + match init with + | Existing -> + return (ctxt, Z.zero) + | Copy {src} -> + OPS.copy ctxt ~from:src ~to_:id + >>=? fun ctxt -> + if OPS.Id.is_temp id then return (ctxt, Z.zero) + else + OPS.Total_bytes.get ctxt src + >>=? fun copy_size -> + return (ctxt, Z.add copy_size OPS.bytes_size_for_empty) + | Alloc alloc -> + OPS.Total_bytes.init ctxt id Z.zero + >>=? fun ctxt -> + OPS.alloc ctxt id alloc + >>=? fun ctxt -> return (ctxt, OPS.bytes_size_for_empty) + +(** + [apply_diff ctxt ops ~id diff] applies the diff [diff] on lazy storage [id] + on storage context [ctxt] using operations [ops] and returns the updated + storage context and the added size in bytes (may be negative). + + If [id] represents a temporary lazy storage, the added size may be wrong. +*) +let apply_diff : + type i a u. + Raw_context.t -> + (i, a, u) ops -> + id:i -> + (i, a, u) diff -> + (Raw_context.t * Z.t) tzresult Lwt.t = + fun ctxt ((module OPS) as ops) ~id diff -> + match diff with + | Remove -> + if OPS.Id.is_temp id then + OPS.remove_rec ctxt id >|= fun ctxt -> ok (ctxt, Z.zero) + else + OPS.Total_bytes.get ctxt id + >>=? fun size -> + OPS.remove_rec ctxt id + >>= fun ctxt -> + return (ctxt, Z.neg (Z.add size OPS.bytes_size_for_empty)) + | Update {init; updates} -> + apply_init ctxt ops ~id init + >>=? fun (ctxt, init_size) -> + apply_updates ctxt ops ~id updates + >>=? fun (ctxt, updates_size) -> + return (ctxt, Z.add init_size updates_size) + +type diffs_item = + | Item : + ('i, 'a, 'u) Lazy_storage_kind.t * 'i * ('i, 'a, 'u) diff + -> diffs_item + +let make : + type i a u. + (i, a, u) Lazy_storage_kind.t -> i -> (i, a, u) diff -> diffs_item = + fun k id diff -> Item (k, id, diff) + +let item_encoding = + let open Data_encoding in + union + @@ List.map + (fun (tag, Lazy_storage_kind.Ex_Kind k) -> + let ops = get_ops k in + let (module OPS) = ops in + let title = OPS.title in + case + (Tag tag) + ~title + (obj3 + (req "kind" (constant title)) + (req "id" OPS.Id.encoding) + (req "diff" (diff_encoding ops))) + (fun (Item (kind, id, diff)) -> + match Lazy_storage_kind.equal k kind with + | Eq -> + Some ((), id, diff) + | Neq -> + None) + (fun ((), id, diff) -> Item (k, id, diff))) + Lazy_storage_kind.all + [@@coq_axiom "gadt"] + +type diffs = diffs_item list + +let encoding = + let open Data_encoding in + def "lazy_storage_diff" @@ list item_encoding + +let apply ctxt diffs = + fold_left_s + (fun (ctxt, total_size) (Item (k, id, diff)) -> + let ops = get_ops k in + apply_diff ctxt ops id diff + >|=? fun (ctxt, added_size) -> + let (module OPS) = ops in + ( ctxt, + if OPS.Id.is_temp id then total_size else Z.add total_size added_size + )) + (ctxt, Z.zero) + diffs + +let fresh : + type i a u. + (i, a, u) Lazy_storage_kind.t -> + temporary:bool -> + Raw_context.t -> + (Raw_context.t * i) tzresult Lwt.t = + fun kind ~temporary ctxt -> + if temporary then + return + (Raw_context.fold_map_temporary_lazy_storage_ids ctxt (fun temp_ids -> + Lazy_storage_kind.Temp_ids.fresh kind temp_ids)) + else + let (module OPS) = get_ops kind in + OPS.Next.incr ctxt + [@@coq_axiom "gadt"] + +let init ctxt = + fold_left_s + (fun ctxt (_tag, Lazy_storage_kind.Ex_Kind k) -> + let (module OPS) = get_ops k in + OPS.Next.init ctxt) + ctxt + Lazy_storage_kind.all + [@@coq_axiom "gadt"] + +let cleanup_temporaries ctxt = + Raw_context.map_temporary_lazy_storage_ids_s ctxt (fun temp_ids -> + Lwt_list.fold_left_s + (fun ctxt (_tag, Lazy_storage_kind.Ex_Kind k) -> + let (module OPS) = get_ops k in + Lazy_storage_kind.Temp_ids.fold_s k OPS.remove_rec temp_ids ctxt) + ctxt + Lazy_storage_kind.all + >|= fun ctxt -> (ctxt, Lazy_storage_kind.Temp_ids.init)) + [@@coq_axiom "gadt"] diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_diff.mli b/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_diff.mli new file mode 100644 index 0000000000000000000000000000000000000000..d9ae7b42f013bcd17850d8ff9c9434edbb0e8971 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_diff.mli @@ -0,0 +1,69 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining 'a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** + See [Lazy_storage_kind] for an introduction on lazy storage. + + This module defines operations on lazy storage types and diffs. +*) + +type ('id, 'alloc) init = Existing | Copy of {src : 'id} | Alloc of 'alloc + +type ('id, 'alloc, 'updates) diff = + | Remove + | Update of {init : ('id, 'alloc) init; updates : 'updates} + +(* Exposing this type is needed only for legacy big map diff. *) +type diffs_item = private + | Item : + ('i, 'a, 'u) Lazy_storage_kind.t * 'i * ('i, 'a, 'u) diff + -> diffs_item + +val make : + ('i, 'a, 'u) Lazy_storage_kind.t -> 'i -> ('i, 'a, 'u) diff -> diffs_item + +type diffs = diffs_item list + +val encoding : diffs Data_encoding.t + +(** + The returned [Z.t] is the size added by the application of the diffs. +*) +val apply : Raw_context.t -> diffs -> (Raw_context.t * Z.t) tzresult Lwt.t + +val fresh : + ('id, _, _) Lazy_storage_kind.t -> + temporary:bool -> + Raw_context.t -> + (Raw_context.t * 'id) tzresult Lwt.t + +(** + Initializes the storage for all lazy storage kind. + This is useful for genesis only. + Protocol updates need to initialize new lazy storage kinds. +*) +val init : Raw_context.t -> Raw_context.t tzresult Lwt.t + +val cleanup_temporaries : Raw_context.t -> Raw_context.t Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_kind.ml b/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_kind.ml new file mode 100644 index 0000000000000000000000000000000000000000..f64262eda4c1c4dad015b22ebb99f36d0b379053 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_kind.ml @@ -0,0 +1,342 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module type Temp_id = sig + type t + + val equal : t -> t -> bool + + val init : t + + val next : t -> t +end + +module type ID = sig + type t + + val compare : t -> t -> int + + val encoding : t Data_encoding.t + + val rpc_arg : t RPC_arg.arg + + val init : t + + (** In the protocol, to be used in parse_data only *) + val parse_z : Z.t -> t + + (** In the protocol, to be used in unparse_data only *) + val unparse_to_z : t -> Z.t + + val next : t -> t + + val is_temp : t -> bool + + val path_length : int + + val to_path : t -> string list -> string list + + val of_path : string list -> t option + + val of_legacy_USE_ONLY_IN_Legacy_big_map_diff : Z.t -> t + + val to_legacy_USE_ONLY_IN_Legacy_big_map_diff : t -> Z.t +end + +module type Title = sig + val title : string +end + +module type TitleWithId = sig + val title : string + + module Id : sig + include ID + + module Temp : Temp_id with type t = private t + end + + module IdSet : S.SET with type elt = Id.t +end + +module MakeId (Title : Title) : TitleWithId = struct + let title = Title.title + + let title_words = String.map (function '_' -> ' ' | c -> c) title + + let rpc_arg_error = Format.sprintf "Cannot parse %s id" title_words + + let description = Format.sprintf "A %s identifier" title_words + + let name = title ^ "_id" + + let encoding_title = String.capitalize_ascii title_words ^ " identifier" + + module Id = struct + type t = Z.t + + let compare = Z.compare + + let encoding = + Data_encoding.def name ~title:encoding_title ~description Data_encoding.z + + let rpc_arg = + let construct = Z.to_string in + let destruct hash = + match Z.of_string hash with + | exception _ -> + Error rpc_arg_error + | id -> + Ok id + in + RPC_arg.make ~descr:description ~name ~construct ~destruct () + + let init = Z.zero + + let parse_z (z : Z.t) : t = z + + let unparse_to_z (z : t) : Z.t = z + + let next = Z.succ + + let of_legacy_USE_ONLY_IN_Legacy_big_map_diff (z : Z.t) : t = z + + let to_legacy_USE_ONLY_IN_Legacy_big_map_diff (z : t) : Z.t = z + + module Temp = struct + type nonrec t = t + + let equal = Z.equal + + let init = Z.of_int ~-1 + + let next z = Z.sub z Z.one + end + + let is_temp z = Compare.Z.(z < Z.zero) + + let path_length = 1 + + let to_path z l = Z.to_string z :: l + + let of_path = function + | [] | _ :: _ :: _ -> + None + | [z] -> + Some (Z.of_string z) + end + + module IdSet = Set.Make (Id) +end + +module Big_map = struct + include MakeId (struct + let title = "big_map" + end) + + type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr} + + type update = { + key : Script_repr.expr; + (** The key is ignored by [apply_update] but is shown in the receipt, + as specified in [print_big_map_diff]. *) + key_hash : Script_expr_hash.t; + value : Script_repr.expr option; + } + + type updates = update list + + let alloc_encoding = + let open Data_encoding in + conv + (fun {key_type; value_type} -> (key_type, value_type)) + (fun (key_type, value_type) -> {key_type; value_type}) + (obj2 + (req "key_type" Script_repr.expr_encoding) + (req "value_type" Script_repr.expr_encoding)) + + let update_encoding = + let open Data_encoding in + conv + (fun {key_hash; key; value} -> (key_hash, key, value)) + (fun (key_hash, key, value) -> {key_hash; key; value}) + (obj3 + (req "key_hash" Script_expr_hash.encoding) + (req "key" Script_repr.expr_encoding) + (opt "value" Script_repr.expr_encoding)) + + let updates_encoding = Data_encoding.list update_encoding +end + +module Sapling_state = struct + include MakeId (struct + let title = "sapling_state" + end) + + type alloc = {memo_size : Sapling_repr.Memo_size.t} + + type updates = Sapling_repr.diff + + let alloc_encoding = + let open Data_encoding in + conv + (fun {memo_size} -> memo_size) + (fun memo_size -> {memo_size}) + (obj1 (req "memo_size" Sapling_repr.Memo_size.encoding)) + + let updates_encoding = Sapling_repr.diff_encoding +end + +(* + When adding cases to this type, grep for [new lazy storage kind] in the code + for locations to update. + It must be: + - the value [all] right below, + - modules [Temp_ids], [IdSet] below, + - the rest should be guided by type errors. +*) +type ('id, 'alloc, 'updates) t = + | Big_map : (Big_map.Id.t, Big_map.alloc, Big_map.updates) t + | Sapling_state + : (Sapling_state.Id.t, Sapling_state.alloc, Sapling_state.updates) t + +type ex = Ex_Kind : (_, _, _) t -> ex + +(* /!\ Don't forget to add new lazy storage kinds here. /!\ *) +let all = [(0, Ex_Kind Big_map); (1, Ex_Kind Sapling_state)] + +type (_, _) cmp = Eq : ('a, 'a) cmp | Neq + +let equal : + type i1 a1 u1 i2 a2 u2. + (i1, a1, u1) t -> (i2, a2, u2) t -> (i1 * a1 * u1, i2 * a2 * u2) cmp = + fun k1 k2 -> + match (k1, k2) with + | (Big_map, Big_map) -> + Eq + | (Sapling_state, Sapling_state) -> + Eq + | (Big_map, _) -> + Neq + | (_, Big_map) -> + Neq + +type ('i, 'a, 'u) kind = ('i, 'a, 'u) t + +module Temp_ids = struct + type t = { + big_map : Big_map.Id.Temp.t; + sapling_state : Sapling_state.Id.Temp.t; + } + + let init = + { + big_map = Big_map.Id.Temp.init; + sapling_state = Sapling_state.Id.Temp.init; + } + + let fresh : type i a u. (i, a, u) kind -> t -> t * i = + fun kind temp_ids -> + match kind with + | Big_map -> + let big_map = Big_map.Id.Temp.next temp_ids.big_map in + ({temp_ids with big_map}, (big_map :> Big_map.Id.t)) + | Sapling_state -> + let sapling_state = + Sapling_state.Id.Temp.next temp_ids.sapling_state + in + ({temp_ids with sapling_state}, (sapling_state :> Sapling_state.Id.t)) + [@@coq_axiom "gadt"] + + let fold_s : + type i a u. + (i, a, u) kind -> ('acc -> i -> 'acc Lwt.t) -> t -> 'acc -> 'acc Lwt.t = + fun kind f temp_ids acc -> + let helper (type j) (module Temp_id : Temp_id with type t = j) ~last f = + let rec aux acc id = + if Temp_id.equal id last then Lwt.return acc + else f acc id >>= fun acc -> aux acc (Temp_id.next id) + in + aux acc Temp_id.init + in + match kind with + | Big_map -> + helper + (module Big_map.Id.Temp) + ~last:temp_ids.big_map + (fun acc temp_id -> f acc (temp_id :> i)) + | Sapling_state -> + helper + (module Sapling_state.Id.Temp) + ~last:temp_ids.sapling_state + (fun acc temp_id -> f acc (temp_id :> i)) + [@@coq_axiom "gadt"] +end + +module IdSet = struct + type t = {big_map : Big_map.IdSet.t; sapling_state : Sapling_state.IdSet.t} + + type 'acc fold_f = {f : 'i 'a 'u. ('i, 'a, 'u) kind -> 'i -> 'acc -> 'acc} + + let empty = + {big_map = Big_map.IdSet.empty; sapling_state = Sapling_state.IdSet.empty} + + let mem (type i a u) (kind : (i, a, u) kind) (id : i) set = + match (kind, set) with + | (Big_map, {big_map}) -> + Big_map.IdSet.mem id big_map + | (Sapling_state, {sapling_state}) -> + Sapling_state.IdSet.mem id sapling_state + + let add (type i a u) (kind : (i, a, u) kind) (id : i) set = + match (kind, set) with + | (Big_map, {big_map}) -> + let big_map = Big_map.IdSet.add id big_map in + {set with big_map} + | (Sapling_state, {sapling_state}) -> + let sapling_state = Sapling_state.IdSet.add id sapling_state in + {set with sapling_state} + + let diff set1 set2 = + let big_map = Big_map.IdSet.diff set1.big_map set2.big_map in + let sapling_state = + Sapling_state.IdSet.diff set1.sapling_state set2.sapling_state + in + {big_map; sapling_state} + + let fold (type i a u) (kind : (i, a, u) kind) (f : i -> 'acc -> 'acc) set + (acc : 'acc) = + match (kind, set) with + | (Big_map, {big_map}) -> + Big_map.IdSet.fold f big_map acc + | (Sapling_state, {sapling_state}) -> + Sapling_state.IdSet.fold f sapling_state acc + + let fold_all f set acc = + List.fold_left + (fun acc (_, Ex_Kind kind) -> fold kind (f.f kind) set acc) + acc + all +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_kind.mli b/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_kind.mli new file mode 100644 index 0000000000000000000000000000000000000000..70298586aa1f9c0f6834fbe36d0a8b49c6a5418c --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/lazy_storage_kind.mli @@ -0,0 +1,182 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** + Lazy_storage offers a unified interface for specific Michelson datatype that + behave somewhat lazily, because they are intended to be quite big. + Instead of serializing/deserializing the whole value to/from the storage, + only an identifier is used. The identifier acts like a pointer. + When using the value in a Michelson script, some part of it may be read from + the storage, and a lightweight diff is computed. + The diff is effectively applied to the storage at the end of the execution. + + This module defines the different kinds of lazy storages and their basic + properties. See also [Lazy_storage_diff]. + + Lazy storage types are: + - Big_map +*) + +(** + Lazy storage ids are kept as abstract as possible to avoid mixing them up. + + Behind the scene they are [Z.t]s but, within the protocol, only [parse_data]/ + [unparse_data] are allowed convert from/to it. + + Temporary ids may be used to pass values between contracts that won't be kept + longer than the lifetime of the operation. + Behind the scene, temporary ids are negative [Z.t]s. +*) +module type ID = sig + type t + + val compare : t -> t -> int + + val encoding : t Data_encoding.t + + val rpc_arg : t RPC_arg.arg + + (** Initial value for ids: zero. *) + val init : t + + (** In the protocol, to be used in parse_data only *) + val parse_z : Z.t -> t + + (** In the protocol, to be used in unparse_data only *) + val unparse_to_z : t -> Z.t + + val next : t -> t + + val is_temp : t -> bool + + (* To be used in storage: *) + + val path_length : int + + val to_path : t -> string list -> string list + + val of_path : string list -> t option + + (* To be removed once legacy big map diff is removed: *) + + val of_legacy_USE_ONLY_IN_Legacy_big_map_diff : Z.t -> t + + val to_legacy_USE_ONLY_IN_Legacy_big_map_diff : t -> Z.t +end + +module Big_map : sig + val title : string + + module Id : ID + + type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr} + + type update = { + key : Script_repr.expr; + (** The key is ignored by [apply_update] but is shown in the receipt, + as specified in [print_big_map_diff]. *) + key_hash : Script_expr_hash.t; + value : Script_repr.expr option; + } + + type updates = update list + + val alloc_encoding : alloc Data_encoding.t + + val updates_encoding : updates Data_encoding.t +end + +module Sapling_state : sig + val title : string + + module Id : ID + + type alloc = {memo_size : Sapling_repr.Memo_size.t} + + type updates = Sapling_repr.diff + + val alloc_encoding : alloc Data_encoding.t + + val updates_encoding : updates Data_encoding.t +end + +(** + Kinds of lazy storage. + The GADT ensures operations are properly applied to the correct kind. + + ['id] the abstract type for the identifier of the kind. + ['alloc] is the type used to construct a new value. + ['updates] is the type used to update a value. +*) +type ('id, 'alloc, 'updates) t = + | Big_map : (Big_map.Id.t, Big_map.alloc, Big_map.updates) t + | Sapling_state + : (Sapling_state.Id.t, Sapling_state.alloc, Sapling_state.updates) t + +type ex = Ex_Kind : (_, _, _) t -> ex + +val all : (int * ex) list + +type (_, _) cmp = Eq : ('a, 'a) cmp | Neq + +val equal : + ('i1, 'a1, 'u1) t -> + ('i2, 'a2, 'u2) t -> + ('i1 * 'a1 * 'u1, 'i2 * 'a2 * 'u2) cmp + +type ('i, 'a, 'u) kind = ('i, 'a, 'u) t + +(** + Type to manage temporary ids. + Used only in the context. +*) +module Temp_ids : sig + type t + + val init : t + + val fresh : ('i, 'a, 'u) kind -> t -> t * 'i + + val fold_s : + ('i, 'a, 'u) kind -> ('acc -> 'i -> 'acc Lwt.t) -> t -> 'acc -> 'acc Lwt.t +end + +module IdSet : sig + type t + + type 'acc fold_f = {f : 'i 'a 'u. ('i, 'a, 'u) kind -> 'i -> 'acc -> 'acc} + + val empty : t + + val mem : ('i, 'a, 'u) kind -> 'i -> t -> bool + + val add : ('i, 'a, 'u) kind -> 'i -> t -> t + + val diff : t -> t -> t + + val fold : ('i, 'a, 'u) kind -> ('i -> 'acc -> 'acc) -> t -> 'acc -> 'acc + + val fold_all : 'acc fold_f -> t -> 'acc -> 'acc +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/level_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/level_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..c3aaf8aedb4b9aec0523ca375a230aa96c4ffef6 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/level_repr.ml @@ -0,0 +1,230 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = { + level : Raw_level_repr.t; + level_position : int32; + cycle : Cycle_repr.t; + cycle_position : int32; + expected_commitment : bool; +} + +include Compare.Make (struct + type nonrec t = t + + let compare {level = l1} {level = l2} = Raw_level_repr.compare l1 l2 +end) + +type level = t + +let pp ppf {level} = Raw_level_repr.pp ppf level + +let pp_full ppf l = + Format.fprintf + ppf + "%a.%ld (cycle %a.%ld)" + Raw_level_repr.pp + l.level + l.level_position + Cycle_repr.pp + l.cycle + l.cycle_position + +let encoding = + let open Data_encoding in + conv + (fun {level; level_position; cycle; cycle_position; expected_commitment} -> + (level, level_position, cycle, cycle_position, expected_commitment)) + (fun (level, level_position, cycle, cycle_position, expected_commitment) -> + {level; level_position; cycle; cycle_position; expected_commitment}) + (obj5 + (req + "level" + ~description: + "The level of the block relative to genesis. This is also the \ + Shell's notion of level" + Raw_level_repr.encoding) + (req + "level_position" + ~description: + "The level of the block relative to the block that starts \ + protocol alpha. This is specific to the protocol alpha. Other \ + protocols might or might not include a similar notion." + int32) + (req + "cycle" + ~description: + "The current cycle's number. Note that cycles are a \ + protocol-specific notion. As a result, the cycle number starts \ + at 0 with the first block of protocol alpha." + Cycle_repr.encoding) + (req + "cycle_position" + ~description: + "The current level of the block relative to the first block of \ + the current cycle." + int32) + (req + "expected_commitment" + ~description: + "Tells wether the baker of this block has to commit a seed nonce \ + hash." + bool)) + +let root_level first_level = + { + level = first_level; + level_position = 0l; + cycle = Cycle_repr.root; + cycle_position = 0l; + expected_commitment = false; + } + +let level_from_raw ~first_level ~blocks_per_cycle ~blocks_per_commitment level + = + let raw_level = Raw_level_repr.to_int32 level in + let first_level = Raw_level_repr.to_int32 first_level in + let level_position = + Compare.Int32.max 0l (Int32.sub raw_level first_level) + in + let cycle = + Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle) + in + let cycle_position = Int32.rem level_position blocks_per_cycle in + let expected_commitment = + Compare.Int32.( + Int32.rem cycle_position blocks_per_commitment + = Int32.pred blocks_per_commitment) + in + {level; level_position; cycle; cycle_position; expected_commitment} + +let diff {level = l1; _} {level = l2; _} = + Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2) + +type compat_t = { + level : Raw_level_repr.t; + level_position : int32; + cycle : Cycle_repr.t; + cycle_position : int32; + voting_period : int32; + voting_period_position : int32; + expected_commitment : bool; +} + +let compat_encoding = + let open Data_encoding in + conv + (fun { level; + level_position; + cycle; + cycle_position; + voting_period; + voting_period_position; + expected_commitment } -> + ( level, + level_position, + cycle, + cycle_position, + voting_period, + voting_period_position, + expected_commitment )) + (fun ( level, + level_position, + cycle, + cycle_position, + voting_period, + voting_period_position, + expected_commitment ) -> + { + level; + level_position; + cycle; + cycle_position; + voting_period; + voting_period_position; + expected_commitment; + }) + (obj7 + (req + "level" + ~description: + "The level of the block relative to genesis. This is also the \ + Shell's notion of level" + Raw_level_repr.encoding) + (req + "level_position" + ~description: + "The level of the block relative to the block that starts \ + protocol alpha. This is specific to the protocol alpha. Other \ + protocols might or might not include a similar notion." + int32) + (req + "cycle" + ~description: + "The current cycle's number. Note that cycles are a \ + protocol-specific notion. As a result, the cycle number starts \ + at 0 with the first block of protocol alpha." + Cycle_repr.encoding) + (req + "cycle_position" + ~description: + "The current level of the block relative to the first block of \ + the current cycle." + int32) + (req + "voting_period" + ~description: + "The current voting period's index. Note that cycles are a \ + protocol-specific notion. As a result, the voting period index \ + starts at 0 with the first block of protocol alpha. This field \ + is DEPRECATED: use `../votes/voting_period` RPC \ + instead." + int32) + (req + "voting_period_position" + ~description: + "The current level of the block relative to the first block of \ + the current voting period. This field is DEPRECATED: use \ + `../votes/voting_period` RPC instead." + int32) + (req + "expected_commitment" + ~description: + "Tells wether the baker of this block has to commit a seed nonce \ + hash." + bool)) + +let to_deprecated_type + ({level; level_position; cycle; cycle_position; expected_commitment} : t) + ~voting_period_index ~voting_period_position = + { + level; + level_position; + cycle; + cycle_position; + voting_period = voting_period_index; + voting_period_position; + expected_commitment; + } diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/level_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/level_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..1ab7137d97a660fcfc461224474385e7a849123f --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/level_repr.mli @@ -0,0 +1,87 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = private { + level : Raw_level_repr.t; + (** The level of the block relative to genesis. This + is also the Shell's notion of level. *) + level_position : int32; + (** The level of the block relative to the block that started the first + version of protocol alpha. *) + cycle : Cycle_repr.t; + (** The current cycle's number. Note that cycles are a protocol-specific + notion. As a result, the cycle number starts at 0 with the first block of + the first version of protocol alpha. *) + cycle_position : int32; + (** The current level of the block relative to the first block of the current + cycle. *) + expected_commitment : bool; +} + +(* Note that, the type `t` above must respect some invariants (hence the + `private` annotation). Notably: + + level_position = cycle * blocks_per_cycle + cycle_position +*) + +type level = t + +include Compare.S with type t := level + +val encoding : level Data_encoding.t + +val pp : Format.formatter -> level -> unit + +val pp_full : Format.formatter -> level -> unit + +val root_level : Raw_level_repr.t -> level + +val level_from_raw : + first_level:Raw_level_repr.t -> + blocks_per_cycle:int32 -> + blocks_per_commitment:int32 -> + Raw_level_repr.t -> + level + +val diff : level -> level -> int32 + +(** Compatibility module with Level_repr.t from protocol 007. + In this version, the [voting_period] and [voting_period_position] fields are + deprecated and replaced by a new RPC endpoint at + [Voting_services.voting_period] *) +type compat_t = { + level : Raw_level_repr.t; + level_position : int32; + cycle : Cycle_repr.t; + cycle_position : int32; + voting_period : int32; + voting_period_position : int32; + expected_commitment : bool; +} + +val compat_encoding : compat_t Data_encoding.t + +val to_deprecated_type : + t -> voting_period_index:int32 -> voting_period_position:int32 -> compat_t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/level_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/level_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..dc3aaf9a9243de224068417e3c3efc0168918c13 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/level_storage.ml @@ -0,0 +1,117 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Level_repr + +let from_raw c ?offset l = + let l = + match offset with + | None -> + l + | Some o -> + Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o)) + in + let constants = Raw_context.constants c in + let first_level = Raw_context.first_level c in + Level_repr.level_from_raw + ~first_level + ~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle + ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment + l + +let root c = Level_repr.root_level (Raw_context.first_level c) + +let succ c (l : Level_repr.t) = from_raw c (Raw_level_repr.succ l.level) + +let pred c (l : Level_repr.t) = + match Raw_level_repr.pred l.Level_repr.level with + | None -> + None + | Some l -> + Some (from_raw c l) + +let current ctxt = Raw_context.current_level ctxt + +let previous ctxt = + let l = current ctxt in + match pred ctxt l with + | None -> + assert false (* We never validate the Genesis... *) + | Some p -> + p + +let first_level_in_cycle ctxt c = + let constants = Raw_context.constants ctxt in + let first_level = Raw_context.first_level ctxt in + from_raw + ctxt + (Raw_level_repr.of_int32_exn + (Int32.add + (Raw_level_repr.to_int32 first_level) + (Int32.mul + constants.Constants_repr.blocks_per_cycle + (Cycle_repr.to_int32 c)))) + +let last_level_in_cycle ctxt c = + match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with + | None -> + assert false + | Some x -> + x + +let levels_in_cycle ctxt cycle = + let first = first_level_in_cycle ctxt cycle in + let rec loop (n : Level_repr.t) acc = + if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc) + else acc + in + loop first [] + +let levels_in_current_cycle ctxt ?(offset = 0l) () = + let current_cycle = Cycle_repr.to_int32 (current ctxt).cycle in + let cycle = Int32.add current_cycle offset in + if Compare.Int32.(cycle < 0l) then [] + else + let cycle = Cycle_repr.of_int32_exn cycle in + levels_in_cycle ctxt cycle + +let levels_with_commitments_in_cycle ctxt c = + let first = first_level_in_cycle ctxt c in + let rec loop (n : Level_repr.t) acc = + if Cycle_repr.(n.cycle = first.cycle) then + if n.expected_commitment then loop (succ ctxt n) (n :: acc) + else loop (succ ctxt n) acc + else acc + in + loop first [] + +let last_allowed_fork_level c = + let level = Raw_context.current_level c in + let preserved_cycles = Constants_storage.preserved_cycles c in + match Cycle_repr.sub level.cycle preserved_cycles with + | None -> + Raw_level_repr.root + | Some cycle -> + (first_level_in_cycle c cycle).level diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/level_storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/level_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..047fcbb40f19f9e82358bff35292930a3822e2b7 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/level_storage.mli @@ -0,0 +1,51 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +val current : Raw_context.t -> Level_repr.t + +val previous : Raw_context.t -> Level_repr.t + +val root : Raw_context.t -> Level_repr.t + +val from_raw : + Raw_context.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t + +val pred : Raw_context.t -> Level_repr.t -> Level_repr.t option + +val succ : Raw_context.t -> Level_repr.t -> Level_repr.t + +val first_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t + +val last_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t + +val levels_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t list + +val levels_in_current_cycle : + Raw_context.t -> ?offset:int32 -> unit -> Level_repr.t list + +val levels_with_commitments_in_cycle : + Raw_context.t -> Cycle_repr.t -> Level_repr.t list + +val last_allowed_fork_level : Raw_context.t -> Raw_level_repr.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/main.ml b/src/proto_008_PtEdo2Zk/lib_protocol/main.ml new file mode 100644 index 0000000000000000000000000000000000000000..43f2ee89bb06026a8567364915a57c2c52627a3c --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/main.ml @@ -0,0 +1,399 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Protocol Signature Instance *) + +type block_header_data = Alpha_context.Block_header.protocol_data + +type block_header = Alpha_context.Block_header.t = { + shell : Block_header.shell_header; + protocol_data : block_header_data; +} + +let block_header_data_encoding = + Alpha_context.Block_header.protocol_data_encoding + +type block_header_metadata = Apply_results.block_metadata + +let block_header_metadata_encoding = Apply_results.block_metadata_encoding + +type operation_data = Alpha_context.packed_protocol_data = + | Operation_data : + 'kind Alpha_context.Operation.protocol_data + -> operation_data + +let operation_data_encoding = Alpha_context.Operation.protocol_data_encoding + +type operation_receipt = Apply_results.packed_operation_metadata = + | Operation_metadata : + 'kind Apply_results.operation_metadata + -> operation_receipt + | No_operation_metadata : operation_receipt + +let operation_receipt_encoding = Apply_results.operation_metadata_encoding + +let operation_data_and_receipt_encoding = + Apply_results.operation_data_and_metadata_encoding + +type operation = Alpha_context.packed_operation = { + shell : Operation.shell_header; + protocol_data : operation_data; +} + +let acceptable_passes = Alpha_context.Operation.acceptable_passes + +let max_block_length = Alpha_context.Block_header.max_header_length + +let max_operation_data_length = + Alpha_context.Constants.max_operation_data_length + +let validation_passes = + let open Alpha_context.Constants in + Updater. + [ (* 32 endorsements *) + {max_size = 32 * 1024; max_op = Some 32}; + (* 32k of voting operations *) + {max_size = 32 * 1024; max_op = None}; + (* revelations, wallet activations and denunciations *) + { + max_size = max_anon_ops_per_block * 1024; + max_op = Some max_anon_ops_per_block; + }; + (* 512kB *) + {max_size = 512 * 1024; max_op = None} ] + +let rpc_services = + Alpha_services.register () ; + Services_registration.get_rpc_services () + +type validation_mode = + | Application of { + block_header : Alpha_context.Block_header.t; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; + } + | Partial_application of { + block_header : Alpha_context.Block_header.t; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; + } + | Partial_construction of {predecessor : Block_hash.t} + | Full_construction of { + predecessor : Block_hash.t; + protocol_data : Alpha_context.Block_header.contents; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; + } + +type validation_state = { + mode : validation_mode; + chain_id : Chain_id.t; + ctxt : Alpha_context.t; + op_count : int; +} + +let current_context {ctxt; _} = return (Alpha_context.finalize ctxt).context + +let begin_partial_application ~chain_id ~ancestor_context:ctxt + ~predecessor_timestamp ~predecessor_fitness + (block_header : Alpha_context.Block_header.t) = + let level = block_header.shell.level in + let fitness = predecessor_fitness in + let timestamp = block_header.shell.timestamp in + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt + >>=? fun ctxt -> + Apply.begin_application ctxt chain_id block_header predecessor_timestamp + >|=? fun (ctxt, baker, block_delay) -> + let mode = + Partial_application + {block_header; baker = Signature.Public_key.hash baker; block_delay} + in + {mode; chain_id; ctxt; op_count = 0} + +let begin_application ~chain_id ~predecessor_context:ctxt + ~predecessor_timestamp ~predecessor_fitness + (block_header : Alpha_context.Block_header.t) = + let level = block_header.shell.level in + let fitness = predecessor_fitness in + let timestamp = block_header.shell.timestamp in + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt + >>=? fun ctxt -> + Apply.begin_application ctxt chain_id block_header predecessor_timestamp + >|=? fun (ctxt, baker, block_delay) -> + let mode = + Application + {block_header; baker = Signature.Public_key.hash baker; block_delay} + in + {mode; chain_id; ctxt; op_count = 0} + +let begin_construction ~chain_id ~predecessor_context:ctxt + ~predecessor_timestamp ~predecessor_level:pred_level + ~predecessor_fitness:pred_fitness ~predecessor ~timestamp + ?(protocol_data : block_header_data option) () = + let level = Int32.succ pred_level in + let fitness = pred_fitness in + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt + >>=? fun ctxt -> + ( match protocol_data with + | None -> + Apply.begin_partial_construction ctxt + >|=? fun ctxt -> + let mode = Partial_construction {predecessor} in + (mode, ctxt) + | Some proto_header -> + Apply.begin_full_construction + ctxt + predecessor_timestamp + proto_header.contents + >|=? fun (ctxt, protocol_data, baker, block_delay) -> + let mode = + let baker = Signature.Public_key.hash baker in + Full_construction {predecessor; baker; protocol_data; block_delay} + in + (mode, ctxt) ) + >|=? fun (mode, ctxt) -> {mode; chain_id; ctxt; op_count = 0} + +let apply_operation ({mode; chain_id; ctxt; op_count; _} as data) + (operation : Alpha_context.packed_operation) = + match mode with + | Partial_application _ + when not + (List.exists + (Compare.Int.equal 0) + (Alpha_context.Operation.acceptable_passes operation)) -> + (* Multipass validation only considers operations in pass 0. *) + let op_count = op_count + 1 in + return ({data with ctxt; op_count}, No_operation_metadata) + | _ -> + let {shell; protocol_data = Operation_data protocol_data} = operation in + let operation : _ Alpha_context.operation = {shell; protocol_data} in + let (predecessor, baker) = + match mode with + | Partial_application + {block_header = {shell = {predecessor; _}; _}; baker} + | Application {block_header = {shell = {predecessor; _}; _}; baker} + | Full_construction {predecessor; baker; _} -> + (predecessor, baker) + | Partial_construction {predecessor} -> + (predecessor, Signature.Public_key_hash.zero) + in + Apply.apply_operation + ctxt + chain_id + Optimized + predecessor + baker + (Alpha_context.Operation.hash operation) + operation + >|=? fun (ctxt, result) -> + let op_count = op_count + 1 in + ({data with ctxt; op_count}, Operation_metadata result) + +let finalize_block {mode; ctxt; op_count} = + match mode with + | Partial_construction _ -> + Alpha_context.Voting_period.get_current_info ctxt + >>=? fun {voting_period = {kind; _}; _} -> + Alpha_context.Voting_period.get_rpc_fixed_current_info ctxt + >>=? fun ({voting_period; position; _} as voting_period_info) -> + let level_info = Alpha_context.Level.current ctxt in + let baker = Signature.Public_key_hash.zero in + Signature.Public_key_hash.Map.fold + (fun delegate deposit ctxt -> + ctxt + >>=? fun ctxt -> + Alpha_context.Delegate.freeze_deposit ctxt delegate deposit) + (Alpha_context.get_deposits ctxt) + (return ctxt) + >|=? fun ctxt -> + let ctxt = Alpha_context.finalize ctxt in + ( ctxt, + Apply_results. + { + baker; + level = + Alpha_context.Level.to_deprecated_type + level_info + ~voting_period_index:voting_period.index + ~voting_period_position:position; + level_info; + voting_period_kind = kind; + voting_period_info; + nonce_hash = None; + consumed_gas = Alpha_context.Gas.Arith.zero; + deactivated = []; + balance_updates = []; + } ) + | Partial_application {block_header; baker; block_delay} -> + let included_endorsements = Alpha_context.included_endorsements ctxt in + Apply.check_minimum_endorsements + ctxt + block_header.protocol_data.contents + block_delay + included_endorsements + >>?= fun () -> + Alpha_context.Voting_period.get_current_info ctxt + >>=? fun {voting_period = {kind; _}; _} -> + Alpha_context.Voting_period.get_rpc_fixed_current_info ctxt + >|=? fun ({voting_period; position; _} as voting_period_info) -> + let level_info = Alpha_context.Level.current ctxt in + let ctxt = Alpha_context.finalize ctxt in + ( ctxt, + Apply_results. + { + baker; + level = + Alpha_context.Level.to_deprecated_type + level_info + ~voting_period_index:voting_period.index + ~voting_period_position:position; + level_info; + voting_period_kind = kind; + voting_period_info; + nonce_hash = None; + consumed_gas = Alpha_context.Gas.Arith.zero; + deactivated = []; + balance_updates = []; + } ) + | Application + { baker; + block_delay; + block_header = {protocol_data = {contents = protocol_data; _}; _} } + | Full_construction {protocol_data; baker; block_delay; _} -> + Apply.finalize_application ctxt protocol_data baker ~block_delay + >|=? fun (ctxt, receipt) -> + let level = Alpha_context.Level.current ctxt in + let priority = protocol_data.priority in + let raw_level = Alpha_context.Raw_level.to_int32 level.level in + let fitness = Alpha_context.Fitness.current ctxt in + let commit_message = + Format.asprintf + "lvl %ld, fit 1:%Ld, prio %d, %d ops" + raw_level + fitness + priority + op_count + in + let ctxt = Alpha_context.finalize ~commit_message ctxt in + (ctxt, receipt) + +let compare_operations op1 op2 = + let open Alpha_context in + let (Operation_data op1) = op1.protocol_data in + let (Operation_data op2) = op2.protocol_data in + match (op1.contents, op2.contents) with + | (Single (Endorsement _), Single (Endorsement _)) -> + 0 + | (_, Single (Endorsement _)) -> + 1 + | (Single (Endorsement _), _) -> + -1 + | (Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _)) -> + 0 + | (_, Single (Seed_nonce_revelation _)) -> + 1 + | (Single (Seed_nonce_revelation _), _) -> + -1 + | ( Single (Double_endorsement_evidence _), + Single (Double_endorsement_evidence _) ) -> + 0 + | (_, Single (Double_endorsement_evidence _)) -> + 1 + | (Single (Double_endorsement_evidence _), _) -> + -1 + | (Single (Double_baking_evidence _), Single (Double_baking_evidence _)) -> + 0 + | (_, Single (Double_baking_evidence _)) -> + 1 + | (Single (Double_baking_evidence _), _) -> + -1 + | (Single (Activate_account _), Single (Activate_account _)) -> + 0 + | (_, Single (Activate_account _)) -> + 1 + | (Single (Activate_account _), _) -> + -1 + | (Single (Proposals _), Single (Proposals _)) -> + 0 + | (_, Single (Proposals _)) -> + 1 + | (Single (Proposals _), _) -> + -1 + | (Single (Ballot _), Single (Ballot _)) -> + 0 + | (_, Single (Ballot _)) -> + 1 + | (Single (Ballot _), _) -> + -1 + (* Manager operations with smaller counter are pre-validated first. *) + | (Single (Manager_operation op1), Single (Manager_operation op2)) -> + Z.compare op1.counter op2.counter + | (Cons (Manager_operation op1, _), Single (Manager_operation op2)) -> + Z.compare op1.counter op2.counter + | (Single (Manager_operation op1), Cons (Manager_operation op2, _)) -> + Z.compare op1.counter op2.counter + | (Cons (Manager_operation op1, _), Cons (Manager_operation op2, _)) -> + Z.compare op1.counter op2.counter + +let init ctxt block_header = + let level = block_header.Block_header.level in + let fitness = block_header.fitness in + let timestamp = block_header.timestamp in + let typecheck (ctxt : Alpha_context.context) + (script : Alpha_context.Script.t) = + let allow_forged_in_storage = + false + (* There should be no forged value in bootstrap contracts. *) + in + Script_ir_translator.parse_script + ctxt + ~legacy:false + ~allow_forged_in_storage + script + >>=? fun (Ex_script parsed_script, ctxt) -> + Script_ir_translator.extract_lazy_storage_diff + ctxt + Optimized + parsed_script.storage_type + parsed_script.storage + ~to_duplicate:Script_ir_translator.no_lazy_storage_id + ~to_update:Script_ir_translator.no_lazy_storage_id + ~temporary:false + >>=? fun (storage, lazy_storage_diff, ctxt) -> + Script_ir_translator.unparse_data + ctxt + Optimized + parsed_script.storage_type + storage + >|=? fun (storage, ctxt) -> + let storage = + Alpha_context.Script.lazy_expr (Micheline.strip_locations storage) + in + (({script with storage}, lazy_storage_diff), ctxt) + in + Alpha_context.prepare_first_block ~typecheck ~level ~timestamp ~fitness ctxt + >|=? fun ctxt -> Alpha_context.finalize ctxt + +(* Vanity nonce: 0000000710783884 *) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/main.mli b/src/proto_008_PtEdo2Zk/lib_protocol/main.mli new file mode 100644 index 0000000000000000000000000000000000000000..5b41eb2bf5d023510d230189bc01ce1e2d8198d3 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/main.mli @@ -0,0 +1,69 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos Protocol Implementation - Protocol Signature Instance *) + +type validation_mode = + | Application of { + block_header : Alpha_context.Block_header.t; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; + } + | Partial_application of { + block_header : Alpha_context.Block_header.t; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; + } + | Partial_construction of {predecessor : Block_hash.t} + | Full_construction of { + predecessor : Block_hash.t; + protocol_data : Alpha_context.Block_header.contents; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; + } + +type validation_state = { + mode : validation_mode; + chain_id : Chain_id.t; + ctxt : Alpha_context.t; + op_count : int; +} + +type operation_data = Alpha_context.packed_protocol_data + +type operation = Alpha_context.packed_operation = { + shell : Operation.shell_header; + protocol_data : operation_data; +} + +include + Updater.PROTOCOL + with type block_header_data = Alpha_context.Block_header.protocol_data + and type block_header_metadata = Apply_results.block_metadata + and type block_header = Alpha_context.Block_header.t + and type operation_data := operation_data + and type operation_receipt = Apply_results.packed_operation_metadata + and type operation := operation + and type validation_state := validation_state diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/manager_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/manager_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..b96a51401289eda7253721bd00572bce6009070a --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/manager_repr.ml @@ -0,0 +1,52 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *) + +type manager_key = + | Hash of Signature.Public_key_hash.t + | Public_key of Signature.Public_key.t + +type t = manager_key + +open Data_encoding + +let hash_case tag = + case + tag + ~title:"Public_key_hash" + Signature.Public_key_hash.encoding + (function Hash hash -> Some hash | _ -> None) + (fun hash -> Hash hash) + +let pubkey_case tag = + case + tag + ~title:"Public_key" + Signature.Public_key.encoding + (function Public_key hash -> Some hash | _ -> None) + (fun hash -> Public_key hash) + +let encoding = union [hash_case (Tag 0); pubkey_case (Tag 1)] diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/manager_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/manager_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..18ca236d71b1b3bd1b7c643078ecfbe9a34b4499 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/manager_repr.mli @@ -0,0 +1,38 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *) + +(** The public key of the manager of a contract is reveled only after the + first operation. At Origination time, the manager provides only the hash + of its public key that is stored in the contract. When the public key + is actually revealed, the public key instead of the hash of the key *) +type manager_key = + | Hash of Signature.Public_key_hash.t + | Public_key of Signature.Public_key.t + +type t = manager_key + +val encoding : t Data_encoding.encoding diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_gas.ml b/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_gas.ml new file mode 100644 index 0000000000000000000000000000000000000000..d3240e7401ccc4e9126c3720f4ef314827537eec --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_gas.ml @@ -0,0 +1,1463 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Gas + +module Cost_of = struct + module Z_syntax = struct + (* This is a good enough approximation. Z.numbits 0 = 0 *) + let log2 x = Z.of_int (1 + Z.numbits x) + + let ( + ) = Z.add + + let ( * ) = Z.mul + + let ( lsr ) = Z.shift_right + end + + let z_bytes (z : Z.t) = + let bits = Z.numbits z in + (7 + bits) / 8 + + let int_bytes (z : 'a Script_int.num) = z_bytes (Script_int.to_zint z) + + let timestamp_bytes (t : Script_timestamp.t) = + let z = Script_timestamp.to_zint t in + z_bytes z + + (* Upper-bound on the time to compare the given value. + For now, returns size in bytes, but this could get more complicated... *) + let rec size_of_comparable : + type a. a Script_typed_ir.comparable_ty -> a -> Z.t = + fun wit v -> + match (wit, v) with + | (Unit_key _, _) -> + Z.of_int 1 + | (Never_key _, _) -> + . + | (Int_key _, _) -> + Z.of_int (int_bytes v) + | (Nat_key _, _) -> + Z.of_int (int_bytes v) + | (Signature_key _, _) -> + Z.of_int Signature.size + | (String_key _, _) -> + Z.of_int (String.length v) + | (Bytes_key _, _) -> + Z.of_int (Bytes.length v) + | (Bool_key _, _) -> + Z.of_int 8 + | (Key_hash_key _, _) -> + Z.of_int Signature.Public_key_hash.size + | (Key_key _, k) -> + Z.of_int (Signature.Public_key.size k) + | (Timestamp_key _, _) -> + Z.of_int (timestamp_bytes v) + | (Address_key _, _) -> + Z.of_int Signature.Public_key_hash.size + | (Mutez_key _, _) -> + Z.of_int 8 + | (Chain_id_key _, _) -> + Z.of_int Chain_id.size + | (Pair_key ((l, _), (r, _), _), (lval, rval)) -> + Z.add (size_of_comparable l lval) (size_of_comparable r rval) + | (Union_key ((t, _), _, _), L x) -> + Z.add (Z.of_int 1) (size_of_comparable t x) + | (Union_key (_, (t, _), _), R x) -> + Z.add (Z.of_int 1) (size_of_comparable t x) + | (Option_key _, None) -> + Z.of_int 1 + | (Option_key (t, _), Some x) -> + Z.add (Z.of_int 1) (size_of_comparable t x) + + let manager_operation = step_cost @@ Z.of_int 1_000 + + (* FIXME: hardcoded constant, available in next environment version. + Set to a reasonable upper bound. *) + let public_key_size = 64 + + module Generated_costs_007 = struct + (* Automatically generated costs functions. *) + + (* model N_Abs_int *) + (* Approximating 0.068306 x term *) + let cost_N_Abs_int size = Z.of_int @@ (80 + (size lsr 4)) + + (* model N_Add_bls12_381_fr *) + + let cost_N_Add_bls12_381_fr = Z.of_int 230 + + (* model N_Add_bls12_381_g1 *) + + let cost_N_Add_bls12_381_g1 = Z.of_int 9_300 + + (* model N_Add_bls12_381_g2 *) + + let cost_N_Add_bls12_381_g2 = Z.of_int 13_000 + + (* model N_Add_intint *) + (* Approximating 0.082158 x term *) + let cost_N_Add_intint size1 size2 = + let v0 = Compare.Int.max size1 size2 in + Z.of_int (80 + ((v0 lsr 4) + (v0 lsr 6))) + + (* model N_Add_tez *) + let cost_N_Add_tez = Z.of_int 100 + + (* model N_And *) + let cost_N_And = Z.of_int 100 + + (* model N_And_nat *) + (* Approximating 0.079325 x term *) + let cost_N_And_nat size1 size2 = + let v0 = Compare.Int.min size1 size2 in + Z.of_int (80 + ((v0 lsr 4) + (v0 lsr 6))) + + (* model N_Blake2b *) + (* Approximating 1.366428 x term *) + let cost_N_Blake2b size = + let open Z_syntax in + let size = Z.of_int size in + Z.of_int 500 + (size + (size lsr 2)) + + (* model N_Car *) + let cost_N_Car = Z.of_int 80 + + (* model N_Cdr *) + let cost_N_Cdr = Z.of_int 80 + + (* model N_Check_signature_ed25519 *) + (* Approximating 1.372685 x term *) + let cost_N_Check_signature_ed25519 size = + let open Z_syntax in + let size = Z.of_int size in + Z.of_int 270_000 + (size + (size lsr 2)) + + (* model N_Check_signature_p256 *) + (* Approximating 1.385771 x term *) + let cost_N_Check_signature_p256 size = + let open Z_syntax in + let size = Z.of_int size in + Z.of_int 600_000 + (size + (size lsr 2) + (size lsr 3)) + + (* model N_Check_signature_secp256k1 *) + (* Approximating 1.372411 x term *) + let cost_N_Check_signature_secp256k1 size = + let open Z_syntax in + let size = Z.of_int size in + Z.of_int 60_000 + (size + (size lsr 2)) + + (* model N_Comb *) + (* Approximating 3.275337 x term *) + let cost_N_Comb size = Z.of_int (80 + ((3 * size) + (size lsr 2))) + + (* model N_Comb_get *) + (* Approximating 0.553178 x term *) + let cost_N_Comb_get size = Z.of_int (80 + ((size lsr 1) + (size lsr 4))) + + (* model N_Comb_set *) + (* Approximating 1.282976 x term *) + let cost_N_Comb_set size = Z.of_int (80 + (size + (size lsr 2))) + + (* model N_Compare_address *) + let cost_N_Compare_address size1 size2 = + Z.of_int (80 + (2 * Compare.Int.min size1 size2)) + + (* model N_Compare_bool *) + let cost_N_Compare_bool size1 size2 = + Z.of_int (80 + (128 * Compare.Int.min size1 size2)) + + (* model N_Compare_int *) + (* Approximating 0.073657 x term *) + let cost_N_Compare_int size1 size2 = + let v0 = Compare.Int.min size1 size2 in + Z.of_int (150 + ((v0 lsr 4) + (v0 lsr 7))) + + (* model N_Compare_key_hash *) + let cost_N_Compare_key_hash size1 size2 = + Z.of_int (80 + (2 * Compare.Int.min size1 size2)) + + (* model N_Compare_mutez *) + let cost_N_Compare_mutez size1 size2 = + Z.of_int (13 * Compare.Int.min size1 size2) + + (* model N_Compare_string *) + (* Approximating 0.039389 x term *) + let cost_N_Compare_string size1 size2 = + let v0 = Compare.Int.min size1 size2 in + Z.of_int (120 + ((v0 lsr 5) + (v0 lsr 7))) + + (* model N_Compare_timestamp *) + (* Approximating 0.072483 x term *) + let cost_N_Compare_timestamp size1 size2 = + let v0 = Compare.Int.min size1 size2 in + Z.of_int (140 + ((v0 lsr 4) + (v0 lsr 7))) + + (* model N_Concat_string_pair *) + (* Approximating 0.068808 x term *) + let cost_N_Concat_string_pair size1 size2 = + let open Z_syntax in + let v0 = Z.of_int size1 + Z.of_int size2 in + Z.of_int 80 + (v0 lsr 4) + + (* model N_Cons_list *) + let cost_N_Cons_list = Z.of_int 80 + + (* model N_Cons_none *) + let cost_N_Cons_none = Z.of_int 80 + + (* model N_Cons_pair *) + let cost_N_Cons_pair = Z.of_int 80 + + (* model N_Cons_some *) + let cost_N_Cons_some = Z.of_int 80 + + (* model N_Const *) + let cost_N_Const = Z.of_int 80 + + (* model N_Dig *) + let cost_N_Dig size = Z.of_int (100 + (4 * size)) + + (* model N_Dip *) + let cost_N_Dip = Z.of_int 100 + + (* model N_DipN *) + let cost_N_DipN size = Z.of_int (100 + (4 * size)) + + (* model N_Drop *) + let cost_N_Drop = Z.of_int 80 + + (* model N_DropN *) + let cost_N_DropN size = Z.of_int (100 + (4 * size)) + + (* model N_Dug *) + let cost_N_Dug size = Z.of_int (100 + (4 * size)) + + (* model N_Dup *) + let cost_N_Dup = Z.of_int 80 + + (* model N_DupN *) + (* Approximating 1.299969 x term *) + let cost_N_DupN size = Z.of_int (60 + size + (size lsr 2)) + + (* model N_Ediv_natnat *) + (* Approximating 0.001599 x term *) + let cost_N_Ediv_natnat size1 size2 = + let q = size1 - size2 in + if Compare.Int.(q < 0) then Z.of_int 300 + else + let open Z_syntax in + let v0 = Z.of_int q * Z.of_int size2 in + Z.of_int 300 + (v0 lsr 10) + (v0 lsr 11) + (v0 lsr 13) + + (* model N_Ediv_tez *) + let cost_N_Ediv_tez = Z.of_int 200 + + (* model N_Ediv_teznat *) + (* Extracted by hand from the empirical data *) + let cost_N_Ediv_teznat = Z.of_int 300 + + (* model N_Empty_map *) + let cost_N_Empty_map = Z.of_int 240 + + (* model N_Empty_set *) + let cost_N_Empty_set = Z.of_int 240 + + (* model N_Eq *) + let cost_N_Eq = Z.of_int 80 + + (* model N_If *) + let cost_N_If = Z.of_int 60 + + (* model N_If_cons *) + let cost_N_If_cons = Z.of_int 110 + + (* model N_If_left *) + let cost_N_If_left = Z.of_int 90 + + (* model N_If_none *) + let cost_N_If_none = Z.of_int 80 + + (* model N_Int_nat *) + let cost_N_Int_nat = Z.of_int 80 + + (* model N_Is_nat *) + let cost_N_Is_nat = Z.of_int 80 + + (* model N_Keccak *) + let cost_N_Keccak size = + let open Z_syntax in + Z.of_int 1_400 + (Z.of_int 30 * Z.of_int size) + + (* model N_Left *) + let cost_N_Left = Z.of_int 80 + + (* model N_List_iter *) + let cost_N_List_iter size = + let open Z_syntax in + Z.of_int 500 + (Z.of_int 7 * Z.of_int size) + + (* model N_List_map *) + let cost_N_List_map size = + let open Z_syntax in + Z.of_int 500 + (Z.of_int 12 * Z.of_int size) + + (* model N_List_size *) + let cost_N_List_size = Z.of_int 80 + + (* model N_Loop *) + let cost_N_Loop = Z.of_int 70 + + (* model N_Loop_left *) + let cost_N_Loop_left = Z.of_int 80 + + (* model N_Lsl_nat *) + (* Approximating 0.129443 x term *) + let cost_N_Lsl_nat size = Z.of_int (150 + (size lsr 3)) + + (* model N_Lsr_nat *) + (* Approximating 0.129435 x term *) + let cost_N_Lsr_nat size = Z.of_int (150 + (size lsr 3)) + + (* model N_Map_get *) + (* Approximating 0.057548 x term *) + let cost_N_Map_get size1 size2 = + let open Z_syntax in + let v0 = size1 * log2 (Z.of_int size2) in + Z.of_int 80 + (v0 lsr 5) + (v0 lsr 6) + (v0 lsr 7) + + (* model N_Map_iter *) + let cost_N_Map_iter size = + let open Z_syntax in + Z.of_int 80 + (Z.of_int 40 * Z.of_int size) + + (* model N_Map_map *) + let cost_N_Map_map size = + let open Z_syntax in + Z.of_int 80 + (Z.of_int 761 * Z.of_int size) + + (* model N_Map_mem *) + (* Approximating 0.058563 x term *) + let cost_N_Map_mem size1 size2 = + let open Z_syntax in + let v0 = size1 * log2 (Z.of_int size2) in + Z.of_int 80 + (v0 lsr 5) + (v0 lsr 6) + (v0 lsr 7) + + (* model N_Map_size *) + let cost_N_Map_size = Z.of_int 90 + + (* model N_Map_update *) + (* Approximating 0.119968 x term *) + let cost_N_Map_update size1 size2 = + let open Z_syntax in + let v0 = size1 * log2 (Z.of_int size2) in + Z.of_int 80 + (v0 lsr 4) + (v0 lsr 5) + (v0 lsr 6) + (v0 lsr 7) + + (* model N_Mul_bls12_381_fr *) + + let cost_N_Mul_bls12_381_fr = Z.of_int 260 + + (* model N_Mul_bls12_381_g1 *) + + let cost_N_Mul_bls12_381_g1 = Z.of_int 265_000 + + (* model N_Mul_bls12_381_g2 *) + + let cost_N_Mul_bls12_381_g2 = Z.of_int 850_000 + + (* Converting fr from/to Z.t *) + let cost_bls12_381_fr_of_z = Z.of_int 130 + + let cost_bls12_381_fr_to_z = Z.of_int 30 + + let cost_N_Mul_bls12_381_fr_z = + Z.add cost_bls12_381_fr_of_z cost_N_Mul_bls12_381_fr + + let cost_N_Int_bls12_381_fr = cost_bls12_381_fr_to_z + + (* model N_Mul_intint *) + let cost_N_Mul_intint size1 size2 = + let open Z_syntax in + let a = Z.of_int size1 + Z.of_int size2 in + Z.of_int 80 + (a * log2 a) + + (* model N_Mul_teznat *) + let cost_N_Mul_teznat size = + let open Z_syntax in + Z.of_int 200 + (Z.of_int 133 * Z.of_int size) + + (* model N_Neg_bls12_381_fr *) + + let cost_N_Neg_bls12_381_fr = Z.of_int 180 + + (* model N_Neg_bls12_381_g1 *) + + let cost_N_Neg_bls12_381_g1 = Z.of_int 410 + + (* model N_Neg_bls12_381_g2 *) + + let cost_N_Neg_bls12_381_g2 = Z.of_int 715 + + (* model N_Neg_int *) + (* Approximating 0.068419 x term *) + let cost_N_Neg_int size = Z.of_int (80 + (size lsr 4)) + + (* model N_Neq *) + let cost_N_Neq = Z.of_int 80 + + (* model N_Nil *) + let cost_N_Nil = Z.of_int 80 + + (* model N_Nop *) + let cost_N_Nop = Z.of_int 70 + + (* model N_Not *) + let cost_N_Not = Z.of_int 90 + + (* model N_Not_int *) + (* Approximating 0.076564 x term *) + let cost_N_Not_int size = Z.of_int (55 + ((size lsr 4) + (size lsr 7))) + + (* model N_Or *) + let cost_N_Or = Z.of_int 90 + + (* model N_Or_nat *) + (* Approximating 0.078718 x term *) + let cost_N_Or_nat size1 size2 = + let v0 = Compare.Int.max size1 size2 in + Z.of_int (80 + ((v0 lsr 4) + (v0 lsr 6))) + + (* model N_Pairing_check_bls12_381 *) + + let cost_N_Pairing_check_bls12_381 size = + Z.add (Z.of_int 1_550_000) (Z.mul (Z.of_int 510_000) (Z.of_int size)) + + (* model N_Right *) + let cost_N_Right = Z.of_int 80 + + (* model N_Seq *) + let cost_N_Seq = Z.of_int 60 + + (* model N_Set_iter *) + let cost_N_Set_iter size = + let open Z_syntax in + Z.of_int 80 + (Z.of_int 36 * Z.of_int size) + + (* model N_Set_mem *) + (* Approximating 0.059410 x term *) + let cost_N_Set_mem size1 size2 = + let open Z_syntax in + let v0 = size1 * log2 (Z.of_int size2) in + Z.of_int 80 + (v0 lsr 5) + (v0 lsr 6) + (v0 lsr 7) + (v0 lsr 8) + + (* model N_Set_size *) + let cost_N_Set_size = Z.of_int 80 + + (* model N_Set_update *) + (* Approximating 0.126260 x term *) + let cost_N_Set_update size1 size2 = + let open Z_syntax in + let v0 = size1 * log2 (Z.of_int size2) in + Z.of_int 80 + (v0 lsr 3) + + (* model N_Sha256 *) + let cost_N_Sha256 size = + let open Z_syntax in + Z.of_int 500 + (Z.of_int 5 * Z.of_int size) + + (* model N_Sha3 *) + let cost_N_Sha3 size = + let open Z_syntax in + Z.of_int 1_400 + (Z.of_int 32 * Z.of_int size) + + (* model N_Sha512 *) + let cost_N_Sha512 size = + let open Z_syntax in + Z.of_int 500 + (Z.of_int 3 * Z.of_int size) + + (* model N_Slice_string *) + (* Approximating 0.067048 x term *) + let cost_N_Slice_string size = Z.of_int (80 + (size lsr 4)) + + (* model N_String_size *) + let cost_N_String_size = Z.of_int 80 + + (* model N_Sub_int *) + (* Approximating 0.082399 x term *) + let cost_N_Sub_int size1 size2 = + let v0 = Compare.Int.max size1 size2 in + Z.of_int (80 + ((v0 lsr 4) + (v0 lsr 6))) + + (* model N_Sub_tez *) + let cost_N_Sub_tez = Z.of_int 80 + + (* model N_Swap *) + let cost_N_Swap = Z.of_int 70 + + (* model N_Total_voting_power *) + let cost_N_Total_voting_power = Z.of_int 400 + + (* model N_Uncomb *) + (* Approximating 3.666332 x term *) + let cost_N_Uncomb size = + Z.of_int (80 + ((3 * size) + (size lsr 1) + (size lsr 3))) + + (* model N_Unpair *) + let cost_N_Unpair = Z.of_int 80 + + (* model N_Voting_power *) + let cost_N_Voting_power = Z.of_int 400 + + (* model N_Xor *) + let cost_N_Xor = Z.of_int 100 + + (* model N_Xor_nat *) + (* Approximating 0.078258 x term *) + let cost_N_Xor_nat size1 size2 = + let v0 = Compare.Int.max size1 size2 in + Z.of_int (80 + ((v0 lsr 4) + (v0 lsr 6))) + + (* model DECODING_BLS_FR *) + + let cost_DECODING_BLS_FR = Z.of_int 50 + + (* model DECODING_BLS_G1 *) + + let cost_DECODING_BLS_G1 = Z.of_int 230_000 + + (* model DECODING_BLS_G2 *) + + let cost_DECODING_BLS_G2 = Z.of_int 740_000 + + (* model B58CHECK_DECODING_CHAIN_ID *) + let cost_B58CHECK_DECODING_CHAIN_ID = Z.of_int 1_500 + + (* model B58CHECK_DECODING_PUBLIC_KEY_HASH_ed25519 *) + let cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_ed25519 = Z.of_int 3_300 + + (* model B58CHECK_DECODING_PUBLIC_KEY_HASH_p256 *) + let cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_p256 = Z.of_int 3_300 + + (* model B58CHECK_DECODING_PUBLIC_KEY_HASH_secp256k1 *) + let cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_secp256k1 = Z.of_int 3_300 + + (* model B58CHECK_DECODING_PUBLIC_KEY_ed25519 *) + let cost_B58CHECK_DECODING_PUBLIC_KEY_ed25519 = Z.of_int 4_300 + + (* model B58CHECK_DECODING_PUBLIC_KEY_p256 *) + let cost_B58CHECK_DECODING_PUBLIC_KEY_p256 = Z.of_int 29_000 + + (* model B58CHECK_DECODING_PUBLIC_KEY_secp256k1 *) + let cost_B58CHECK_DECODING_PUBLIC_KEY_secp256k1 = Z.of_int 9_400 + + (* model B58CHECK_DECODING_SIGNATURE_ed25519 *) + let cost_B58CHECK_DECODING_SIGNATURE_ed25519 = Z.of_int 6_600 + + (* model B58CHECK_DECODING_SIGNATURE_p256 *) + let cost_B58CHECK_DECODING_SIGNATURE_p256 = Z.of_int 6_600 + + (* model B58CHECK_DECODING_SIGNATURE_secp256k1 *) + let cost_B58CHECK_DECODING_SIGNATURE_secp256k1 = Z.of_int 6_600 + + (* model ENCODING_BLS_FR *) + + let cost_ENCODING_BLS_FR = Z.of_int 30 + + (* model ENCODING_BLS_G1 *) + + let cost_ENCODING_BLS_G1 = Z.of_int 30 + + (* model ENCODING_BLS_G2 *) + + let cost_ENCODING_BLS_G2 = Z.of_int 30 + + (* model B58CHECK_ENCODING_CHAIN_ID *) + let cost_B58CHECK_ENCODING_CHAIN_ID = Z.of_int 1_600 + + (* model B58CHECK_ENCODING_PUBLIC_KEY_HASH_ed25519 *) + let cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_ed25519 = Z.of_int 3_300 + + (* model B58CHECK_ENCODING_PUBLIC_KEY_HASH_p256 *) + let cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_p256 = Z.of_int 3_750 + + (* model B58CHECK_ENCODING_PUBLIC_KEY_HASH_secp256k1 *) + let cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_secp256k1 = Z.of_int 3_300 + + (* model B58CHECK_ENCODING_PUBLIC_KEY_ed25519 *) + let cost_B58CHECK_ENCODING_PUBLIC_KEY_ed25519 = Z.of_int 4_500 + + (* model B58CHECK_ENCODING_PUBLIC_KEY_p256 *) + let cost_B58CHECK_ENCODING_PUBLIC_KEY_p256 = Z.of_int 5_300 + + (* model B58CHECK_ENCODING_PUBLIC_KEY_secp256k1 *) + let cost_B58CHECK_ENCODING_PUBLIC_KEY_secp256k1 = Z.of_int 5_000 + + (* model B58CHECK_ENCODING_SIGNATURE_ed25519 *) + let cost_B58CHECK_ENCODING_SIGNATURE_ed25519 = Z.of_int 8_700 + + (* model B58CHECK_ENCODING_SIGNATURE_p256 *) + let cost_B58CHECK_ENCODING_SIGNATURE_p256 = Z.of_int 8_700 + + (* model B58CHECK_ENCODING_SIGNATURE_secp256k1 *) + let cost_B58CHECK_ENCODING_SIGNATURE_secp256k1 = Z.of_int 8_700 + + (* model DECODING_CHAIN_ID *) + let cost_DECODING_CHAIN_ID = Z.of_int 50 + + (* model DECODING_PUBLIC_KEY_HASH_ed25519 *) + let cost_DECODING_PUBLIC_KEY_HASH_ed25519 = Z.of_int 50 + + (* model DECODING_PUBLIC_KEY_HASH_p256 *) + let cost_DECODING_PUBLIC_KEY_HASH_p256 = Z.of_int 60 + + (* model DECODING_PUBLIC_KEY_HASH_secp256k1 *) + let cost_DECODING_PUBLIC_KEY_HASH_secp256k1 = Z.of_int 60 + + (* model DECODING_PUBLIC_KEY_ed25519 *) + let cost_DECODING_PUBLIC_KEY_ed25519 = Z.of_int 60 + + (* model DECODING_PUBLIC_KEY_p256 *) + let cost_DECODING_PUBLIC_KEY_p256 = Z.of_int 25_000 + + (* model DECODING_PUBLIC_KEY_secp256k1 *) + let cost_DECODING_PUBLIC_KEY_secp256k1 = Z.of_int 5_300 + + (* model DECODING_SIGNATURE_ed25519 *) + let cost_DECODING_SIGNATURE_ed25519 = Z.of_int 30 + + (* model DECODING_SIGNATURE_p256 *) + let cost_DECODING_SIGNATURE_p256 = Z.of_int 30 + + (* model DECODING_SIGNATURE_secp256k1 *) + let cost_DECODING_SIGNATURE_secp256k1 = Z.of_int 30 + + (* model ENCODING_CHAIN_ID *) + let cost_ENCODING_CHAIN_ID = Z.of_int 50 + + (* model ENCODING_PUBLIC_KEY_HASH_ed25519 *) + let cost_ENCODING_PUBLIC_KEY_HASH_ed25519 = Z.of_int 70 + + (* model ENCODING_PUBLIC_KEY_HASH_p256 *) + let cost_ENCODING_PUBLIC_KEY_HASH_p256 = Z.of_int 80 + + (* model ENCODING_PUBLIC_KEY_HASH_secp256k1 *) + let cost_ENCODING_PUBLIC_KEY_HASH_secp256k1 = Z.of_int 70 + + (* model ENCODING_PUBLIC_KEY_ed25519 *) + let cost_ENCODING_PUBLIC_KEY_ed25519 = Z.of_int 80 + + (* model ENCODING_PUBLIC_KEY_p256 *) + let cost_ENCODING_PUBLIC_KEY_p256 = Z.of_int 450 + + (* model ENCODING_PUBLIC_KEY_secp256k1 *) + let cost_ENCODING_PUBLIC_KEY_secp256k1 = Z.of_int 490 + + (* model ENCODING_SIGNATURE_ed25519 *) + let cost_ENCODING_SIGNATURE_ed25519 = Z.of_int 40 + + (* model ENCODING_SIGNATURE_p256 *) + let cost_ENCODING_SIGNATURE_p256 = Z.of_int 40 + + (* model ENCODING_SIGNATURE_secp256k1 *) + let cost_ENCODING_SIGNATURE_secp256k1 = Z.of_int 40 + + (* model TIMESTAMP_READABLE_DECODING *) + let cost_TIMESTAMP_READABLE_DECODING = Z.of_int 130 + + (* model TIMESTAMP_READABLE_ENCODING *) + let cost_TIMESTAMP_READABLE_ENCODING = Z.of_int 900 + + (* model CHECK_PRINTABLE *) + let cost_CHECK_PRINTABLE size = + let open Z_syntax in + Z.of_int 14 + (Z.of_int 10 * Z.of_int size) + + (* model MERGE_TYPES + This is the estimated cost of one iteration of merge_types, extracted + and copied manually from the parameter fit for the MERGE_TYPES benchmark + (the model is parametric on the size of the type, which we don't have + access to in O(1)). *) + let cost_MERGE_TYPES = Z.of_int 130 + + (* model TYPECHECKING_CODE + This is the cost of one iteration of parse_instr, extracted by hand from the + parameter fit for the TYPECHECKING_CODE benchmark. *) + let cost_TYPECHECKING_CODE = Z.of_int 375 + + (* model UNPARSING_CODE + This is the cost of one iteration of unparse_instr, extracted by hand from the + parameter fit for the UNPARSING_CODE benchmark. *) + let cost_UNPARSING_CODE = Z.of_int 200 + + (* model TYPECHECKING_DATA + This is the cost of one iteration of parse_data, extracted by hand from the + parameter fit for the TYPECHECKING_DATA benchmark. *) + let cost_TYPECHECKING_DATA = Z.of_int 240 + + (* model UNPARSING_DATA + This is the cost of one iteration of unparse_data, extracted by hand from the + parameter fit for the UNPARSING_DATA benchmark. *) + let cost_UNPARSING_DATA = Z.of_int 140 + + (* model PARSE_TYPE + This is the cost of one iteration of parse_ty, extracted by hand from the + parameter fit for the PARSE_TYPE benchmark. *) + let cost_PARSE_TYPE = Z.of_int 170 + + (* model UNPARSE_TYPE + This is the cost of one iteration of unparse_ty, extracted by hand from the + parameter fit for the UNPARSE_TYPE benchmark. *) + let cost_UNPARSE_TYPE = Z.of_int 185 + + (* TODO: benchmark *) + let cost_COMPARABLE_TY_OF_TY = Z.of_int 120 + end + + module Interpreter = struct + open Generated_costs_007 + + let drop = atomic_step_cost cost_N_Drop + + let dup = atomic_step_cost cost_N_Dup + + let swap = atomic_step_cost cost_N_Swap + + let push = atomic_step_cost cost_N_Const + + let cons_some = atomic_step_cost cost_N_Cons_some + + let cons_none = atomic_step_cost cost_N_Cons_none + + let if_none = atomic_step_cost cost_N_If_none + + let cons_pair = atomic_step_cost cost_N_Cons_pair + + let unpair = atomic_step_cost cost_N_Unpair + + let car = atomic_step_cost cost_N_Car + + let cdr = atomic_step_cost cost_N_Cdr + + let cons_left = atomic_step_cost cost_N_Left + + let cons_right = atomic_step_cost cost_N_Right + + let if_left = atomic_step_cost cost_N_If_left + + let cons_list = atomic_step_cost cost_N_Cons_list + + let nil = atomic_step_cost cost_N_Nil + + let if_cons = atomic_step_cost cost_N_If_cons + + let list_map : 'a Script_typed_ir.boxed_list -> Gas.cost = + fun {length; _} -> atomic_step_cost (cost_N_List_map length) + + let list_size = atomic_step_cost cost_N_List_size + + let list_iter : 'a Script_typed_ir.boxed_list -> Gas.cost = + fun {length; _} -> atomic_step_cost (cost_N_List_iter length) + + let empty_set = atomic_step_cost cost_N_Empty_set + + let set_iter (type a) ((module Box) : a Script_typed_ir.set) = + atomic_step_cost (cost_N_Set_iter Box.size) + + let set_mem (type a) (elt : a) ((module Box) : a Script_typed_ir.set) = + let elt_size = size_of_comparable Box.elt_ty elt in + atomic_step_cost (cost_N_Set_mem elt_size Box.size) + + let set_update (type a) (elt : a) ((module Box) : a Script_typed_ir.set) = + let elt_size = size_of_comparable Box.elt_ty elt in + atomic_step_cost (cost_N_Set_update elt_size Box.size) + + let set_size = atomic_step_cost cost_N_Set_size + + let empty_map = atomic_step_cost cost_N_Empty_map + + let map_map (type k v) ((module Box) : (k, v) Script_typed_ir.map) = + atomic_step_cost (cost_N_Map_map (snd Box.boxed)) + + let map_iter (type k v) ((module Box) : (k, v) Script_typed_ir.map) = + atomic_step_cost (cost_N_Map_iter (snd Box.boxed)) + + let map_mem (type k v) (elt : k) + ((module Box) : (k, v) Script_typed_ir.map) = + let elt_size = size_of_comparable Box.key_ty elt in + atomic_step_cost (cost_N_Map_mem elt_size (snd Box.boxed)) + + let map_get (type k v) (elt : k) + ((module Box) : (k, v) Script_typed_ir.map) = + let elt_size = size_of_comparable Box.key_ty elt in + atomic_step_cost (cost_N_Map_get elt_size (snd Box.boxed)) + + let map_update (type k v) (elt : k) + ((module Box) : (k, v) Script_typed_ir.map) = + let elt_size = size_of_comparable Box.key_ty elt in + atomic_step_cost (cost_N_Map_update elt_size (snd Box.boxed)) + + let map_get_and_update (type k v) (elt : k) + (m : (k, v) Script_typed_ir.map) = + map_get elt m +@ map_update elt m + + let map_size = atomic_step_cost cost_N_Map_size + + let add_seconds_timestamp : + 'a Script_int.num -> Script_timestamp.t -> Gas.cost = + fun seconds timestamp -> + let seconds_bytes = int_bytes seconds in + let timestamp_bytes = z_bytes (Script_timestamp.to_zint timestamp) in + atomic_step_cost (cost_N_Add_intint seconds_bytes timestamp_bytes) + + let sub_seconds_timestamp : + 'a Script_int.num -> Script_timestamp.t -> Gas.cost = + fun seconds timestamp -> + let seconds_bytes = int_bytes seconds in + let timestamp_bytes = z_bytes (Script_timestamp.to_zint timestamp) in + atomic_step_cost (cost_N_Sub_int seconds_bytes timestamp_bytes) + + let diff_timestamps t1 t2 = + let t1_bytes = z_bytes (Script_timestamp.to_zint t1) in + let t2_bytes = z_bytes (Script_timestamp.to_zint t2) in + atomic_step_cost (cost_N_Sub_int t1_bytes t2_bytes) + + let concat_string_pair s1 s2 = + atomic_step_cost + (cost_N_Concat_string_pair (String.length s1) (String.length s2)) + + let slice_string s = + atomic_step_cost (cost_N_Slice_string (String.length s)) + + let string_size = atomic_step_cost cost_N_String_size + + let concat_bytes_pair b1 b2 = + atomic_step_cost + (cost_N_Concat_string_pair (Bytes.length b1) (Bytes.length b2)) + + let slice_bytes b = atomic_step_cost (cost_N_Slice_string (Bytes.length b)) + + let bytes_size = atomic_step_cost cost_N_String_size + + let add_tez = atomic_step_cost cost_N_Add_tez + + let sub_tez = atomic_step_cost cost_N_Sub_tez + + let mul_teznat n = atomic_step_cost (cost_N_Mul_teznat (int_bytes n)) + + let bool_or = atomic_step_cost cost_N_Or + + let bool_and = atomic_step_cost cost_N_And + + let bool_xor = atomic_step_cost cost_N_Xor + + let bool_not = atomic_step_cost cost_N_Not + + let is_nat = atomic_step_cost cost_N_Is_nat + + let abs_int i = atomic_step_cost (cost_N_Abs_int (int_bytes i)) + + let int_nat = atomic_step_cost cost_N_Int_nat + + let neg_int i = atomic_step_cost (cost_N_Neg_int (int_bytes i)) + + let neg_nat n = atomic_step_cost (cost_N_Neg_int (int_bytes n)) + + let add_bigint i1 i2 = + atomic_step_cost (cost_N_Add_intint (int_bytes i1) (int_bytes i2)) + + let sub_bigint i1 i2 = + atomic_step_cost (cost_N_Sub_int (int_bytes i1) (int_bytes i2)) + + let mul_bigint i1 i2 = + atomic_step_cost (cost_N_Mul_intint (int_bytes i1) (int_bytes i2)) + + let ediv_teznat _tez _n = atomic_step_cost cost_N_Ediv_teznat + + let ediv_tez = atomic_step_cost cost_N_Ediv_tez + + let ediv_bigint i1 i2 = + atomic_step_cost (cost_N_Ediv_natnat (int_bytes i1) (int_bytes i2)) + + let eq = atomic_step_cost cost_N_Eq + + let lsl_nat shifted = atomic_step_cost (cost_N_Lsl_nat (int_bytes shifted)) + + let lsr_nat shifted = atomic_step_cost (cost_N_Lsr_nat (int_bytes shifted)) + + let or_nat n1 n2 = + atomic_step_cost (cost_N_Or_nat (int_bytes n1) (int_bytes n2)) + + let and_nat n1 n2 = + atomic_step_cost (cost_N_And_nat (int_bytes n1) (int_bytes n2)) + + let xor_nat n1 n2 = + atomic_step_cost (cost_N_Xor_nat (int_bytes n1) (int_bytes n2)) + + let not_int i = atomic_step_cost (cost_N_Not_int (int_bytes i)) + + let not_nat = not_int + + let seq = atomic_step_cost cost_N_Seq + + let if_ = atomic_step_cost cost_N_If + + let loop = atomic_step_cost cost_N_Loop + + let loop_left = atomic_step_cost cost_N_Loop_left + + let dip = atomic_step_cost cost_N_Dip + + let check_signature (pkey : Signature.public_key) b = + let cost = + match pkey with + | Ed25519 _ -> + cost_N_Check_signature_ed25519 (Bytes.length b) + | Secp256k1 _ -> + cost_N_Check_signature_secp256k1 (Bytes.length b) + | P256 _ -> + cost_N_Check_signature_p256 (Bytes.length b) + in + atomic_step_cost cost + + let blake2b b = atomic_step_cost (cost_N_Blake2b (Bytes.length b)) + + let sha256 b = atomic_step_cost (cost_N_Sha256 (Bytes.length b)) + + let sha512 b = atomic_step_cost (cost_N_Sha512 (Bytes.length b)) + + let dign n = atomic_step_cost (cost_N_Dig n) + + let dugn n = atomic_step_cost (cost_N_Dug n) + + let dipn n = atomic_step_cost (cost_N_DipN n) + + let dropn n = atomic_step_cost (cost_N_DropN n) + + let voting_power = atomic_step_cost cost_N_Voting_power + + let total_voting_power = atomic_step_cost cost_N_Total_voting_power + + let keccak b = atomic_step_cost (cost_N_Keccak (Bytes.length b)) + + let sha3 b = atomic_step_cost (cost_N_Sha3 (Bytes.length b)) + + let add_bls12_381_g1 = atomic_step_cost cost_N_Add_bls12_381_g1 + + let add_bls12_381_g2 = atomic_step_cost cost_N_Add_bls12_381_g2 + + let add_bls12_381_fr = atomic_step_cost cost_N_Add_bls12_381_fr + + let mul_bls12_381_g1 = atomic_step_cost cost_N_Mul_bls12_381_g1 + + let mul_bls12_381_g2 = atomic_step_cost cost_N_Mul_bls12_381_g2 + + let mul_bls12_381_fr = atomic_step_cost cost_N_Mul_bls12_381_fr + + let mul_bls12_381_fr_z = atomic_step_cost cost_N_Mul_bls12_381_fr_z + + let int_bls12_381_fr = atomic_step_cost cost_N_Int_bls12_381_fr + + let neg_bls12_381_g1 = atomic_step_cost cost_N_Neg_bls12_381_g1 + + let neg_bls12_381_g2 = atomic_step_cost cost_N_Neg_bls12_381_g2 + + let neg_bls12_381_fr = atomic_step_cost cost_N_Neg_bls12_381_fr + + let neq = atomic_step_cost cost_N_Neq + + let nop = atomic_step_cost cost_N_Nop + + let pairing_check_bls12_381 (l : 'a Script_typed_ir.boxed_list) = + atomic_step_cost (cost_N_Pairing_check_bls12_381 l.length) + + let comb n = atomic_step_cost (cost_N_Comb n) + + let uncomb n = atomic_step_cost (cost_N_Uncomb n) + + let comb_get n = atomic_step_cost (cost_N_Comb_get n) + + let comb_set n = atomic_step_cost (cost_N_Comb_set n) + + let dupn n = atomic_step_cost (cost_N_DupN n) + + let sapling_verify_update ~inputs ~outputs = + let open Z_syntax in + atomic_step_cost + ( Z.of_int 85_000 + + (Z.of_int inputs * Z.of_int 4) + + (Z.of_int outputs * Z.of_int 30) ) + + (* --------------------------------------------------------------------- *) + (* Semi-hand-crafted models *) + let compare_unit = atomic_step_cost (Z.of_int 10) + + let compare_union_tag = atomic_step_cost (Z.of_int 10) + + let compare_option_tag = atomic_step_cost (Z.of_int 10) + + let compare_bool = atomic_step_cost (cost_N_Compare_bool 1 1) + + let compare_signature = atomic_step_cost (Z.of_int 92) + + let compare_string s1 s2 = + atomic_step_cost + (cost_N_Compare_string (String.length s1) (String.length s2)) + + let compare_bytes b1 b2 = + atomic_step_cost + (cost_N_Compare_string (Bytes.length b1) (Bytes.length b2)) + + let compare_mutez = atomic_step_cost (cost_N_Compare_mutez 8 8) + + let compare_int i1 i2 = + atomic_step_cost (cost_N_Compare_int (int_bytes i1) (int_bytes i2)) + + let compare_nat n1 n2 = + atomic_step_cost (cost_N_Compare_int (int_bytes n1) (int_bytes n2)) + + let compare_key_hash = + let sz = Signature.Public_key_hash.size in + atomic_step_cost (cost_N_Compare_key_hash sz sz) + + let compare_key = atomic_step_cost (Z.of_int 92) + + let compare_timestamp t1 t2 = + atomic_step_cost + (cost_N_Compare_timestamp + (z_bytes (Script_timestamp.to_zint t1)) + (z_bytes (Script_timestamp.to_zint t2))) + + let compare_address = + let sz = Signature.Public_key_hash.size + Chain_id.size in + atomic_step_cost (cost_N_Compare_address sz sz) + + let compare_chain_id = atomic_step_cost (Z.of_int 30) + + let rec compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost + = + fun ty x y -> + match ty with + | Unit_key _ -> + compare_unit + | Never_key _ -> ( + match x with _ -> . ) + | Bool_key _ -> + compare_bool + | String_key _ -> + compare_string x y + | Signature_key _ -> + compare_signature + | Bytes_key _ -> + compare_bytes x y + | Mutez_key _ -> + compare_mutez + | Int_key _ -> + compare_int x y + | Nat_key _ -> + compare_nat x y + | Key_hash_key _ -> + compare_key_hash + | Key_key _ -> + compare_key + | Timestamp_key _ -> + compare_timestamp x y + | Address_key _ -> + compare_address + | Chain_id_key _ -> + compare_chain_id + | Pair_key ((tl, _), (tr, _), _) -> + (* Reasonable over-approximation of the cost of lexicographic comparison. *) + let (xl, xr) = x in + let (yl, yr) = y in + compare tl xl yl +@ compare tr xr yr + | Union_key ((tl, _), (tr, _), _) -> ( + compare_union_tag + +@ + match (x, y) with + | (L x, L y) -> + compare tl x y + | (L _, R _) -> + free + | (R _, L _) -> + free + | (R x, R y) -> + compare tr x y ) + | Option_key (t, _) -> ( + compare_option_tag + +@ + match (x, y) with + | (None, None) -> + free + | (None, Some _) -> + free + | (Some _, None) -> + free + | (Some x, Some y) -> + compare t x y ) + + (* --------------------------------------------------------------------- *) + (* Hand-crafted models *) + + (* The cost functions below where not benchmarked, a cost model was derived + from looking at similar instructions. *) + + let sapling_empty_state = empty_map + + (* Cost for Concat_string is paid in two steps: when entering the interpreter, + the user pays for the cost of computing the information necessary to compute + the actual gas (so it's meta-gas): indeed, one needs to run through the + list of strings to compute the total allocated cost. + [concat_string_precheck] corresponds to the meta-gas cost of this computation. + *) + let concat_string_precheck (l : 'a Script_typed_ir.boxed_list) = + (* we set the precheck to be slightly more expensive than cost_N_List_iter *) + atomic_step_cost (Z.mul (Z.of_int l.length) (Z.of_int 10)) + + (* This is the cost of allocating a string and blitting existing ones into it. *) + let concat_string total_bytes = + atomic_step_cost + Z.(add (of_int 100) (fst (ediv_rem total_bytes (of_int 10)))) + + (* Same story as Concat_string. *) + let concat_bytes total_bytes = + atomic_step_cost + Z.(add (of_int 100) (fst (ediv_rem total_bytes (of_int 10)))) + + (* Cost of additional call to logger + overhead of setting up call to [interp]. *) + let exec = atomic_step_cost (Z.of_int 100) + + (* Heavy computation happens in the [unparse_data], [unparse_ty] + functions which are carbonated. We must account for allocating + the Micheline lambda wrapper. *) + let apply = atomic_step_cost (Z.of_int 1000) + + (* Pushing a pointer on the stack. *) + let lambda = push + + (* Pusing an address on the stack. *) + let address = push + + (* Most computation happens in [parse_contract_from_script], which is carbonated. + Account for pushing on the stack. *) + let contract = push + + (* Most computation happens in [collect_lazy_storage], [extract_lazy_storage_diff] + and [unparse_data] which are carbonated. The instruction-specific overhead + is mostly that of updating the internal nonce, which we approximate by the + cost of a push. *) + let transfer_tokens = Gas.(push +@ push) + + (* Wrapping a value and pushing it on the stack. *) + let implicit_account = push + + (* As for [transfer_token], most computation happens elsewhere. + We still account for the overhead of updating the internal_nonce. *) + let create_contract = Gas.(push +@ push) + + (* Increments the internal_nonce counter. *) + let set_delegate = Gas.(push +@ push) + + (* Cost of access taken care of in Contract_storage.get_balance_carbonated *) + let balance = Gas.free + + (* Accessing the raw_context, Small arithmetic & pushing on the stack. *) + let level = atomic_step_cost (Z.mul (Z.of_int 2) cost_N_Const) + + (* Same as [cost_level] *) + let now = level + + (* Public keys are hashed with Blake2b *) + let hash_key _pk = atomic_step_cost (cost_N_Blake2b public_key_size) + + (* Pushes on the stack an element from the [step_constants] record. *) + let source = push + + (* Same as cost_source *) + let sender = source + + (* Same as cost_source *) + let self = source + + (* Same as cost_source *) + let self_address = source + + (* Same as cost_source *) + let amount = source + + (* Same as cost_source *) + let chain_id = source + + (* TODO benchmark *) + (* FIXME: imported from 006, needs proper benchmarks *) + let unpack_failed bytes = + (* We cannot instrument failed deserialization, + so we take worst case fees: a set of size 1 bytes values. *) + let len = Z.of_int (Bytes.length bytes) in + (len *@ alloc_mbytes_cost 1) + +@ len + *@ ( Z.of_int (Z.numbits len) + *@ (alloc_cost (Z.of_int 3) +@ step_cost Z.one) ) + + let ticket = atomic_step_cost (Z.of_int 80) + + let read_ticket = atomic_step_cost (Z.of_int 80) + + let split_ticket ticket_amount amount_a amount_b = + ticket + +@ add_bigint amount_a amount_b + +@ compare_nat ticket_amount ticket_amount + + let join_tickets : + 'a Script_typed_ir.comparable_ty -> + 'a Script_typed_ir.ticket -> + 'a Script_typed_ir.ticket -> + Gas.cost = + fun ty ticket_a ticket_b -> + ticket +@ compare_address + +@ add_bigint ticket_a.amount ticket_b.amount + +@ compare ty ticket_a.contents ticket_b.contents + end + + module Typechecking = struct + open Generated_costs_007 + + let public_key_optimized = + atomic_step_cost + @@ Compare.Z.( + max + cost_DECODING_PUBLIC_KEY_ed25519 + (max + cost_DECODING_PUBLIC_KEY_secp256k1 + cost_DECODING_PUBLIC_KEY_p256)) + + let public_key_readable = + atomic_step_cost + @@ Compare.Z.( + max + cost_B58CHECK_DECODING_PUBLIC_KEY_ed25519 + (max + cost_B58CHECK_DECODING_PUBLIC_KEY_secp256k1 + cost_B58CHECK_DECODING_PUBLIC_KEY_p256)) + + let key_hash_optimized = + atomic_step_cost + @@ Compare.Z.( + max + cost_DECODING_PUBLIC_KEY_HASH_ed25519 + (max + cost_DECODING_PUBLIC_KEY_HASH_secp256k1 + cost_DECODING_PUBLIC_KEY_HASH_p256)) + + let key_hash_readable = + atomic_step_cost + @@ Compare.Z.( + max + cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_ed25519 + (max + cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_secp256k1 + cost_B58CHECK_DECODING_PUBLIC_KEY_HASH_p256)) + + let signature_optimized = + atomic_step_cost + @@ Compare.Z.( + max + cost_DECODING_SIGNATURE_ed25519 + (max + cost_DECODING_SIGNATURE_secp256k1 + cost_DECODING_SIGNATURE_p256)) + + let signature_readable = + atomic_step_cost + @@ Compare.Z.( + max + cost_B58CHECK_DECODING_SIGNATURE_ed25519 + (max + cost_B58CHECK_DECODING_SIGNATURE_secp256k1 + cost_B58CHECK_DECODING_SIGNATURE_p256)) + + let chain_id_optimized = atomic_step_cost cost_DECODING_CHAIN_ID + + let chain_id_readable = atomic_step_cost cost_B58CHECK_DECODING_CHAIN_ID + + (* Reasonable approximation *) + let address_optimized = key_hash_optimized + + (* Reasonable approximation *) + let contract_optimized = key_hash_optimized + + (* Reasonable approximation *) + let contract_readable = key_hash_readable + + let bls12_381_g1 = atomic_step_cost cost_DECODING_BLS_G1 + + let bls12_381_g2 = atomic_step_cost cost_DECODING_BLS_G2 + + let bls12_381_fr = atomic_step_cost cost_DECODING_BLS_FR + + let check_printable s = + atomic_step_cost (cost_CHECK_PRINTABLE (String.length s)) + + let merge_cycle = atomic_step_cost cost_MERGE_TYPES + + let parse_type_cycle = atomic_step_cost cost_PARSE_TYPE + + let parse_instr_cycle = atomic_step_cost cost_TYPECHECKING_CODE + + let parse_data_cycle = atomic_step_cost cost_TYPECHECKING_DATA + + let comparable_ty_of_ty_cycle = atomic_step_cost cost_COMPARABLE_TY_OF_TY + + (* Cost of a cycle of checking that a type is dupable *) + (* TODO: bench *) + let check_dupable_cycle = atomic_step_cost cost_TYPECHECKING_DATA + + let bool = free + + let unit = free + + let timestamp_readable = atomic_step_cost cost_TIMESTAMP_READABLE_DECODING + + (* Reasonable estimate. *) + let contract = Gas.(Z.of_int 2 *@ public_key_readable) + + (* Assuming unflattened storage: /contracts/hash1/.../hash6/key/balance, + balance stored on 64 bits *) + let contract_exists = + Gas.cost_of_repr + @@ Storage_costs.read_access ~path_length:9 ~read_bytes:8 + + (* Constructing proof arguments consists in a decreasing loop in the result + monad, allocating at each step. We charge a reasonable overapproximation. *) + let proof_argument n = atomic_step_cost (Z.mul (Z.of_int n) (Z.of_int 50)) + end + + module Unparsing = struct + open Generated_costs_007 + + let public_key_optimized = + atomic_step_cost + @@ Compare.Z.( + max + cost_ENCODING_PUBLIC_KEY_ed25519 + (max + cost_ENCODING_PUBLIC_KEY_secp256k1 + cost_ENCODING_PUBLIC_KEY_p256)) + + let public_key_readable = + atomic_step_cost + @@ Compare.Z.( + max + cost_B58CHECK_ENCODING_PUBLIC_KEY_ed25519 + (max + cost_B58CHECK_ENCODING_PUBLIC_KEY_secp256k1 + cost_B58CHECK_ENCODING_PUBLIC_KEY_p256)) + + let key_hash_optimized = + atomic_step_cost + @@ Compare.Z.( + max + cost_ENCODING_PUBLIC_KEY_HASH_ed25519 + (max + cost_ENCODING_PUBLIC_KEY_HASH_secp256k1 + cost_ENCODING_PUBLIC_KEY_HASH_p256)) + + let key_hash_readable = + atomic_step_cost + @@ Compare.Z.( + max + cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_ed25519 + (max + cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_secp256k1 + cost_B58CHECK_ENCODING_PUBLIC_KEY_HASH_p256)) + + let signature_optimized = + atomic_step_cost + @@ Compare.Z.( + max + cost_ENCODING_SIGNATURE_ed25519 + (max + cost_ENCODING_SIGNATURE_secp256k1 + cost_ENCODING_SIGNATURE_p256)) + + let signature_readable = + atomic_step_cost + @@ Compare.Z.( + max + cost_B58CHECK_ENCODING_SIGNATURE_ed25519 + (max + cost_B58CHECK_ENCODING_SIGNATURE_secp256k1 + cost_B58CHECK_ENCODING_SIGNATURE_p256)) + + let chain_id_optimized = atomic_step_cost cost_ENCODING_CHAIN_ID + + let chain_id_readable = atomic_step_cost cost_B58CHECK_ENCODING_CHAIN_ID + + let timestamp_readable = atomic_step_cost cost_TIMESTAMP_READABLE_ENCODING + + (* Reasonable approximation *) + let address_optimized = key_hash_optimized + + (* Reasonable approximation *) + let contract_optimized = key_hash_optimized + + (* Reasonable approximation *) + let contract_readable = key_hash_readable + + let bls12_381_g1 = atomic_step_cost cost_ENCODING_BLS_G1 + + let bls12_381_g2 = atomic_step_cost cost_ENCODING_BLS_G2 + + let bls12_381_fr = atomic_step_cost cost_ENCODING_BLS_FR + + let unparse_type_cycle = atomic_step_cost cost_UNPARSE_TYPE + + let unparse_instr_cycle = atomic_step_cost cost_UNPARSING_CODE + + let unparse_data_cycle = atomic_step_cost cost_UNPARSING_DATA + + let unit = Gas.free + + (* Reasonable estimate. *) + let contract = Gas.(Z.of_int 2 *@ public_key_readable) + + (* Reuse 006 costs. *) + let operation bytes = Script.bytes_node_cost bytes + + let sapling_transaction _t = + (* TODO should it be scaled? *) + (* let size = Data_encoding.Binary.length Sapling.transaction_encoding t in *) + (* string_cost size *) + Gas.free + + let sapling_diff _d = + (* TODO should it be scaled? *) + (* let size = Data_encoding.Binary.length Sapling.diff_encoding d in *) + (* string_cost size *) + Gas.free + end +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_gas.mli b/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_gas.mli new file mode 100644 index 0000000000000000000000000000000000000000..1ed46de6eed6156518493d2d924c0c115a3d1f1f --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_gas.mli @@ -0,0 +1,411 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +module Cost_of : sig + val manager_operation : Gas.cost + + module Interpreter : sig + val drop : Gas.cost + + val dup : Gas.cost + + val swap : Gas.cost + + val push : Gas.cost + + val cons_some : Gas.cost + + val cons_none : Gas.cost + + val if_none : Gas.cost + + val cons_pair : Gas.cost + + val unpair : Gas.cost + + val car : Gas.cost + + val cdr : Gas.cost + + val cons_left : Gas.cost + + val cons_right : Gas.cost + + val if_left : Gas.cost + + val cons_list : Gas.cost + + val nil : Gas.cost + + val if_cons : Gas.cost + + val list_map : 'a Script_typed_ir.boxed_list -> Gas.cost + + val list_size : Gas.cost + + val list_iter : 'a Script_typed_ir.boxed_list -> Gas.cost + + val empty_set : Gas.cost + + val set_iter : 'a Script_typed_ir.set -> Gas.cost + + val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost + + val set_update : 'a -> 'a Script_typed_ir.set -> Gas.cost + + val set_size : Gas.cost + + val empty_map : Gas.cost + + val map_map : ('k, 'v) Script_typed_ir.map -> Gas.cost + + val map_iter : ('k, 'v) Script_typed_ir.map -> Gas.cost + + val map_mem : 'k -> ('k, 'v) Script_typed_ir.map -> Gas.cost + + val map_get : 'k -> ('k, 'v) Script_typed_ir.map -> Gas.cost + + val map_update : 'k -> ('k, 'v) Script_typed_ir.map -> Gas.cost + + val map_get_and_update : 'k -> ('k, 'v) Script_typed_ir.map -> Gas.cost + + val map_size : Gas.cost + + val add_seconds_timestamp : + 'a Script_int.num -> Script_timestamp.t -> Gas.cost + + val sub_seconds_timestamp : + 'a Script_int.num -> Script_timestamp.t -> Gas.cost + + val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost + + val concat_string_pair : string -> string -> Gas.cost + + val slice_string : string -> Gas.cost + + val string_size : Gas.cost + + val concat_bytes_pair : bytes -> bytes -> Gas.cost + + val slice_bytes : bytes -> Gas.cost + + val bytes_size : Gas.cost + + val add_tez : Gas.cost + + val sub_tez : Gas.cost + + val mul_teznat : 'a Script_int.num -> Gas.cost + + val bool_or : Gas.cost + + val bool_and : Gas.cost + + val bool_xor : Gas.cost + + val bool_not : Gas.cost + + val is_nat : Gas.cost + + val abs_int : 'a Script_int.num -> Gas.cost + + val int_nat : Gas.cost + + val neg_int : 'a Script_int.num -> Gas.cost + + val neg_nat : 'a Script_int.num -> Gas.cost + + val add_bigint : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + + val sub_bigint : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + + val mul_bigint : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + + val ediv_teznat : 'a -> 'b Script_int.num -> Gas.cost + + val ediv_tez : Gas.cost + + val ediv_bigint : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + + val eq : Gas.cost + + val lsl_nat : 'a Script_int.num -> Gas.cost + + val lsr_nat : 'a Script_int.num -> Gas.cost + + val or_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + + val and_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + + val xor_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + + val not_int : 'a Script_int.num -> Gas.cost + + val not_nat : 'a Script_int.num -> Gas.cost + + val seq : Gas.cost + + val if_ : Gas.cost + + val loop : Gas.cost + + val loop_left : Gas.cost + + val dip : Gas.cost + + val check_signature : Signature.public_key -> bytes -> Gas.cost + + val blake2b : bytes -> Gas.cost + + val sha256 : bytes -> Gas.cost + + val sha512 : bytes -> Gas.cost + + val dign : int -> Gas.cost + + val dugn : int -> Gas.cost + + val dipn : int -> Gas.cost + + val dropn : int -> Gas.cost + + val voting_power : Gas.cost + + val total_voting_power : Gas.cost + + val keccak : bytes -> Gas.cost + + val sha3 : bytes -> Gas.cost + + val add_bls12_381_g1 : Gas.cost + + val add_bls12_381_g2 : Gas.cost + + val add_bls12_381_fr : Gas.cost + + val mul_bls12_381_g1 : Gas.cost + + val mul_bls12_381_g2 : Gas.cost + + val mul_bls12_381_fr : Gas.cost + + val mul_bls12_381_fr_z : Gas.cost + + val int_bls12_381_fr : Gas.cost + + val neg_bls12_381_g1 : Gas.cost + + val neg_bls12_381_g2 : Gas.cost + + val neg_bls12_381_fr : Gas.cost + + val neq : Gas.cost + + val nop : Gas.cost + + val pairing_check_bls12_381 : 'a Script_typed_ir.boxed_list -> Gas.cost + + val comb : int -> Gas.cost + + val uncomb : int -> Gas.cost + + val comb_get : int -> Gas.cost + + val comb_set : int -> Gas.cost + + val dupn : int -> Gas.cost + + val compare : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> Gas.cost + + val concat_string_precheck : 'a Script_typed_ir.boxed_list -> Gas.cost + + val concat_string : Z.t -> Gas.cost + + val concat_bytes : Z.t -> Gas.cost + + val exec : Gas.cost + + val apply : Gas.cost + + val lambda : Gas.cost + + val address : Gas.cost + + val contract : Gas.cost + + val transfer_tokens : Gas.cost + + val implicit_account : Gas.cost + + val create_contract : Gas.cost + + val set_delegate : Gas.cost + + val balance : Gas.cost + + val level : Gas.cost + + val now : Gas.cost + + val hash_key : Signature.Public_key.t -> Gas.cost + + val source : Gas.cost + + val sender : Gas.cost + + val self : Gas.cost + + val self_address : Gas.cost + + val amount : Gas.cost + + val chain_id : Gas.cost + + val unpack_failed : bytes -> Gas.cost + + val sapling_empty_state : Gas.cost + + val sapling_verify_update : inputs:int -> outputs:int -> Gas.cost + + val ticket : Gas.cost + + val read_ticket : Gas.cost + + val split_ticket : + 'a Script_int.num -> 'a Script_int.num -> 'a Script_int.num -> Gas.cost + + val join_tickets : + 'a Script_typed_ir.comparable_ty -> + 'a Script_typed_ir.ticket -> + 'a Script_typed_ir.ticket -> + Gas.cost + end + + module Typechecking : sig + val public_key_optimized : Gas.cost + + val public_key_readable : Gas.cost + + val key_hash_optimized : Gas.cost + + val key_hash_readable : Gas.cost + + val signature_optimized : Gas.cost + + val signature_readable : Gas.cost + + val chain_id_optimized : Gas.cost + + val chain_id_readable : Gas.cost + + val address_optimized : Gas.cost + + val contract_optimized : Gas.cost + + val contract_readable : Gas.cost + + val bls12_381_g1 : Gas.cost + + val bls12_381_g2 : Gas.cost + + val bls12_381_fr : Gas.cost + + val check_printable : string -> Gas.cost + + val merge_cycle : Gas.cost + + val parse_type_cycle : Gas.cost + + val parse_instr_cycle : Gas.cost + + val parse_data_cycle : Gas.cost + + val comparable_ty_of_ty_cycle : Gas.cost + + val check_dupable_cycle : Gas.cost + + val bool : Gas.cost + + val unit : Gas.cost + + val timestamp_readable : Gas.cost + + val contract : Gas.cost + + val contract_exists : Gas.cost + + val proof_argument : int -> Gas.cost + end + + module Unparsing : sig + val public_key_optimized : Gas.cost + + val public_key_readable : Gas.cost + + val key_hash_optimized : Gas.cost + + val key_hash_readable : Gas.cost + + val signature_optimized : Gas.cost + + val signature_readable : Gas.cost + + val chain_id_optimized : Gas.cost + + val chain_id_readable : Gas.cost + + val timestamp_readable : Gas.cost + + val address_optimized : Gas.cost + + val contract_optimized : Gas.cost + + val contract_readable : Gas.cost + + val bls12_381_g1 : Gas.cost + + val bls12_381_g2 : Gas.cost + + val bls12_381_fr : Gas.cost + + val unparse_type_cycle : Gas.cost + + val unparse_instr_cycle : Gas.cost + + val unparse_data_cycle : Gas.cost + + val unit : Gas.cost + + val contract : Gas.cost + + val operation : bytes -> Gas.cost + + val sapling_transaction : Sapling.transaction -> Gas.cost + + val sapling_diff : Sapling.diff -> Gas.cost + end +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_primitives.ml b/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_primitives.ml new file mode 100644 index 0000000000000000000000000000000000000000..005cd37f60ca81b74449f13fdc8c5b11243fab1d --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_primitives.ml @@ -0,0 +1,1166 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Micheline + +type error += Unknown_primitive_name of string + +type error += Invalid_case of string + +type error += + | Invalid_primitive_name of + string Micheline.canonical * Micheline.canonical_location + +type prim = + | K_parameter + | K_storage + | K_code + | D_False + | D_Elt + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit + | I_PACK + | I_UNPACK + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHAIN_ID + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_IMPLICIT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_BIG_MAP + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_APPLY + | I_FAILWITH + | I_GE + | I_GET + | I_GET_AND_UPDATE + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LEVEL + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_UNPAIR + | I_PUSH + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_SENDER + | I_SELF + | I_SELF_ADDRESS + | I_SLICE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_SET_DELEGATE + | I_UNIT + | I_UPDATE + | I_XOR + | I_ITER + | I_LOOP_LEFT + | I_ADDRESS + | I_CONTRACT + | I_ISNAT + | I_CAST + | I_RENAME + | I_SAPLING_EMPTY_STATE + | I_SAPLING_VERIFY_UPDATE + | I_DIG + | I_DUG + | I_NEVER + | I_VOTING_POWER + | I_TOTAL_VOTING_POWER + | I_KECCAK + | I_SHA3 + | I_PAIRING_CHECK + | I_TICKET + | I_READ_TICKET + | I_SPLIT_TICKET + | I_JOIN_TICKETS + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_big_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_bytes + | T_mutez + | T_timestamp + | T_unit + | T_operation + | T_address + | T_sapling_transaction + | T_sapling_state + | T_chain_id + | T_never + | T_bls12_381_g1 + | T_bls12_381_g2 + | T_bls12_381_fr + | T_ticket + +(* Auxiliary types for error documentation. + All the prim constructor prefixes must match their namespace. *) +type namespace = + | (* prefix "T" *) Type_namespace + | (* prefix "D" *) Constant_namespace + | (* prefix "I" *) Instr_namespace + | (* prefix "K" *) Keyword_namespace + +let namespace = function + | K_code | K_parameter | K_storage -> + Keyword_namespace + | D_Elt + | D_False + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit -> + Constant_namespace + | I_ABS + | I_ADD + | I_ADDRESS + | I_AMOUNT + | I_AND + | I_APPLY + | I_BALANCE + | I_BLAKE2B + | I_CAR + | I_CAST + | I_CDR + | I_CHAIN_ID + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CONTRACT + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_DIG + | I_DIP + | I_DROP + | I_DUG + | I_DUP + | I_EDIV + | I_EMPTY_BIG_MAP + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAILWITH + | I_GE + | I_GET + | I_GET_AND_UPDATE + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_IMPLICIT_ACCOUNT + | I_INT + | I_ISNAT + | I_ITER + | I_JOIN_TICKETS + | I_KECCAK + | I_LAMBDA + | I_LE + | I_LEFT + | I_LEVEL + | I_LOOP + | I_LOOP_LEFT + | I_LSL + | I_LSR + | I_LT + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NEVER + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PACK + | I_PAIR + | I_PAIRING_CHECK + | I_PUSH + | I_READ_TICKET + | I_RENAME + | I_RIGHT + | I_SAPLING_EMPTY_STATE + | I_SAPLING_VERIFY_UPDATE + | I_SELF + | I_SELF_ADDRESS + | I_SENDER + | I_SET_DELEGATE + | I_SHA256 + | I_SHA512 + | I_SHA3 + | I_SIZE + | I_SLICE + | I_SOME + | I_SOURCE + | I_SPLIT_TICKET + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TICKET + | I_TOTAL_VOTING_POWER + | I_TRANSFER_TOKENS + | I_UNIT + | I_UNPACK + | I_UNPAIR + | I_UPDATE + | I_VOTING_POWER + | I_XOR -> + Instr_namespace + | T_address + | T_big_map + | T_bool + | T_bytes + | T_chain_id + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_mutez + | T_nat + | T_never + | T_operation + | T_option + | T_or + | T_pair + | T_sapling_state + | T_sapling_transaction + | T_set + | T_signature + | T_string + | T_timestamp + | T_unit + | T_bls12_381_fr + | T_bls12_381_g1 + | T_bls12_381_g2 + | T_ticket -> + Type_namespace + +let valid_case name = + let is_lower = function '_' | 'a' .. 'z' -> true | _ -> false in + let is_upper = function '_' | 'A' .. 'Z' -> true | _ -> false in + let rec for_all a b f = + Compare.Int.(a > b) || (f a && for_all (a + 1) b f) + in + let len = String.length name in + Compare.Int.(len <> 0) + && Compare.Char.(name.[0] <> '_') + && ( (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_upper name.[i])) + || (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i])) + || (is_lower name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i])) + ) + +let string_of_prim = function + | K_parameter -> + "parameter" + | K_storage -> + "storage" + | K_code -> + "code" + | D_False -> + "False" + | D_Elt -> + "Elt" + | D_Left -> + "Left" + | D_None -> + "None" + | D_Pair -> + "Pair" + | D_Right -> + "Right" + | D_Some -> + "Some" + | D_True -> + "True" + | D_Unit -> + "Unit" + | I_PACK -> + "PACK" + | I_UNPACK -> + "UNPACK" + | I_BLAKE2B -> + "BLAKE2B" + | I_SHA256 -> + "SHA256" + | I_SHA512 -> + "SHA512" + | I_ABS -> + "ABS" + | I_ADD -> + "ADD" + | I_AMOUNT -> + "AMOUNT" + | I_AND -> + "AND" + | I_BALANCE -> + "BALANCE" + | I_CAR -> + "CAR" + | I_CDR -> + "CDR" + | I_CHAIN_ID -> + "CHAIN_ID" + | I_CHECK_SIGNATURE -> + "CHECK_SIGNATURE" + | I_COMPARE -> + "COMPARE" + | I_CONCAT -> + "CONCAT" + | I_CONS -> + "CONS" + | I_CREATE_ACCOUNT -> + "CREATE_ACCOUNT" + | I_CREATE_CONTRACT -> + "CREATE_CONTRACT" + | I_IMPLICIT_ACCOUNT -> + "IMPLICIT_ACCOUNT" + | I_DIP -> + "DIP" + | I_DROP -> + "DROP" + | I_DUP -> + "DUP" + | I_EDIV -> + "EDIV" + | I_EMPTY_BIG_MAP -> + "EMPTY_BIG_MAP" + | I_EMPTY_MAP -> + "EMPTY_MAP" + | I_EMPTY_SET -> + "EMPTY_SET" + | I_EQ -> + "EQ" + | I_EXEC -> + "EXEC" + | I_APPLY -> + "APPLY" + | I_FAILWITH -> + "FAILWITH" + | I_GE -> + "GE" + | I_GET -> + "GET" + | I_GET_AND_UPDATE -> + "GET_AND_UPDATE" + | I_GT -> + "GT" + | I_HASH_KEY -> + "HASH_KEY" + | I_IF -> + "IF" + | I_IF_CONS -> + "IF_CONS" + | I_IF_LEFT -> + "IF_LEFT" + | I_IF_NONE -> + "IF_NONE" + | I_INT -> + "INT" + | I_LAMBDA -> + "LAMBDA" + | I_LE -> + "LE" + | I_LEFT -> + "LEFT" + | I_LEVEL -> + "LEVEL" + | I_LOOP -> + "LOOP" + | I_LSL -> + "LSL" + | I_LSR -> + "LSR" + | I_LT -> + "LT" + | I_MAP -> + "MAP" + | I_MEM -> + "MEM" + | I_MUL -> + "MUL" + | I_NEG -> + "NEG" + | I_NEQ -> + "NEQ" + | I_NIL -> + "NIL" + | I_NONE -> + "NONE" + | I_NOT -> + "NOT" + | I_NOW -> + "NOW" + | I_OR -> + "OR" + | I_PAIR -> + "PAIR" + | I_PUSH -> + "PUSH" + | I_RIGHT -> + "RIGHT" + | I_SIZE -> + "SIZE" + | I_SOME -> + "SOME" + | I_SOURCE -> + "SOURCE" + | I_SENDER -> + "SENDER" + | I_SELF -> + "SELF" + | I_SELF_ADDRESS -> + "SELF_ADDRESS" + | I_SLICE -> + "SLICE" + | I_STEPS_TO_QUOTA -> + "STEPS_TO_QUOTA" + | I_SUB -> + "SUB" + | I_SWAP -> + "SWAP" + | I_TRANSFER_TOKENS -> + "TRANSFER_TOKENS" + | I_SET_DELEGATE -> + "SET_DELEGATE" + | I_UNIT -> + "UNIT" + | I_UNPAIR -> + "UNPAIR" + | I_UPDATE -> + "UPDATE" + | I_XOR -> + "XOR" + | I_ITER -> + "ITER" + | I_LOOP_LEFT -> + "LOOP_LEFT" + | I_ADDRESS -> + "ADDRESS" + | I_CONTRACT -> + "CONTRACT" + | I_ISNAT -> + "ISNAT" + | I_CAST -> + "CAST" + | I_RENAME -> + "RENAME" + | I_SAPLING_EMPTY_STATE -> + "SAPLING_EMPTY_STATE" + | I_SAPLING_VERIFY_UPDATE -> + "SAPLING_VERIFY_UPDATE" + | I_DIG -> + "DIG" + | I_DUG -> + "DUG" + | I_NEVER -> + "NEVER" + | I_VOTING_POWER -> + "VOTING_POWER" + | I_TOTAL_VOTING_POWER -> + "TOTAL_VOTING_POWER" + | I_KECCAK -> + "KECCAK" + | I_SHA3 -> + "SHA3" + | I_PAIRING_CHECK -> + "PAIRING_CHECK" + | I_TICKET -> + "TICKET" + | I_READ_TICKET -> + "READ_TICKET" + | I_SPLIT_TICKET -> + "SPLIT_TICKET" + | I_JOIN_TICKETS -> + "JOIN_TICKETS" + | T_bool -> + "bool" + | T_contract -> + "contract" + | T_int -> + "int" + | T_key -> + "key" + | T_key_hash -> + "key_hash" + | T_lambda -> + "lambda" + | T_list -> + "list" + | T_map -> + "map" + | T_big_map -> + "big_map" + | T_nat -> + "nat" + | T_option -> + "option" + | T_or -> + "or" + | T_pair -> + "pair" + | T_set -> + "set" + | T_signature -> + "signature" + | T_string -> + "string" + | T_bytes -> + "bytes" + | T_mutez -> + "mutez" + | T_timestamp -> + "timestamp" + | T_unit -> + "unit" + | T_operation -> + "operation" + | T_address -> + "address" + | T_sapling_state -> + "sapling_state" + | T_sapling_transaction -> + "sapling_transaction" + | T_chain_id -> + "chain_id" + | T_never -> + "never" + | T_bls12_381_g1 -> + "bls12_381_g1" + | T_bls12_381_g2 -> + "bls12_381_g2" + | T_bls12_381_fr -> + "bls12_381_fr" + | T_ticket -> + "ticket" + +let prim_of_string = function + | "parameter" -> + ok K_parameter + | "storage" -> + ok K_storage + | "code" -> + ok K_code + | "False" -> + ok D_False + | "Elt" -> + ok D_Elt + | "Left" -> + ok D_Left + | "None" -> + ok D_None + | "Pair" -> + ok D_Pair + | "Right" -> + ok D_Right + | "Some" -> + ok D_Some + | "True" -> + ok D_True + | "Unit" -> + ok D_Unit + | "PACK" -> + ok I_PACK + | "UNPACK" -> + ok I_UNPACK + | "BLAKE2B" -> + ok I_BLAKE2B + | "SHA256" -> + ok I_SHA256 + | "SHA512" -> + ok I_SHA512 + | "ABS" -> + ok I_ABS + | "ADD" -> + ok I_ADD + | "AMOUNT" -> + ok I_AMOUNT + | "AND" -> + ok I_AND + | "BALANCE" -> + ok I_BALANCE + | "CAR" -> + ok I_CAR + | "CDR" -> + ok I_CDR + | "CHAIN_ID" -> + ok I_CHAIN_ID + | "CHECK_SIGNATURE" -> + ok I_CHECK_SIGNATURE + | "COMPARE" -> + ok I_COMPARE + | "CONCAT" -> + ok I_CONCAT + | "CONS" -> + ok I_CONS + | "CREATE_ACCOUNT" -> + ok I_CREATE_ACCOUNT + | "CREATE_CONTRACT" -> + ok I_CREATE_CONTRACT + | "IMPLICIT_ACCOUNT" -> + ok I_IMPLICIT_ACCOUNT + | "DIP" -> + ok I_DIP + | "DROP" -> + ok I_DROP + | "DUP" -> + ok I_DUP + | "EDIV" -> + ok I_EDIV + | "EMPTY_BIG_MAP" -> + ok I_EMPTY_BIG_MAP + | "EMPTY_MAP" -> + ok I_EMPTY_MAP + | "EMPTY_SET" -> + ok I_EMPTY_SET + | "EQ" -> + ok I_EQ + | "EXEC" -> + ok I_EXEC + | "APPLY" -> + ok I_APPLY + | "FAILWITH" -> + ok I_FAILWITH + | "GE" -> + ok I_GE + | "GET" -> + ok I_GET + | "GET_AND_UPDATE" -> + ok I_GET_AND_UPDATE + | "GT" -> + ok I_GT + | "HASH_KEY" -> + ok I_HASH_KEY + | "IF" -> + ok I_IF + | "IF_CONS" -> + ok I_IF_CONS + | "IF_LEFT" -> + ok I_IF_LEFT + | "IF_NONE" -> + ok I_IF_NONE + | "INT" -> + ok I_INT + | "KECCAK" -> + ok I_KECCAK + | "LAMBDA" -> + ok I_LAMBDA + | "LE" -> + ok I_LE + | "LEFT" -> + ok I_LEFT + | "LEVEL" -> + ok I_LEVEL + | "LOOP" -> + ok I_LOOP + | "LSL" -> + ok I_LSL + | "LSR" -> + ok I_LSR + | "LT" -> + ok I_LT + | "MAP" -> + ok I_MAP + | "MEM" -> + ok I_MEM + | "MUL" -> + ok I_MUL + | "NEG" -> + ok I_NEG + | "NEQ" -> + ok I_NEQ + | "NIL" -> + ok I_NIL + | "NONE" -> + ok I_NONE + | "NOT" -> + ok I_NOT + | "NOW" -> + ok I_NOW + | "OR" -> + ok I_OR + | "PAIR" -> + ok I_PAIR + | "UNPAIR" -> + ok I_UNPAIR + | "PAIRING_CHECK" -> + ok I_PAIRING_CHECK + | "PUSH" -> + ok I_PUSH + | "RIGHT" -> + ok I_RIGHT + | "SHA3" -> + ok I_SHA3 + | "SIZE" -> + ok I_SIZE + | "SOME" -> + ok I_SOME + | "SOURCE" -> + ok I_SOURCE + | "SENDER" -> + ok I_SENDER + | "SELF" -> + ok I_SELF + | "SELF_ADDRESS" -> + ok I_SELF_ADDRESS + | "SLICE" -> + ok I_SLICE + | "STEPS_TO_QUOTA" -> + ok I_STEPS_TO_QUOTA + | "SUB" -> + ok I_SUB + | "SWAP" -> + ok I_SWAP + | "TRANSFER_TOKENS" -> + ok I_TRANSFER_TOKENS + | "SET_DELEGATE" -> + ok I_SET_DELEGATE + | "UNIT" -> + ok I_UNIT + | "UPDATE" -> + ok I_UPDATE + | "XOR" -> + ok I_XOR + | "ITER" -> + ok I_ITER + | "LOOP_LEFT" -> + ok I_LOOP_LEFT + | "ADDRESS" -> + ok I_ADDRESS + | "CONTRACT" -> + ok I_CONTRACT + | "ISNAT" -> + ok I_ISNAT + | "CAST" -> + ok I_CAST + | "RENAME" -> + ok I_RENAME + | "SAPLING_EMPTY_STATE" -> + ok I_SAPLING_EMPTY_STATE + | "SAPLING_VERIFY_UPDATE" -> + ok I_SAPLING_VERIFY_UPDATE + | "DIG" -> + ok I_DIG + | "DUG" -> + ok I_DUG + | "NEVER" -> + ok I_NEVER + | "VOTING_POWER" -> + ok I_VOTING_POWER + | "TOTAL_VOTING_POWER" -> + ok I_TOTAL_VOTING_POWER + | "TICKET" -> + ok I_TICKET + | "READ_TICKET" -> + ok I_READ_TICKET + | "SPLIT_TICKET" -> + ok I_SPLIT_TICKET + | "JOIN_TICKETS" -> + ok I_JOIN_TICKETS + | "bool" -> + ok T_bool + | "contract" -> + ok T_contract + | "int" -> + ok T_int + | "key" -> + ok T_key + | "key_hash" -> + ok T_key_hash + | "lambda" -> + ok T_lambda + | "list" -> + ok T_list + | "map" -> + ok T_map + | "big_map" -> + ok T_big_map + | "nat" -> + ok T_nat + | "option" -> + ok T_option + | "or" -> + ok T_or + | "pair" -> + ok T_pair + | "set" -> + ok T_set + | "signature" -> + ok T_signature + | "string" -> + ok T_string + | "bytes" -> + ok T_bytes + | "mutez" -> + ok T_mutez + | "timestamp" -> + ok T_timestamp + | "unit" -> + ok T_unit + | "operation" -> + ok T_operation + | "address" -> + ok T_address + | "sapling_state" -> + ok T_sapling_state + | "sapling_transaction" -> + ok T_sapling_transaction + | "chain_id" -> + ok T_chain_id + | "never" -> + ok T_never + | "bls12_381_g1" -> + ok T_bls12_381_g1 + | "bls12_381_g2" -> + ok T_bls12_381_g2 + | "bls12_381_fr" -> + ok T_bls12_381_fr + | "ticket" -> + ok T_ticket + | n -> + if valid_case n then error (Unknown_primitive_name n) + else error (Invalid_case n) + +let prims_of_strings expr = + let rec convert = function + | (Int _ | String _ | Bytes _) as expr -> + ok expr + | Prim (loc, prim, args, annot) -> + Error_monad.record_trace + (Invalid_primitive_name (expr, loc)) + (prim_of_string prim) + >>? fun prim -> + map convert args >|? fun args -> Prim (0, prim, args, annot) + | Seq (_, args) -> + map convert args >|? fun args -> Seq (0, args) + in + convert (root expr) >|? fun expr -> strip_locations expr + [@@coq_axiom "implicit type conversion for expr in the constant cases"] + +let strings_of_prims expr = + let rec convert = function + | (Int _ | String _ | Bytes _) as expr -> + expr + | Prim (_, prim, args, annot) -> + let prim = string_of_prim prim in + let args = List.map convert args in + Prim (0, prim, args, annot) + | Seq (_, args) -> + let args = List.map convert args in + Seq (0, args) + in + strip_locations (convert (root expr)) + [@@coq_axiom "implicit type conversion for expr in the constant cases"] + +let prim_encoding = + let open Data_encoding in + def "michelson.v1.primitives" + @@ string_enum + (* Add the comment below every 10 lines *) + [ (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("parameter", K_parameter); + ("storage", K_storage); + ("code", K_code); + ("False", D_False); + ("Elt", D_Elt); + ("Left", D_Left); + ("None", D_None); + ("Pair", D_Pair); + ("Right", D_Right); + ("Some", D_Some); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("True", D_True); + ("Unit", D_Unit); + ("PACK", I_PACK); + ("UNPACK", I_UNPACK); + ("BLAKE2B", I_BLAKE2B); + ("SHA256", I_SHA256); + ("SHA512", I_SHA512); + ("ABS", I_ABS); + ("ADD", I_ADD); + ("AMOUNT", I_AMOUNT); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("AND", I_AND); + ("BALANCE", I_BALANCE); + ("CAR", I_CAR); + ("CDR", I_CDR); + ("CHECK_SIGNATURE", I_CHECK_SIGNATURE); + ("COMPARE", I_COMPARE); + ("CONCAT", I_CONCAT); + ("CONS", I_CONS); + ("CREATE_ACCOUNT", I_CREATE_ACCOUNT); + ("CREATE_CONTRACT", I_CREATE_CONTRACT); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT); + ("DIP", I_DIP); + ("DROP", I_DROP); + ("DUP", I_DUP); + ("EDIV", I_EDIV); + ("EMPTY_MAP", I_EMPTY_MAP); + ("EMPTY_SET", I_EMPTY_SET); + ("EQ", I_EQ); + ("EXEC", I_EXEC); + ("FAILWITH", I_FAILWITH); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("GE", I_GE); + ("GET", I_GET); + ("GT", I_GT); + ("HASH_KEY", I_HASH_KEY); + ("IF", I_IF); + ("IF_CONS", I_IF_CONS); + ("IF_LEFT", I_IF_LEFT); + ("IF_NONE", I_IF_NONE); + ("INT", I_INT); + ("LAMBDA", I_LAMBDA); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("LE", I_LE); + ("LEFT", I_LEFT); + ("LOOP", I_LOOP); + ("LSL", I_LSL); + ("LSR", I_LSR); + ("LT", I_LT); + ("MAP", I_MAP); + ("MEM", I_MEM); + ("MUL", I_MUL); + ("NEG", I_NEG); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("NEQ", I_NEQ); + ("NIL", I_NIL); + ("NONE", I_NONE); + ("NOT", I_NOT); + ("NOW", I_NOW); + ("OR", I_OR); + ("PAIR", I_PAIR); + ("PUSH", I_PUSH); + ("RIGHT", I_RIGHT); + ("SIZE", I_SIZE); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("SOME", I_SOME); + ("SOURCE", I_SOURCE); + ("SENDER", I_SENDER); + ("SELF", I_SELF); + ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA); + ("SUB", I_SUB); + ("SWAP", I_SWAP); + ("TRANSFER_TOKENS", I_TRANSFER_TOKENS); + ("SET_DELEGATE", I_SET_DELEGATE); + ("UNIT", I_UNIT); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("UPDATE", I_UPDATE); + ("XOR", I_XOR); + ("ITER", I_ITER); + ("LOOP_LEFT", I_LOOP_LEFT); + ("ADDRESS", I_ADDRESS); + ("CONTRACT", I_CONTRACT); + ("ISNAT", I_ISNAT); + ("CAST", I_CAST); + ("RENAME", I_RENAME); + ("bool", T_bool); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("contract", T_contract); + ("int", T_int); + ("key", T_key); + ("key_hash", T_key_hash); + ("lambda", T_lambda); + ("list", T_list); + ("map", T_map); + ("big_map", T_big_map); + ("nat", T_nat); + ("option", T_option); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("or", T_or); + ("pair", T_pair); + ("set", T_set); + ("signature", T_signature); + ("string", T_string); + ("bytes", T_bytes); + ("mutez", T_mutez); + ("timestamp", T_timestamp); + ("unit", T_unit); + ("operation", T_operation); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("address", T_address); + (* Alpha_002 addition *) + ("SLICE", I_SLICE); + (* Alpha_005 addition *) + ("DIG", I_DIG); + ("DUG", I_DUG); + ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP); + ("APPLY", I_APPLY); + ("chain_id", T_chain_id); + ("CHAIN_ID", I_CHAIN_ID); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + (* Alpha_008 addition *) + ("LEVEL", I_LEVEL); + ("SELF_ADDRESS", I_SELF_ADDRESS); + ("never", T_never); + ("NEVER", I_NEVER); + ("UNPAIR", I_UNPAIR); + ("VOTING_POWER", I_VOTING_POWER); + ("TOTAL_VOTING_POWER", I_TOTAL_VOTING_POWER); + ("KECCAK", I_KECCAK); + ("SHA3", I_SHA3); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + (* Alpha_008 addition *) + ("PAIRING_CHECK", I_PAIRING_CHECK); + ("bls12_381_g1", T_bls12_381_g1); + ("bls12_381_g2", T_bls12_381_g2); + ("bls12_381_fr", T_bls12_381_fr); + ("sapling_state", T_sapling_state); + ("sapling_transaction", T_sapling_transaction); + ("SAPLING_EMPTY_STATE", I_SAPLING_EMPTY_STATE); + ("SAPLING_VERIFY_UPDATE", I_SAPLING_VERIFY_UPDATE); + ("ticket", T_ticket); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + (* Alpha_008 addition *) + ("TICKET", I_TICKET); + ("READ_TICKET", I_READ_TICKET); + ("SPLIT_TICKET", I_SPLIT_TICKET); + ("JOIN_TICKETS", I_JOIN_TICKETS); + ("GET_AND_UPDATE", I_GET_AND_UPDATE) + (* New instructions must be added here, for backward compatibility of the encoding. *) + (* Keep the comment above at the end of the list *) + ] + +let () = + register_error_kind + `Permanent + ~id:"michelson_v1.unknown_primitive_name" + ~title:"Unknown primitive name" + ~description:"In a script or data expression, a primitive was unknown." + ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n) + Data_encoding.(obj1 (req "wrong_primitive_name" string)) + (function Unknown_primitive_name got -> Some got | _ -> None) + (fun got -> Unknown_primitive_name got) ; + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_primitive_name_case" + ~title:"Invalid primitive name case" + ~description: + "In a script or data expression, a primitive name is neither uppercase, \ + lowercase or capitalized." + ~pp:(fun ppf n -> Format.fprintf ppf "Primitive %s has invalid case." n) + Data_encoding.(obj1 (req "wrong_primitive_name" string)) + (function Invalid_case name -> Some name | _ -> None) + (fun name -> Invalid_case name) ; + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_primitive_name" + ~title:"Invalid primitive name" + ~description: + "In a script or data expression, a primitive name is unknown or has a \ + wrong case." + ~pp:(fun ppf _ -> Format.fprintf ppf "Invalid primitive.") + Data_encoding.( + obj2 + (req + "expression" + (Micheline.canonical_encoding ~variant:"generic" string)) + (req "location" Micheline.canonical_location_encoding)) + (function + | Invalid_primitive_name (expr, loc) -> Some (expr, loc) | _ -> None) + (fun (expr, loc) -> Invalid_primitive_name (expr, loc)) + +let string_of_namespace = function + | Type_namespace -> + "T" + | Constant_namespace -> + "D" + | Instr_namespace -> + "I" + | Keyword_namespace -> + "K" diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_primitives.mli b/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_primitives.mli new file mode 100644 index 0000000000000000000000000000000000000000..0b02822f021c92ac02a09e479bd079e6c1161c47 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/michelson_v1_primitives.mli @@ -0,0 +1,202 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += (* `Permanent *) Unknown_primitive_name of string + +type error += (* `Permanent *) Invalid_case of string + +type error += + | (* `Permanent *) + Invalid_primitive_name of + string Micheline.canonical * Micheline.canonical_location + +type prim = + | K_parameter + | K_storage + | K_code + | D_False + | D_Elt + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit + | I_PACK + | I_UNPACK + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHAIN_ID + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_IMPLICIT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_BIG_MAP + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_APPLY + | I_FAILWITH + | I_GE + | I_GET + | I_GET_AND_UPDATE + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LEVEL + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_UNPAIR + | I_PUSH + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_SENDER + | I_SELF + | I_SELF_ADDRESS + | I_SLICE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_SET_DELEGATE + | I_UNIT + | I_UPDATE + | I_XOR + | I_ITER + | I_LOOP_LEFT + | I_ADDRESS + | I_CONTRACT + | I_ISNAT + | I_CAST + | I_RENAME + | I_SAPLING_EMPTY_STATE + | I_SAPLING_VERIFY_UPDATE + | I_DIG + | I_DUG + | I_NEVER + | I_VOTING_POWER + | I_TOTAL_VOTING_POWER + | I_KECCAK + | I_SHA3 + | I_PAIRING_CHECK + | I_TICKET + | I_READ_TICKET + | I_SPLIT_TICKET + | I_JOIN_TICKETS + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_big_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_bytes + | T_mutez + | T_timestamp + | T_unit + | T_operation + | T_address + | T_sapling_transaction + | T_sapling_state + | T_chain_id + | T_never + | T_bls12_381_g1 + | T_bls12_381_g2 + | T_bls12_381_fr + | T_ticket + +(** Auxiliary types for error documentation. + All the prim constructor prefixes must match their namespace. *) +type namespace = + | (* prefix "T" *) Type_namespace + | (* prefix "D" *) Constant_namespace + | (* prefix "I" *) Instr_namespace + | (* prefix "K" *) Keyword_namespace + +val namespace : prim -> namespace + +val prim_encoding : prim Data_encoding.encoding + +val string_of_prim : prim -> string + +val prim_of_string : string -> prim tzresult + +val prims_of_strings : + string Micheline.canonical -> prim Micheline.canonical tzresult + +val strings_of_prims : prim Micheline.canonical -> string Micheline.canonical + +(** The string corresponds to the constructor prefix from the given namespace + (i.e. "T", "D", "I" or "K") *) +val string_of_namespace : namespace -> string diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/misc.ml b/src/proto_008_PtEdo2Zk/lib_protocol/misc.ml new file mode 100644 index 0000000000000000000000000000000000000000..14a34bd0ef5ec3672541b677bde4b6baff8315cb --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/misc.ml @@ -0,0 +1,89 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type 'a lazyt = unit -> 'a + +type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt + +type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t + +let rec ( --> ) i j = + (* [i; i+1; ...; j] *) + if Compare.Int.(i > j) then [] else i :: (succ i --> j) + +let rec ( ---> ) i j = + (* [i; i+1; ...; j] *) + if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j) + +let split delim ?(limit = max_int) path = + let l = String.length path in + let rec do_slashes acc limit i = + if Compare.Int.(i >= l) then List.rev acc + else if Compare.Char.(path.[i] = delim) then do_slashes acc limit (i + 1) + else do_split acc limit i + and do_split acc limit i = + if Compare.Int.(limit <= 0) then + if Compare.Int.(i = l) then List.rev acc + else List.rev (String.sub path i (l - i) :: acc) + else do_component acc (pred limit) i i + and do_component acc limit i j = + if Compare.Int.(j >= l) then + if Compare.Int.(i = j) then List.rev acc + else List.rev (String.sub path i (j - i) :: acc) + else if Compare.Char.(path.[j] = delim) then + do_slashes (String.sub path i (j - i) :: acc) limit j + else do_component acc limit i (j + 1) + in + if Compare.Int.(limit > 0) then do_slashes [] limit 0 else [path] + [@@coq_axiom "non-top-level mutual recursion"] + +let pp_print_paragraph ppf description = + Format.fprintf + ppf + "@[%a@]" + Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string) + (split ' ' description) + +let take n l = + let rec loop acc n xs = + if Compare.Int.(n <= 0) then Some (List.rev acc, xs) + else match xs with [] -> None | x :: xs -> loop (x :: acc) (n - 1) xs + in + loop [] n l + +let remove_prefix ~prefix s = + let x = String.length prefix in + let n = String.length s in + if Compare.Int.(n >= x) && Compare.String.(String.sub s 0 x = prefix) then + Some (String.sub s x (n - x)) + else None + +let rec remove_elem_from_list nb = function + | [] -> + [] + | _ :: _ as l when Compare.Int.(nb <= 0) -> + l + | _ :: tl -> + remove_elem_from_list (nb - 1) tl diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/misc.mli b/src/proto_008_PtEdo2Zk/lib_protocol/misc.mli new file mode 100644 index 0000000000000000000000000000000000000000..fb4e07dae4f05303bab2299a817385f7a138df85 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/misc.mli @@ -0,0 +1,47 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** {2 Helper functions} *) + +type 'a lazyt = unit -> 'a + +type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt + +type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t + +(** Include bounds *) +val ( --> ) : int -> int -> int list + +val ( ---> ) : Int32.t -> Int32.t -> Int32.t list + +val pp_print_paragraph : Format.formatter -> string -> unit + +val take : int -> 'a list -> ('a list * 'a list) option + +(** Some (input with [prefix] removed), if string has [prefix], else [None] *) +val remove_prefix : prefix:string -> string -> string option + +(** [remove nb list] remove the first [nb] elements from the list [list]. *) +val remove_elem_from_list : int -> 'a list -> 'a list diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/nonce_hash.ml b/src/proto_008_PtEdo2Zk/lib_protocol/nonce_hash.ml new file mode 100644 index 0000000000000000000000000000000000000000..a79656ea8365ae8c5005ae8dc8e254d5f94eb75c --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/nonce_hash.ml @@ -0,0 +1,41 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* 32 *) +let nonce_hash = "\069\220\169" (* nce(53) *) + +include Blake2B.Make + (Base58) + (struct + let name = "cycle_nonce" + + let title = "A nonce hash" + + let b58check_prefix = nonce_hash + + let size = None + end) + +let () = Base58.check_encoded_prefix b58check_encoding "nce" 53 diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/nonce_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/nonce_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..a6abefe2a62822e8d5bfd60f242ffd590cd73f47 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/nonce_storage.ml @@ -0,0 +1,132 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = Seed_repr.nonce + +type nonce = t + +let encoding = Seed_repr.nonce_encoding + +type error += + | Too_late_revelation + | Too_early_revelation + | Previously_revealed_nonce + | Unexpected_nonce + +let () = + register_error_kind + `Branch + ~id:"nonce.too_late_revelation" + ~title:"Too late nonce revelation" + ~description:"Nonce revelation happens too late" + ~pp:(fun ppf () -> + Format.fprintf ppf "This nonce cannot be revealed anymore.") + Data_encoding.unit + (function Too_late_revelation -> Some () | _ -> None) + (fun () -> Too_late_revelation) ; + register_error_kind + `Temporary + ~id:"nonce.too_early_revelation" + ~title:"Too early nonce revelation" + ~description:"Nonce revelation happens before cycle end" + ~pp:(fun ppf () -> + Format.fprintf ppf "This nonce should not yet be revealed") + Data_encoding.unit + (function Too_early_revelation -> Some () | _ -> None) + (fun () -> Too_early_revelation) ; + register_error_kind + `Branch + ~id:"nonce.previously_revealed" + ~title:"Previously revealed nonce" + ~description:"Duplicated revelation for a nonce." + ~pp:(fun ppf () -> Format.fprintf ppf "This nonce was previously revealed") + Data_encoding.unit + (function Previously_revealed_nonce -> Some () | _ -> None) + (fun () -> Previously_revealed_nonce) ; + register_error_kind + `Branch + ~id:"nonce.unexpected" + ~title:"Unexpected nonce" + ~description: + "The provided nonce is inconsistent with the committed nonce hash." + ~pp:(fun ppf () -> + Format.fprintf + ppf + "This nonce revelation is invalid (inconsistent with the committed \ + hash)") + Data_encoding.unit + (function Unexpected_nonce -> Some () | _ -> None) + (fun () -> Unexpected_nonce) + +(* checks that the level of a revelation is not too early or too late wrt to the + current context and that a nonce has not been already revealed for that level *) +let get_unrevealed ctxt (level : Level_repr.t) = + let cur_level = Level_storage.current ctxt in + match Cycle_repr.pred cur_level.cycle with + | None -> + fail Too_early_revelation (* no revelations during cycle 0 *) + | Some revealed_cycle -> ( + if Cycle_repr.(revealed_cycle < level.Level_repr.cycle) then + fail Too_early_revelation + else if Cycle_repr.(level.Level_repr.cycle < revealed_cycle) then + fail Too_late_revelation + else + Storage.Seed.Nonce.get ctxt level + >>=? function + | Revealed _ -> + fail Previously_revealed_nonce + | Unrevealed status -> + return status ) + +let record_hash ctxt unrevealed = + let level = Level_storage.current ctxt in + Storage.Seed.Nonce.init ctxt level (Unrevealed unrevealed) + +let reveal ctxt level nonce = + get_unrevealed ctxt level + >>=? fun unrevealed -> + error_unless + (Seed_repr.check_hash nonce unrevealed.nonce_hash) + Unexpected_nonce + >>?= fun () -> Storage.Seed.Nonce.set ctxt level (Revealed nonce) + +type unrevealed = Storage.Seed.unrevealed_nonce = { + nonce_hash : Nonce_hash.t; + delegate : Signature.Public_key_hash.t; + rewards : Tez_repr.t; + fees : Tez_repr.t; +} + +type status = Storage.Seed.nonce_status = + | Unrevealed of unrevealed + | Revealed of Seed_repr.nonce + +let get = Storage.Seed.Nonce.get + +let of_bytes = Seed_repr.make_nonce + +let hash = Seed_repr.hash + +let check_hash = Seed_repr.check_hash diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/nonce_storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/nonce_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..b305053d8ad624319853319613d9463067b23b4b --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/nonce_storage.mli @@ -0,0 +1,58 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += + | Too_late_revelation + | Too_early_revelation + | Previously_revealed_nonce + | Unexpected_nonce + +type t = Seed_repr.nonce + +type nonce = t + +val encoding : nonce Data_encoding.t + +type unrevealed = Storage.Seed.unrevealed_nonce = { + nonce_hash : Nonce_hash.t; + delegate : Signature.Public_key_hash.t; + rewards : Tez_repr.t; + fees : Tez_repr.t; +} + +type status = Unrevealed of unrevealed | Revealed of Seed_repr.nonce + +val get : Raw_context.t -> Level_repr.t -> status tzresult Lwt.t + +val record_hash : Raw_context.t -> unrevealed -> Raw_context.t tzresult Lwt.t + +val reveal : + Raw_context.t -> Level_repr.t -> nonce -> Raw_context.t tzresult Lwt.t + +val of_bytes : bytes -> nonce tzresult + +val hash : nonce -> Nonce_hash.t + +val check_hash : nonce -> Nonce_hash.t -> bool diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/operation_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/operation_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..d6be42d2ed3382b1a307b9158663db4b7b83b9a5 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/operation_repr.ml @@ -0,0 +1,853 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Low level Repr. of Operations *) + +module Kind = struct + type seed_nonce_revelation = Seed_nonce_revelation_kind + + type double_endorsement_evidence = Double_endorsement_evidence_kind + + type double_baking_evidence = Double_baking_evidence_kind + + type activate_account = Activate_account_kind + + type endorsement = Endorsement_kind + + type proposals = Proposals_kind + + type ballot = Ballot_kind + + type reveal = Reveal_kind + + type transaction = Transaction_kind + + type origination = Origination_kind + + type delegation = Delegation_kind + + type 'a manager = + | Reveal_manager_kind : reveal manager + | Transaction_manager_kind : transaction manager + | Origination_manager_kind : origination manager + | Delegation_manager_kind : delegation manager +end + +type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} + +let raw_encoding = Operation.encoding + +type 'kind operation = { + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; +} + +and 'kind protocol_data = { + contents : 'kind contents_list; + signature : Signature.t option; +} + +and _ contents_list = + | Single : 'kind contents -> 'kind contents_list + | Cons : + 'kind Kind.manager contents * 'rest Kind.manager contents_list + -> ('kind * 'rest) Kind.manager contents_list + +and _ contents = + | Endorsement : {level : Raw_level_repr.t} -> Kind.endorsement contents + | Seed_nonce_revelation : { + level : Raw_level_repr.t; + nonce : Seed_repr.nonce; + } + -> Kind.seed_nonce_revelation contents + | Double_endorsement_evidence : { + op1 : Kind.endorsement operation; + op2 : Kind.endorsement operation; + } + -> Kind.double_endorsement_evidence contents + | Double_baking_evidence : { + bh1 : Block_header_repr.t; + bh2 : Block_header_repr.t; + } + -> Kind.double_baking_evidence contents + | Activate_account : { + id : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + } + -> Kind.activate_account contents + | Proposals : { + source : Signature.Public_key_hash.t; + period : int32; + proposals : Protocol_hash.t list; + } + -> Kind.proposals contents + | Ballot : { + source : Signature.Public_key_hash.t; + period : int32; + proposal : Protocol_hash.t; + ballot : Vote_repr.ballot; + } + -> Kind.ballot contents + | Manager_operation : { + source : Signature.public_key_hash; + fee : Tez_repr.tez; + counter : counter; + operation : 'kind manager_operation; + gas_limit : Gas_limit_repr.Arith.integral; + storage_limit : Z.t; + } + -> 'kind Kind.manager contents + +and _ manager_operation = + | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation + | Transaction : { + amount : Tez_repr.tez; + parameters : Script_repr.lazy_expr; + entrypoint : string; + destination : Contract_repr.contract; + } + -> Kind.transaction manager_operation + | Origination : { + delegate : Signature.Public_key_hash.t option; + script : Script_repr.t; + credit : Tez_repr.tez; + preorigination : Contract_repr.t option; + } + -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation + +and counter = Z.t + +let manager_kind : type kind. kind manager_operation -> kind Kind.manager = + function + | Reveal _ -> + Kind.Reveal_manager_kind + | Transaction _ -> + Kind.Transaction_manager_kind + | Origination _ -> + Kind.Origination_manager_kind + | Delegation _ -> + Kind.Delegation_manager_kind + +type 'kind internal_operation = { + source : Contract_repr.contract; + operation : 'kind manager_operation; + nonce : int; +} + +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation + +type packed_contents = Contents : 'kind contents -> packed_contents + +type packed_contents_list = + | Contents_list : 'kind contents_list -> packed_contents_list + +type packed_protocol_data = + | Operation_data : 'kind protocol_data -> packed_protocol_data + +type packed_operation = { + shell : Operation.shell_header; + protocol_data : packed_protocol_data; +} + +let pack ({shell; protocol_data} : _ operation) : packed_operation = + {shell; protocol_data = Operation_data protocol_data} + +type packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation + +let rec to_list = function + | Contents_list (Single o) -> + [Contents o] + | Contents_list (Cons (o, os)) -> + Contents o :: to_list (Contents_list os) + +let rec of_list = function + | [] -> + assert false + | [Contents o] -> + Contents_list (Single o) + | Contents o :: os -> ( + let (Contents_list os) = of_list os in + match (o, os) with + | (Manager_operation _, Single (Manager_operation _)) -> + Contents_list (Cons (o, os)) + | (Manager_operation _, Cons _) -> + Contents_list (Cons (o, os)) + | _ -> + Pervasives.failwith + "Operation list of length > 1 should only contains manager \ + operations." ) + +module Encoding = struct + open Data_encoding + + let case tag name args proj inj = + let open Data_encoding in + case + tag + ~title:(String.capitalize_ascii name) + (merge_objs (obj1 (req "kind" (constant name))) args) + (fun x -> match proj x with None -> None | Some x -> Some ((), x)) + (fun ((), x) -> inj x) + + module Manager_operations = struct + type 'kind case = + | MCase : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : packed_manager_operation -> 'kind manager_operation option; + proj : 'kind manager_operation -> 'a; + inj : 'a -> 'kind manager_operation; + } + -> 'kind case + + let reveal_case = + MCase + { + tag = 0; + name = "reveal"; + encoding = obj1 (req "public_key" Signature.Public_key.encoding); + select = (function Manager (Reveal _ as op) -> Some op | _ -> None); + proj = (function Reveal pkh -> pkh); + inj = (fun pkh -> Reveal pkh); + } + + let entrypoint_encoding = + def + ~title:"entrypoint" + ~description:"Named entrypoint to a Michelson smart contract" + "entrypoint" + @@ + let builtin_case tag name = + Data_encoding.case + (Tag tag) + ~title:name + (constant name) + (fun n -> if Compare.String.(n = name) then Some () else None) + (fun () -> name) + in + union + [ builtin_case 0 "default"; + builtin_case 1 "root"; + builtin_case 2 "do"; + builtin_case 3 "set_delegate"; + builtin_case 4 "remove_delegate"; + Data_encoding.case + (Tag 255) + ~title:"named" + (Bounded.string 31) + (fun s -> Some s) + (fun s -> s) ] + + let transaction_case = + MCase + { + tag = 1; + name = "transaction"; + encoding = + obj3 + (req "amount" Tez_repr.encoding) + (req "destination" Contract_repr.encoding) + (opt + "parameters" + (obj2 + (req "entrypoint" entrypoint_encoding) + (req "value" Script_repr.lazy_expr_encoding))); + select = + (function Manager (Transaction _ as op) -> Some op | _ -> None); + proj = + (function + | Transaction {amount; destination; parameters; entrypoint} -> + let parameters = + if + Script_repr.is_unit_parameter parameters + && Compare.String.(entrypoint = "default") + then None + else Some (entrypoint, parameters) + in + (amount, destination, parameters)); + inj = + (fun (amount, destination, parameters) -> + let (entrypoint, parameters) = + match parameters with + | None -> + ("default", Script_repr.unit_parameter) + | Some (entrypoint, value) -> + (entrypoint, value) + in + Transaction {amount; destination; parameters; entrypoint}); + } + + let origination_case = + MCase + { + tag = 2; + name = "origination"; + encoding = + obj3 + (req "balance" Tez_repr.encoding) + (opt "delegate" Signature.Public_key_hash.encoding) + (req "script" Script_repr.encoding); + select = + (function Manager (Origination _ as op) -> Some op | _ -> None); + proj = + (function + | Origination + { credit; + delegate; + script; + preorigination = + _ + (* the hash is only used internally + when originating from smart + contracts, don't serialize it *) + } -> + (credit, delegate, script)); + inj = + (fun (credit, delegate, script) -> + Origination {credit; delegate; script; preorigination = None}); + } + + let delegation_case = + MCase + { + tag = 3; + name = "delegation"; + encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding); + select = + (function Manager (Delegation _ as op) -> Some op | _ -> None); + proj = (function Delegation key -> key); + inj = (fun key -> Delegation key); + } + + let encoding = + let make (MCase {tag; name; encoding; select; proj; inj}) = + case + (Tag tag) + name + encoding + (fun o -> + match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Manager (inj x)) + in + union + ~tag_size:`Uint8 + [ make reveal_case; + make transaction_case; + make origination_case; + make delegation_case ] + end + + type 'b case = + | Case : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : packed_contents -> 'b contents option; + proj : 'b contents -> 'a; + inj : 'a -> 'b contents; + } + -> 'b case + + let endorsement_encoding = obj1 (req "level" Raw_level_repr.encoding) + + let endorsement_case = + Case + { + tag = 0; + name = "endorsement"; + encoding = endorsement_encoding; + select = + (function Contents (Endorsement _ as op) -> Some op | _ -> None); + proj = (fun (Endorsement {level}) -> level); + inj = (fun level -> Endorsement {level}); + } + + let endorsement_encoding = + let make (Case {tag; name; encoding; select = _; proj; inj}) = + case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) + in + let to_list : Kind.endorsement contents_list -> _ = function + | Single o -> + o + in + let of_list : Kind.endorsement contents -> _ = function o -> Single o in + def "inlined.endorsement" + @@ conv + (fun ({shell; protocol_data = {contents; signature}} : _ operation) -> + (shell, (contents, signature))) + (fun (shell, (contents, signature)) -> + ({shell; protocol_data = {contents; signature}} : _ operation)) + (merge_objs + Operation.shell_header_encoding + (obj2 + (req + "operations" + ( conv to_list of_list + @@ def "inlined.endorsement.contents" + @@ union [make endorsement_case] )) + (varopt "signature" Signature.encoding))) + + let seed_nonce_revelation_case = + Case + { + tag = 1; + name = "seed_nonce_revelation"; + encoding = + obj2 + (req "level" Raw_level_repr.encoding) + (req "nonce" Seed_repr.nonce_encoding); + select = + (function + | Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None); + proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce)); + inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce}); + } + + let double_endorsement_evidence_case : Kind.double_endorsement_evidence case + = + Case + { + tag = 2; + name = "double_endorsement_evidence"; + encoding = + obj2 + (req "op1" (dynamic_size endorsement_encoding)) + (req "op2" (dynamic_size endorsement_encoding)); + select = + (function + | Contents (Double_endorsement_evidence _ as op) -> + Some op + | _ -> + None); + proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2)); + inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2}); + } + + let double_baking_evidence_case = + Case + { + tag = 3; + name = "double_baking_evidence"; + encoding = + obj2 + (req "bh1" (dynamic_size Block_header_repr.encoding)) + (req "bh2" (dynamic_size Block_header_repr.encoding)); + select = + (function + | Contents (Double_baking_evidence _ as op) -> Some op | _ -> None); + proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2)); + inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2}); + } + + let activate_account_case = + Case + { + tag = 4; + name = "activate_account"; + encoding = + obj2 + (req "pkh" Ed25519.Public_key_hash.encoding) + (req "secret" Blinded_public_key_hash.activation_code_encoding); + select = + (function + | Contents (Activate_account _ as op) -> Some op | _ -> None); + proj = + (fun (Activate_account {id; activation_code}) -> + (id, activation_code)); + inj = + (fun (id, activation_code) -> Activate_account {id; activation_code}); + } + + let proposals_case = + Case + { + tag = 5; + name = "proposals"; + encoding = + obj3 + (req "source" Signature.Public_key_hash.encoding) + (req "period" int32) + (req "proposals" (list Protocol_hash.encoding)); + select = + (function Contents (Proposals _ as op) -> Some op | _ -> None); + proj = + (fun (Proposals {source; period; proposals}) -> + (source, period, proposals)); + inj = + (fun (source, period, proposals) -> + Proposals {source; period; proposals}); + } + + let ballot_case = + Case + { + tag = 6; + name = "ballot"; + encoding = + obj4 + (req "source" Signature.Public_key_hash.encoding) + (req "period" int32) + (req "proposal" Protocol_hash.encoding) + (req "ballot" Vote_repr.ballot_encoding); + select = (function Contents (Ballot _ as op) -> Some op | _ -> None); + proj = + (function + | Ballot {source; period; proposal; ballot} -> + (source, period, proposal, ballot)); + inj = + (fun (source, period, proposal, ballot) -> + Ballot {source; period; proposal; ballot}); + } + + let manager_encoding = + obj5 + (req "source" Signature.Public_key_hash.encoding) + (req "fee" Tez_repr.encoding) + (req "counter" (check_size 10 n)) + (req "gas_limit" (check_size 10 Gas_limit_repr.Arith.n_integral_encoding)) + (req "storage_limit" (check_size 10 n)) + + let extract (type kind) + (Manager_operation + {source; fee; counter; gas_limit; storage_limit; operation = _} : + kind Kind.manager contents) = + (source, fee, counter, gas_limit, storage_limit) + + let rebuild (source, fee, counter, gas_limit, storage_limit) operation = + Manager_operation + {source; fee; counter; gas_limit; storage_limit; operation} + + let make_manager_case tag (type kind) + (Manager_operations.MCase mcase : kind Manager_operations.case) = + Case + { + tag; + name = mcase.name; + encoding = merge_objs manager_encoding mcase.encoding; + select = + (function + | Contents (Manager_operation ({operation; _} as op)) -> ( + match mcase.select (Manager operation) with + | None -> + None + | Some operation -> + Some (Manager_operation {op with operation}) ) + | _ -> + None); + proj = + (function + | Manager_operation {operation; _} as op -> + (extract op, mcase.proj operation)); + inj = (fun (op, contents) -> rebuild op (mcase.inj contents)); + } + + let reveal_case = make_manager_case 107 Manager_operations.reveal_case + + let transaction_case = + make_manager_case 108 Manager_operations.transaction_case + + let origination_case = + make_manager_case 109 Manager_operations.origination_case + + let delegation_case = + make_manager_case 110 Manager_operations.delegation_case + + let contents_encoding = + let make (Case {tag; name; encoding; select; proj; inj}) = + case + (Tag tag) + name + encoding + (fun o -> match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Contents (inj x)) + in + def "operation.alpha.contents" + @@ union + [ make endorsement_case; + make seed_nonce_revelation_case; + make double_endorsement_evidence_case; + make double_baking_evidence_case; + make activate_account_case; + make proposals_case; + make ballot_case; + make reveal_case; + make transaction_case; + make origination_case; + make delegation_case ] + + let contents_list_encoding = + conv to_list of_list (Variable.list contents_encoding) + + let optional_signature_encoding = + conv + (function Some s -> s | None -> Signature.zero) + (fun s -> if Signature.equal s Signature.zero then None else Some s) + Signature.encoding + + let protocol_data_encoding = + def "operation.alpha.contents_and_signature" + @@ conv + (fun (Operation_data {contents; signature}) -> + (Contents_list contents, signature)) + (fun (Contents_list contents, signature) -> + Operation_data {contents; signature}) + (obj2 + (req "contents" contents_list_encoding) + (req "signature" optional_signature_encoding)) + + let operation_encoding = + conv + (fun {shell; protocol_data} -> (shell, protocol_data)) + (fun (shell, protocol_data) -> {shell; protocol_data}) + (merge_objs Operation.shell_header_encoding protocol_data_encoding) + + let unsigned_operation_encoding = + def "operation.alpha.unsigned_operation" + @@ merge_objs + Operation.shell_header_encoding + (obj1 (req "contents" contents_list_encoding)) + + let internal_operation_encoding = + def "operation.alpha.internal_operation" + @@ conv + (fun (Internal_operation {source; operation; nonce}) -> + ((source, nonce), Manager operation)) + (fun ((source, nonce), Manager operation) -> + Internal_operation {source; operation; nonce}) + (merge_objs + (obj2 (req "source" Contract_repr.encoding) (req "nonce" uint16)) + Manager_operations.encoding) +end + +let encoding = Encoding.operation_encoding + +let contents_encoding = Encoding.contents_encoding + +let contents_list_encoding = Encoding.contents_list_encoding + +let protocol_data_encoding = Encoding.protocol_data_encoding + +let unsigned_operation_encoding = Encoding.unsigned_operation_encoding + +let internal_operation_encoding = Encoding.internal_operation_encoding + +let raw ({shell; protocol_data} : _ operation) = + let proto = + Data_encoding.Binary.to_bytes_exn + protocol_data_encoding + (Operation_data protocol_data) + in + {Operation.shell; proto} + +let acceptable_passes (op : packed_operation) = + let (Operation_data protocol_data) = op.protocol_data in + match protocol_data.contents with + | Single (Endorsement _) -> + [0] + | Single (Proposals _) -> + [1] + | Single (Ballot _) -> + [1] + | Single (Seed_nonce_revelation _) -> + [2] + | Single (Double_endorsement_evidence _) -> + [2] + | Single (Double_baking_evidence _) -> + [2] + | Single (Activate_account _) -> + [2] + | Single (Manager_operation _) -> + [3] + | Cons _ -> + [3] + +type error += Invalid_signature (* `Permanent *) + +type error += Missing_signature (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"operation.invalid_signature" + ~title:"Invalid operation signature" + ~description: + "The operation signature is ill-formed or has been made with the wrong \ + public key" + ~pp:(fun ppf () -> Format.fprintf ppf "The operation signature is invalid") + Data_encoding.unit + (function Invalid_signature -> Some () | _ -> None) + (fun () -> Invalid_signature) ; + register_error_kind + `Permanent + ~id:"operation.missing_signature" + ~title:"Missing operation signature" + ~description: + "The operation is of a kind that must be signed, but the signature is \ + missing" + ~pp:(fun ppf () -> Format.fprintf ppf "The operation requires a signature") + Data_encoding.unit + (function Missing_signature -> Some () | _ -> None) + (fun () -> Missing_signature) + +let check_signature (type kind) key chain_id + ({shell; protocol_data} : kind operation) = + let check ~watermark contents signature = + let unsigned_operation = + Data_encoding.Binary.to_bytes_exn + unsigned_operation_encoding + (shell, contents) + in + if Signature.check ~watermark key signature unsigned_operation then Ok () + else error Invalid_signature + in + match (protocol_data.contents, protocol_data.signature) with + | (Single _, None) -> + error Missing_signature + | (Cons _, None) -> + error Missing_signature + | ((Single (Endorsement _) as contents), Some signature) -> + check + ~watermark:(Endorsement chain_id) + (Contents_list contents) + signature + | ((Single _ as contents), Some signature) -> + check ~watermark:Generic_operation (Contents_list contents) signature + | ((Cons _ as contents), Some signature) -> + check ~watermark:Generic_operation (Contents_list contents) signature + +let hash_raw = Operation.hash + +let hash (o : _ operation) = + let proto = + Data_encoding.Binary.to_bytes_exn + protocol_data_encoding + (Operation_data o.protocol_data) + in + Operation.hash {shell = o.shell; proto} + +let hash_packed (o : packed_operation) = + let proto = + Data_encoding.Binary.to_bytes_exn protocol_data_encoding o.protocol_data + in + Operation.hash {shell = o.shell; proto} + +type ('a, 'b) eq = Eq : ('a, 'a) eq + +let equal_manager_operation_kind : + type a b. a manager_operation -> b manager_operation -> (a, b) eq option = + fun op1 op2 -> + match (op1, op2) with + | (Reveal _, Reveal _) -> + Some Eq + | (Reveal _, _) -> + None + | (Transaction _, Transaction _) -> + Some Eq + | (Transaction _, _) -> + None + | (Origination _, Origination _) -> + Some Eq + | (Origination _, _) -> + None + | (Delegation _, Delegation _) -> + Some Eq + | (Delegation _, _) -> + None + +let equal_contents_kind : + type a b. a contents -> b contents -> (a, b) eq option = + fun op1 op2 -> + match (op1, op2) with + | (Endorsement _, Endorsement _) -> + Some Eq + | (Endorsement _, _) -> + None + | (Seed_nonce_revelation _, Seed_nonce_revelation _) -> + Some Eq + | (Seed_nonce_revelation _, _) -> + None + | (Double_endorsement_evidence _, Double_endorsement_evidence _) -> + Some Eq + | (Double_endorsement_evidence _, _) -> + None + | (Double_baking_evidence _, Double_baking_evidence _) -> + Some Eq + | (Double_baking_evidence _, _) -> + None + | (Activate_account _, Activate_account _) -> + Some Eq + | (Activate_account _, _) -> + None + | (Proposals _, Proposals _) -> + Some Eq + | (Proposals _, _) -> + None + | (Ballot _, Ballot _) -> + Some Eq + | (Ballot _, _) -> + None + | (Manager_operation op1, Manager_operation op2) -> ( + match equal_manager_operation_kind op1.operation op2.operation with + | None -> + None + | Some Eq -> + Some Eq ) + | (Manager_operation _, _) -> + None + +let rec equal_contents_kind_list : + type a b. a contents_list -> b contents_list -> (a, b) eq option = + fun op1 op2 -> + match (op1, op2) with + | (Single op1, Single op2) -> + equal_contents_kind op1 op2 + | (Single _, Cons _) -> + None + | (Cons _, Single _) -> + None + | (Cons (op1, ops1), Cons (op2, ops2)) -> ( + match equal_contents_kind op1 op2 with + | None -> + None + | Some Eq -> ( + match equal_contents_kind_list ops1 ops2 with + | None -> + None + | Some Eq -> + Some Eq ) ) + +let equal : type a b. a operation -> b operation -> (a, b) eq option = + fun op1 op2 -> + if not (Operation_hash.equal (hash op1) (hash op2)) then None + else + equal_contents_kind_list + op1.protocol_data.contents + op2.protocol_data.contents diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/operation_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/operation_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..fa60012a43066d85abe513b0ae2df17a5bf57b37 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/operation_repr.mli @@ -0,0 +1,266 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Low level Repr. of Operations *) + +module Kind : sig + type seed_nonce_revelation = Seed_nonce_revelation_kind + + type double_endorsement_evidence = Double_endorsement_evidence_kind + + type double_baking_evidence = Double_baking_evidence_kind + + type activate_account = Activate_account_kind + + type endorsement = Endorsement_kind + + type proposals = Proposals_kind + + type ballot = Ballot_kind + + type reveal = Reveal_kind + + type transaction = Transaction_kind + + type origination = Origination_kind + + type delegation = Delegation_kind + + type 'a manager = + | Reveal_manager_kind : reveal manager + | Transaction_manager_kind : transaction manager + | Origination_manager_kind : origination manager + | Delegation_manager_kind : delegation manager +end + +type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} + +val raw_encoding : raw Data_encoding.t + +type 'kind operation = { + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; +} + +and 'kind protocol_data = { + contents : 'kind contents_list; + signature : Signature.t option; +} + +and _ contents_list = + | Single : 'kind contents -> 'kind contents_list + | Cons : + 'kind Kind.manager contents * 'rest Kind.manager contents_list + -> ('kind * 'rest) Kind.manager contents_list + +and _ contents = + | Endorsement : {level : Raw_level_repr.t} -> Kind.endorsement contents + | Seed_nonce_revelation : { + level : Raw_level_repr.t; + nonce : Seed_repr.nonce; + } + -> Kind.seed_nonce_revelation contents + | Double_endorsement_evidence : { + op1 : Kind.endorsement operation; + op2 : Kind.endorsement operation; + } + -> Kind.double_endorsement_evidence contents + | Double_baking_evidence : { + bh1 : Block_header_repr.t; + bh2 : Block_header_repr.t; + } + -> Kind.double_baking_evidence contents + | Activate_account : { + id : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + } + -> Kind.activate_account contents + | Proposals : { + source : Signature.Public_key_hash.t; + period : int32; + proposals : Protocol_hash.t list; + } + -> Kind.proposals contents + | Ballot : { + source : Signature.Public_key_hash.t; + period : int32; + proposal : Protocol_hash.t; + ballot : Vote_repr.ballot; + } + -> Kind.ballot contents + | Manager_operation : { + source : Signature.Public_key_hash.t; + fee : Tez_repr.tez; + counter : counter; + operation : 'kind manager_operation; + gas_limit : Gas_limit_repr.Arith.integral; + storage_limit : Z.t; + } + -> 'kind Kind.manager contents + +and _ manager_operation = + | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation + | Transaction : { + amount : Tez_repr.tez; + parameters : Script_repr.lazy_expr; + entrypoint : string; + destination : Contract_repr.contract; + } + -> Kind.transaction manager_operation + | Origination : { + delegate : Signature.Public_key_hash.t option; + script : Script_repr.t; + credit : Tez_repr.tez; + preorigination : Contract_repr.t option; + } + -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation + +and counter = Z.t + +type 'kind internal_operation = { + source : Contract_repr.contract; + operation : 'kind manager_operation; + nonce : int; +} + +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation + +type packed_contents = Contents : 'kind contents -> packed_contents + +type packed_contents_list = + | Contents_list : 'kind contents_list -> packed_contents_list + +val of_list : packed_contents list -> packed_contents_list + +val to_list : packed_contents_list -> packed_contents list + +type packed_protocol_data = + | Operation_data : 'kind protocol_data -> packed_protocol_data + +type packed_operation = { + shell : Operation.shell_header; + protocol_data : packed_protocol_data; +} + +val pack : 'kind operation -> packed_operation + +type packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation + +val manager_kind : 'kind manager_operation -> 'kind Kind.manager + +val encoding : packed_operation Data_encoding.t + +val contents_encoding : packed_contents Data_encoding.t + +val contents_list_encoding : packed_contents_list Data_encoding.t + +val protocol_data_encoding : packed_protocol_data Data_encoding.t + +val unsigned_operation_encoding : + (Operation.shell_header * packed_contents_list) Data_encoding.t + +val raw : _ operation -> raw + +val hash_raw : raw -> Operation_hash.t + +val hash : _ operation -> Operation_hash.t + +val hash_packed : packed_operation -> Operation_hash.t + +val acceptable_passes : packed_operation -> int list + +type error += Missing_signature (* `Permanent *) + +type error += Invalid_signature (* `Permanent *) + +val check_signature : + Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult + +val internal_operation_encoding : packed_internal_operation Data_encoding.t + +type ('a, 'b) eq = Eq : ('a, 'a) eq + +val equal : 'a operation -> 'b operation -> ('a, 'b) eq option + +module Encoding : sig + type 'b case = + | Case : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : packed_contents -> 'b contents option; + proj : 'b contents -> 'a; + inj : 'a -> 'b contents; + } + -> 'b case + + val endorsement_case : Kind.endorsement case + + val seed_nonce_revelation_case : Kind.seed_nonce_revelation case + + val double_endorsement_evidence_case : Kind.double_endorsement_evidence case + + val double_baking_evidence_case : Kind.double_baking_evidence case + + val activate_account_case : Kind.activate_account case + + val proposals_case : Kind.proposals case + + val ballot_case : Kind.ballot case + + val reveal_case : Kind.reveal Kind.manager case + + val transaction_case : Kind.transaction Kind.manager case + + val origination_case : Kind.origination Kind.manager case + + val delegation_case : Kind.delegation Kind.manager case + + module Manager_operations : sig + type 'b case = + | MCase : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : packed_manager_operation -> 'kind manager_operation option; + proj : 'kind manager_operation -> 'a; + inj : 'a -> 'kind manager_operation; + } + -> 'kind case + + val reveal_case : Kind.reveal case + + val transaction_case : Kind.transaction case + + val origination_case : Kind.origination case + + val delegation_case : Kind.delegation case + end +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/parameters_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/parameters_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..d5869c641c12dbf0776ad999c556f89649045dd7 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/parameters_repr.ml @@ -0,0 +1,127 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type bootstrap_account = { + public_key_hash : Signature.Public_key_hash.t; + public_key : Signature.Public_key.t option; + amount : Tez_repr.t; +} + +type bootstrap_contract = { + delegate : Signature.Public_key_hash.t; + amount : Tez_repr.t; + script : Script_repr.t; +} + +type t = { + bootstrap_accounts : bootstrap_account list; + bootstrap_contracts : bootstrap_contract list; + commitments : Commitment_repr.t list; + constants : Constants_repr.parametric; + security_deposit_ramp_up_cycles : int option; + no_reward_cycles : int option; +} + +let bootstrap_account_encoding = + let open Data_encoding in + union + [ case + (Tag 0) + ~title:"Public_key_known" + (tup2 Signature.Public_key.encoding Tez_repr.encoding) + (function + | {public_key_hash; public_key = Some public_key; amount} -> + assert ( + Signature.Public_key_hash.equal + (Signature.Public_key.hash public_key) + public_key_hash ) ; + Some (public_key, amount) + | {public_key = None} -> + None) + (fun (public_key, amount) -> + { + public_key = Some public_key; + public_key_hash = Signature.Public_key.hash public_key; + amount; + }); + case + (Tag 1) + ~title:"Public_key_unknown" + (tup2 Signature.Public_key_hash.encoding Tez_repr.encoding) + (function + | {public_key_hash; public_key = None; amount} -> + Some (public_key_hash, amount) + | {public_key = Some _} -> + None) + (fun (public_key_hash, amount) -> + {public_key = None; public_key_hash; amount}) ] + +let bootstrap_contract_encoding = + let open Data_encoding in + conv + (fun {delegate; amount; script} -> (delegate, amount, script)) + (fun (delegate, amount, script) -> {delegate; amount; script}) + (obj3 + (req "delegate" Signature.Public_key_hash.encoding) + (req "amount" Tez_repr.encoding) + (req "script" Script_repr.encoding)) + +let encoding = + let open Data_encoding in + conv + (fun { bootstrap_accounts; + bootstrap_contracts; + commitments; + constants; + security_deposit_ramp_up_cycles; + no_reward_cycles } -> + ( ( bootstrap_accounts, + bootstrap_contracts, + commitments, + security_deposit_ramp_up_cycles, + no_reward_cycles ), + constants )) + (fun ( ( bootstrap_accounts, + bootstrap_contracts, + commitments, + security_deposit_ramp_up_cycles, + no_reward_cycles ), + constants ) -> + { + bootstrap_accounts; + bootstrap_contracts; + commitments; + constants; + security_deposit_ramp_up_cycles; + no_reward_cycles; + }) + (merge_objs + (obj5 + (req "bootstrap_accounts" (list bootstrap_account_encoding)) + (dft "bootstrap_contracts" (list bootstrap_contract_encoding) []) + (dft "commitments" (list Commitment_repr.encoding) []) + (opt "security_deposit_ramp_up_cycles" int31) + (opt "no_reward_cycles" int31)) + Constants_repr.parametric_encoding) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/parameters_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/parameters_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..6f8436e719b916ed3050d6f86b4c939adc2ec7bd --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/parameters_repr.mli @@ -0,0 +1,47 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type bootstrap_account = { + public_key_hash : Signature.Public_key_hash.t; + public_key : Signature.Public_key.t option; + amount : Tez_repr.t; +} + +type bootstrap_contract = { + delegate : Signature.Public_key_hash.t; + amount : Tez_repr.t; + script : Script_repr.t; +} + +type t = { + bootstrap_accounts : bootstrap_account list; + bootstrap_contracts : bootstrap_contract list; + commitments : Commitment_repr.t list; + constants : Constants_repr.parametric; + security_deposit_ramp_up_cycles : int option; + no_reward_cycles : int option; +} + +val encoding : t Data_encoding.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/period_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/period_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..2bd3e643b8cec528ada0c1d21b2501e411d25e72 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/period_repr.ml @@ -0,0 +1,87 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = Int64.t + +type period = t + +include (Compare.Int64 : Compare.S with type t := t) + +let encoding = Data_encoding.int64 + +let rpc_arg = RPC_arg.int64 + +let pp ppf v = Format.fprintf ppf "%Ld" v + +type error += (* `Permanent *) + Malformed_period | Invalid_arg + +let () = + let open Data_encoding in + (* Malformed period *) + register_error_kind + `Permanent + ~id:"malformed_period" + ~title:"Malformed period" + ~description:"Period is negative." + ~pp:(fun ppf () -> Format.fprintf ppf "Malformed period") + empty + (function Malformed_period -> Some () | _ -> None) + (fun () -> Malformed_period) ; + (* Invalid arg *) + register_error_kind + `Permanent + ~id:"invalid_arg" + ~title:"Invalid arg" + ~description:"Negative multiple of periods are not allowed." + ~pp:(fun ppf () -> Format.fprintf ppf "Invalid arg") + empty + (function Invalid_arg -> Some () | _ -> None) + (fun () -> Invalid_arg) + +let of_seconds t = + if Compare.Int64.(t >= 0L) then ok t else error Malformed_period + +let to_seconds t = t + +let of_seconds_exn t = + match of_seconds t with + | Ok t -> + t + | _ -> + invalid_arg "Period.of_seconds_exn" + +let mult i p = + (* TODO check overflow *) + if Compare.Int32.(i < 0l) then error Invalid_arg + else ok (Int64.mul (Int64.of_int32 i) p) + +let zero = of_seconds_exn 0L + +let one_second = of_seconds_exn 1L + +let one_minute = of_seconds_exn 60L + +let one_hour = of_seconds_exn 3600L diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/period_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/period_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..4fbd52db4507b555c498d13e82199923a0cd8d74 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/period_repr.mli @@ -0,0 +1,55 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t + +type period = t + +include Compare.S with type t := t + +val encoding : period Data_encoding.t + +val rpc_arg : period RPC_arg.t + +val pp : Format.formatter -> period -> unit + +val to_seconds : period -> int64 + +(** [of_second period] fails if period is not positive *) +val of_seconds : int64 -> period tzresult + +(** [of_second period] fails if period is not positive. + It should only be used at toplevel for constants. *) +val of_seconds_exn : int64 -> period + +val mult : int32 -> period -> period tzresult + +val zero : period + +val one_second : period + +val one_minute : period + +val one_hour : period diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/raw_context.ml b/src/proto_008_PtEdo2Zk/lib_protocol/raw_context.ml new file mode 100644 index 0000000000000000000000000000000000000000..0087847f70da898611512dd4692cf9526e339b76 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/raw_context.ml @@ -0,0 +1,742 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Int_set = Set.Make (Compare.Int) + +type t = { + context : Context.t; + constants : Constants_repr.parametric; + first_level : Raw_level_repr.t; + level : Level_repr.t; + predecessor_timestamp : Time.t; + timestamp : Time.t; + fitness : Int64.t; + deposits : Tez_repr.t Signature.Public_key_hash.Map.t; + included_endorsements : int; + allowed_endorsements : + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t; + fees : Tez_repr.t; + rewards : Tez_repr.t; + block_gas : Gas_limit_repr.Arith.fp; + operation_gas : Gas_limit_repr.t; + storage_space_to_pay : Z.t option; + allocated_contracts : int option; + origination_nonce : Contract_repr.origination_nonce option; + temporary_lazy_storage_ids : Lazy_storage_kind.Temp_ids.t; + internal_nonce : int; + internal_nonces_used : Int_set.t; +} + +type context = t + +type root_context = t + +let current_level ctxt = ctxt.level + +let predecessor_timestamp ctxt = ctxt.predecessor_timestamp + +let current_timestamp ctxt = ctxt.timestamp + +let current_fitness ctxt = ctxt.fitness + +let first_level ctxt = ctxt.first_level + +let constants ctxt = ctxt.constants + +let recover ctxt = ctxt.context + +let record_endorsement ctxt k = + match Signature.Public_key_hash.Map.find_opt k ctxt.allowed_endorsements with + | None -> + assert false + | Some (_, _, true) -> + assert false (* right already used *) + | Some (d, s, false) -> + { + ctxt with + included_endorsements = ctxt.included_endorsements + List.length s; + allowed_endorsements = + Signature.Public_key_hash.Map.add + k + (d, s, true) + ctxt.allowed_endorsements; + } + +let init_endorsements ctxt allowed_endorsements = + if Signature.Public_key_hash.Map.is_empty allowed_endorsements then + assert false (* can't initialize to empty *) + else if Signature.Public_key_hash.Map.is_empty ctxt.allowed_endorsements then + {ctxt with allowed_endorsements} + else assert false + +(* can't initialize twice *) + +let allowed_endorsements ctxt = ctxt.allowed_endorsements + +let included_endorsements ctxt = ctxt.included_endorsements + +type error += Too_many_internal_operations (* `Permanent *) + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"too_many_internal_operations" + ~title:"Too many internal operations" + ~description: + "A transaction exceeded the hard limit of internal operations it can emit" + empty + (function Too_many_internal_operations -> Some () | _ -> None) + (fun () -> Too_many_internal_operations) + +let fresh_internal_nonce ctxt = + if Compare.Int.(ctxt.internal_nonce >= 65_535) then + error Too_many_internal_operations + else + ok + ( {ctxt with internal_nonce = ctxt.internal_nonce + 1}, + ctxt.internal_nonce ) + +let reset_internal_nonce ctxt = + {ctxt with internal_nonces_used = Int_set.empty; internal_nonce = 0} + +let record_internal_nonce ctxt k = + {ctxt with internal_nonces_used = Int_set.add k ctxt.internal_nonces_used} + +let internal_nonce_already_recorded ctxt k = + Int_set.mem k ctxt.internal_nonces_used + +let set_current_fitness ctxt fitness = {ctxt with fitness} + +let add_fees ctxt fees = + Tez_repr.(ctxt.fees +? fees) >|? fun fees -> {ctxt with fees} + +let add_rewards ctxt rewards = + Tez_repr.(ctxt.rewards +? rewards) >|? fun rewards -> {ctxt with rewards} + +let add_deposit ctxt delegate deposit = + let previous = + match Signature.Public_key_hash.Map.find_opt delegate ctxt.deposits with + | Some tz -> + tz + | None -> + Tez_repr.zero + in + Tez_repr.(previous +? deposit) + >|? fun deposit -> + let deposits = + Signature.Public_key_hash.Map.add delegate deposit ctxt.deposits + in + {ctxt with deposits} + +let get_deposits ctxt = ctxt.deposits + +let get_rewards ctxt = ctxt.rewards + +let get_fees ctxt = ctxt.fees + +type error += Undefined_operation_nonce (* `Permanent *) + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"undefined_operation_nonce" + ~title:"Ill timed access to the origination nonce" + ~description: + "An origination was attempted out of the scope of a manager operation" + empty + (function Undefined_operation_nonce -> Some () | _ -> None) + (fun () -> Undefined_operation_nonce) + +let init_origination_nonce ctxt operation_hash = + let origination_nonce = + Some (Contract_repr.initial_origination_nonce operation_hash) + in + {ctxt with origination_nonce} + +let origination_nonce ctxt = + match ctxt.origination_nonce with + | None -> + error Undefined_operation_nonce + | Some origination_nonce -> + ok origination_nonce + +let increment_origination_nonce ctxt = + match ctxt.origination_nonce with + | None -> + error Undefined_operation_nonce + | Some cur_origination_nonce -> + let origination_nonce = + Some (Contract_repr.incr_origination_nonce cur_origination_nonce) + in + ok ({ctxt with origination_nonce}, cur_origination_nonce) + +let unset_origination_nonce ctxt = {ctxt with origination_nonce = None} + +type error += Gas_limit_too_high (* `Permanent *) + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"gas_limit_too_high" + ~title:"Gas limit out of protocol hard bounds" + ~description:"A transaction tried to exceed the hard limit on gas" + empty + (function Gas_limit_too_high -> Some () | _ -> None) + (fun () -> Gas_limit_too_high) + +let check_gas_limit ctxt (remaining : 'a Gas_limit_repr.Arith.t) = + if + Gas_limit_repr.Arith.( + remaining > ctxt.constants.hard_gas_limit_per_operation + || remaining < zero) + then error Gas_limit_too_high + else ok_unit + +let set_gas_limit ctxt (remaining : 'a Gas_limit_repr.Arith.t) = + let remaining = Gas_limit_repr.Arith.fp remaining in + {ctxt with operation_gas = Limited {remaining}} + +let set_gas_unlimited ctxt = {ctxt with operation_gas = Unaccounted} + +let consume_gas ctxt cost = + Gas_limit_repr.raw_consume ctxt.block_gas ctxt.operation_gas cost + >>? fun (block_gas, operation_gas) -> ok {ctxt with block_gas; operation_gas} + +let check_enough_gas ctxt cost = + Gas_limit_repr.raw_check_enough ctxt.block_gas ctxt.operation_gas cost + +let gas_level ctxt = ctxt.operation_gas + +let block_gas_level ctxt = ctxt.block_gas + +let gas_consumed ~since ~until = + match (gas_level since, gas_level until) with + | (Limited {remaining = before}, Limited {remaining = after}) -> + Gas_limit_repr.Arith.sub before after + | (_, _) -> + Gas_limit_repr.Arith.zero + +let init_storage_space_to_pay ctxt = + match ctxt.storage_space_to_pay with + | Some _ -> + assert false + | None -> + { + ctxt with + storage_space_to_pay = Some Z.zero; + allocated_contracts = Some 0; + } + +let update_storage_space_to_pay ctxt n = + match ctxt.storage_space_to_pay with + | None -> + assert false + | Some storage_space_to_pay -> + {ctxt with storage_space_to_pay = Some (Z.add n storage_space_to_pay)} + +let update_allocated_contracts_count ctxt = + match ctxt.allocated_contracts with + | None -> + assert false + | Some allocated_contracts -> + {ctxt with allocated_contracts = Some (succ allocated_contracts)} + +let clear_storage_space_to_pay ctxt = + match (ctxt.storage_space_to_pay, ctxt.allocated_contracts) with + | (None, _) | (_, None) -> + assert false + | (Some storage_space_to_pay, Some allocated_contracts) -> + ( {ctxt with storage_space_to_pay = None; allocated_contracts = None}, + storage_space_to_pay, + allocated_contracts ) + +type missing_key_kind = Get | Set | Del | Copy + +type storage_error = + | Incompatible_protocol_version of string + | Missing_key of string list * missing_key_kind + | Existing_key of string list + | Corrupted_data of string list + +let storage_error_encoding = + let open Data_encoding in + union + [ case + (Tag 0) + ~title:"Incompatible_protocol_version" + (obj1 (req "incompatible_protocol_version" string)) + (function Incompatible_protocol_version arg -> Some arg | _ -> None) + (fun arg -> Incompatible_protocol_version arg); + case + (Tag 1) + ~title:"Missing_key" + (obj2 + (req "missing_key" (list string)) + (req + "function" + (string_enum + [("get", Get); ("set", Set); ("del", Del); ("copy", Copy)]))) + (function Missing_key (key, f) -> Some (key, f) | _ -> None) + (fun (key, f) -> Missing_key (key, f)); + case + (Tag 2) + ~title:"Existing_key" + (obj1 (req "existing_key" (list string))) + (function Existing_key key -> Some key | _ -> None) + (fun key -> Existing_key key); + case + (Tag 3) + ~title:"Corrupted_data" + (obj1 (req "corrupted_data" (list string))) + (function Corrupted_data key -> Some key | _ -> None) + (fun key -> Corrupted_data key) ] + +let pp_storage_error ppf = function + | Incompatible_protocol_version version -> + Format.fprintf + ppf + "Found a context with an unexpected version '%s'." + version + | Missing_key (key, Get) -> + Format.fprintf ppf "Missing key '%s'." (String.concat "/" key) + | Missing_key (key, Set) -> + Format.fprintf + ppf + "Cannot set undefined key '%s'." + (String.concat "/" key) + | Missing_key (key, Del) -> + Format.fprintf + ppf + "Cannot delete undefined key '%s'." + (String.concat "/" key) + | Missing_key (key, Copy) -> + Format.fprintf + ppf + "Cannot copy undefined key '%s'." + (String.concat "/" key) + | Existing_key key -> + Format.fprintf + ppf + "Cannot initialize defined key '%s'." + (String.concat "/" key) + | Corrupted_data key -> + Format.fprintf + ppf + "Failed to parse the data at '%s'." + (String.concat "/" key) + +type error += Storage_error of storage_error + +let () = + register_error_kind + `Permanent + ~id:"context.storage_error" + ~title:"Storage error (fatal internal error)" + ~description: + "An error that should never happen unless something has been deleted or \ + corrupted in the database." + ~pp:(fun ppf err -> + Format.fprintf ppf "@[Storage error:@ %a@]" pp_storage_error err) + storage_error_encoding + (function Storage_error err -> Some err | _ -> None) + (fun err -> Storage_error err) + +let storage_error err = error (Storage_error err) + +(* Initialization *********************************************************) + +(* This key should always be populated for every version of the + protocol. It's absence meaning that the context is empty. *) +let version_key = ["version"] + +let version_value = "edo_008" + +let version = "v1" + +let first_level_key = [version; "first_level"] + +let constants_key = [version; "constants"] + +let protocol_param_key = ["protocol_parameters"] + +let get_first_level ctxt = + Context.get ctxt first_level_key + >|= function + | None -> + storage_error (Missing_key (first_level_key, Get)) + | Some bytes -> ( + match Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes with + | None -> + storage_error (Corrupted_data first_level_key) + | Some level -> + ok level ) + +let set_first_level ctxt level = + let bytes = + Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level + in + Context.set ctxt first_level_key bytes >|= ok + +type error += Failed_to_parse_parameter of bytes + +type error += Failed_to_decode_parameter of Data_encoding.json * string + +let () = + register_error_kind + `Temporary + ~id:"context.failed_to_parse_parameter" + ~title:"Failed to parse parameter" + ~description:"The protocol parameters are not valid JSON." + ~pp:(fun ppf bytes -> + Format.fprintf + ppf + "@[Cannot parse the protocol parameter:@ %s@]" + (Bytes.to_string bytes)) + Data_encoding.(obj1 (req "contents" bytes)) + (function Failed_to_parse_parameter data -> Some data | _ -> None) + (fun data -> Failed_to_parse_parameter data) ; + register_error_kind + `Temporary + ~id:"context.failed_to_decode_parameter" + ~title:"Failed to decode parameter" + ~description:"Unexpected JSON object." + ~pp:(fun ppf (json, msg) -> + Format.fprintf + ppf + "@[Cannot decode the protocol parameter:@ %s@ %a@]" + msg + Data_encoding.Json.pp + json) + Data_encoding.(obj2 (req "contents" json) (req "error" string)) + (function + | Failed_to_decode_parameter (json, msg) -> Some (json, msg) | _ -> None) + (fun (json, msg) -> Failed_to_decode_parameter (json, msg)) + +let get_proto_param ctxt = + Context.get ctxt protocol_param_key + >>= function + | None -> + failwith "Missing protocol parameters." + | Some bytes -> ( + match Data_encoding.Binary.of_bytes Data_encoding.json bytes with + | None -> + fail (Failed_to_parse_parameter bytes) + | Some json -> ( + Context.remove_rec ctxt protocol_param_key + >|= fun ctxt -> + match Data_encoding.Json.destruct Parameters_repr.encoding json with + | exception (Data_encoding.Json.Cannot_destruct _ as exn) -> + Format.kasprintf + failwith + "Invalid protocol_parameters: %a %a" + (fun ppf -> Data_encoding.Json.print_error ppf) + exn + Data_encoding.Json.pp + json + | param -> + ok (param, ctxt) ) ) + +let set_constants ctxt constants = + let bytes = + Data_encoding.Binary.to_bytes_exn + Constants_repr.parametric_encoding + constants + in + Context.set ctxt constants_key bytes + +let get_constants ctxt = + Context.get ctxt constants_key + >|= function + | None -> + failwith "Internal error: cannot read constants in context." + | Some bytes -> ( + match + Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding bytes + with + | None -> + failwith "Internal error: cannot parse constants in context." + | Some constants -> + ok constants ) + +let patch_constants ctxt f = + let constants = f ctxt.constants in + set_constants ctxt.context constants + >|= fun context -> {ctxt with context; constants} + +let check_inited ctxt = + Context.get ctxt version_key + >|= function + | None -> + failwith "Internal error: un-initialized context." + | Some bytes -> + let s = Bytes.to_string bytes in + if Compare.String.(s = version_value) then ok_unit + else storage_error (Incompatible_protocol_version s) + +let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt = + Raw_level_repr.of_int32 level + >>?= fun level -> + Fitness_repr.to_int64 fitness + >>?= fun fitness -> + check_inited ctxt + >>=? fun () -> + get_constants ctxt + >>=? fun constants -> + get_first_level ctxt + >|=? fun first_level -> + let level = + Level_repr.level_from_raw + ~first_level + ~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle + ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment + level + in + { + context = ctxt; + constants; + level; + predecessor_timestamp; + timestamp; + fitness; + first_level; + allowed_endorsements = Signature.Public_key_hash.Map.empty; + included_endorsements = 0; + fees = Tez_repr.zero; + rewards = Tez_repr.zero; + deposits = Signature.Public_key_hash.Map.empty; + operation_gas = Unaccounted; + storage_space_to_pay = None; + allocated_contracts = None; + block_gas = + Gas_limit_repr.Arith.fp constants.Constants_repr.hard_gas_limit_per_block; + origination_nonce = None; + temporary_lazy_storage_ids = Lazy_storage_kind.Temp_ids.init; + internal_nonce = 0; + internal_nonces_used = Int_set.empty; + } + +type previous_protocol = Genesis of Parameters_repr.t | Delphi_007 + +let check_and_update_protocol_version ctxt = + Context.get ctxt version_key + >>= (function + | None -> + failwith + "Internal error: un-initialized context in check_first_block." + | Some bytes -> + let s = Bytes.to_string bytes in + if Compare.String.(s = version_value) then + failwith "Internal error: previously initialized context." + else if Compare.String.(s = "genesis") then + get_proto_param ctxt + >|=? fun (param, ctxt) -> (Genesis param, ctxt) + else if Compare.String.(s = "delphi_007") then + return (Delphi_007, ctxt) + else Lwt.return @@ storage_error (Incompatible_protocol_version s)) + >>=? fun (previous_proto, ctxt) -> + Context.set ctxt version_key (Bytes.of_string version_value) + >|= fun ctxt -> ok (previous_proto, ctxt) + +let prepare_first_block ~level ~timestamp ~fitness ctxt = + check_and_update_protocol_version ctxt + >>=? fun (previous_proto, ctxt) -> + ( match previous_proto with + | Genesis param -> + Raw_level_repr.of_int32 level + >>?= fun first_level -> + set_first_level ctxt first_level + >>=? fun ctxt -> + set_constants ctxt param.constants + >|= fun ctxt -> ok (ctxt, param.constants.blocks_per_voting_period) + | Delphi_007 -> + get_constants ctxt + >>=? fun c -> + let prev_blocks_per_voting_period = c.blocks_per_voting_period in + let constants = + Constants_repr. + { + c with + blocks_per_voting_period = 20480l; + test_chain_duration = 1_228_800L; + } + in + set_constants ctxt constants + >>= fun ctxt -> return (ctxt, prev_blocks_per_voting_period) ) + >>=? fun (ctxt, prev_blocks_per_voting_period) -> + prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness + >|=? fun ctxt -> (previous_proto, ctxt, prev_blocks_per_voting_period) + +let activate ({context = c; _} as s) h = + Updater.activate c h >|= fun c -> {s with context = c} + +let fork_test_chain ({context = c; _} as s) protocol expiration = + Updater.fork_test_chain c ~protocol ~expiration + >|= fun c -> {s with context = c} + +(* Generic context ********************************************************) + +type key = string list + +type value = bytes + +module type T = sig + type t + + type context = t + + val mem : context -> key -> bool Lwt.t + + val dir_mem : context -> key -> bool Lwt.t + + val get : context -> key -> value tzresult Lwt.t + + val get_option : context -> key -> value option Lwt.t + + val init : context -> key -> value -> context tzresult Lwt.t + + val set : context -> key -> value -> context tzresult Lwt.t + + val init_set : context -> key -> value -> context Lwt.t + + val set_option : context -> key -> value option -> context Lwt.t + + val delete : context -> key -> context tzresult Lwt.t + + val remove : context -> key -> context Lwt.t + + val remove_rec : context -> key -> context Lwt.t + + val copy : context -> from:key -> to_:key -> context tzresult Lwt.t + + val fold : + context -> + key -> + init:'a -> + f:(Context.key_or_dir -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + + val keys : context -> key -> key list Lwt.t + + val fold_keys : + context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + val project : context -> root_context + + val absolute_key : context -> key -> key + + val consume_gas : context -> Gas_limit_repr.cost -> context tzresult + + val check_enough_gas : context -> Gas_limit_repr.cost -> unit tzresult + + val description : context Storage_description.t +end + +let mem ctxt k = Context.mem ctxt.context k + +let dir_mem ctxt k = Context.dir_mem ctxt.context k + +let get ctxt k = + Context.get ctxt.context k + >|= function None -> storage_error (Missing_key (k, Get)) | Some v -> ok v + +let get_option ctxt k = Context.get ctxt.context k + +(* Verify that the k is present before modifying *) +let set ctxt k v = + Context.mem ctxt.context k + >>= function + | false -> + Lwt.return @@ storage_error (Missing_key (k, Set)) + | true -> + Context.set ctxt.context k v >|= fun context -> ok {ctxt with context} + +(* Verify that the k is not present before inserting *) +let init ctxt k v = + Context.mem ctxt.context k + >>= function + | true -> + Lwt.return @@ storage_error (Existing_key k) + | false -> + Context.set ctxt.context k v >|= fun context -> ok {ctxt with context} + +(* Does not verify that the key is present or not *) +let init_set ctxt k v = + Context.set ctxt.context k v >|= fun context -> {ctxt with context} + +(* Verify that the key is present before deleting *) +let delete ctxt k = + Context.mem ctxt.context k + >>= function + | false -> + Lwt.return @@ storage_error (Missing_key (k, Del)) + | true -> + Context.remove_rec ctxt.context k + >|= fun context -> ok {ctxt with context} + +(* Do not verify before deleting *) +let remove ctxt k = + Context.remove_rec ctxt.context k >|= fun context -> {ctxt with context} + +let set_option ctxt k = function + | None -> + remove ctxt k + | Some v -> + init_set ctxt k v + +let remove_rec ctxt k = + Context.remove_rec ctxt.context k >|= fun context -> {ctxt with context} + +let copy ctxt ~from ~to_ = + Context.copy ctxt.context ~from ~to_ + >|= function + | None -> + storage_error (Missing_key (from, Copy)) + | Some context -> + ok {ctxt with context} + +let fold ctxt k ~init ~f = Context.fold ctxt.context k ~init ~f + +let keys ctxt k = Context.keys ctxt.context k + +let fold_keys ctxt k ~init ~f = Context.fold_keys ctxt.context k ~init ~f + +let project x = x + +let absolute_key _ k = k + +let description = Storage_description.create () + +let fold_map_temporary_lazy_storage_ids ctxt f = + f ctxt.temporary_lazy_storage_ids + |> fun (temporary_lazy_storage_ids, x) -> + ({ctxt with temporary_lazy_storage_ids}, x) + +let map_temporary_lazy_storage_ids_s ctxt f = + f ctxt.temporary_lazy_storage_ids + >|= fun (ctxt, temporary_lazy_storage_ids) -> + {ctxt with temporary_lazy_storage_ids} diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/raw_context.mli b/src/proto_008_PtEdo2Zk/lib_protocol/raw_context.mli new file mode 100644 index 0000000000000000000000000000000000000000..782d0616eed14f12a58ebe31f28bb0a12e3daeb0 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/raw_context.mli @@ -0,0 +1,292 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** {1 Errors} *) + +type error += Too_many_internal_operations (* `Permanent *) + +type missing_key_kind = Get | Set | Del | Copy + +(** An internal storage error that should not happen *) +type storage_error = + | Incompatible_protocol_version of string + | Missing_key of string list * missing_key_kind + | Existing_key of string list + | Corrupted_data of string list + +type error += Storage_error of storage_error + +type error += Failed_to_parse_parameter of bytes + +type error += Failed_to_decode_parameter of Data_encoding.json * string + +val storage_error : storage_error -> 'a tzresult + +(** {1 Abstract Context} *) + +(** Abstract view of the context. + Includes a handle to the functional key-value database + ({!Context.t}) along with some in-memory values (gas, etc.). *) +type t + +type context = t + +type root_context = t + +(** Retrieves the state of the database and gives its abstract view. + It also returns wether this is the first block validated + with this version of the protocol. *) +val prepare : + level:Int32.t -> + predecessor_timestamp:Time.t -> + timestamp:Time.t -> + fitness:Fitness.t -> + Context.t -> + context tzresult Lwt.t + +type previous_protocol = Genesis of Parameters_repr.t | Delphi_007 + +val prepare_first_block : + level:int32 -> + timestamp:Time.t -> + fitness:Fitness.t -> + Context.t -> + (previous_protocol * context * Int32.t) tzresult Lwt.t + +val activate : context -> Protocol_hash.t -> t Lwt.t + +val fork_test_chain : context -> Protocol_hash.t -> Time.t -> t Lwt.t + +(** Returns the state of the database resulting of operations on its + abstract view *) +val recover : context -> Context.t + +val current_level : context -> Level_repr.t + +val predecessor_timestamp : context -> Time.t + +val current_timestamp : context -> Time.t + +val current_fitness : context -> Int64.t + +val set_current_fitness : context -> Int64.t -> t + +val constants : context -> Constants_repr.parametric + +val patch_constants : + context -> + (Constants_repr.parametric -> Constants_repr.parametric) -> + context Lwt.t + +val first_level : context -> Raw_level_repr.t + +(** Increment the current block fee stash that will be credited to baker's + frozen_fees account at finalize_application *) +val add_fees : context -> Tez_repr.t -> context tzresult + +(** Increment the current block reward stash that will be credited to baker's + frozen_fees account at finalize_application *) +val add_rewards : context -> Tez_repr.t -> context tzresult + +(** Increment the current block deposit stash for a specific delegate. All the + delegates' frozen_deposit accounts are credited at finalize_application *) +val add_deposit : + context -> Signature.Public_key_hash.t -> Tez_repr.t -> context tzresult + +val get_fees : context -> Tez_repr.t + +val get_rewards : context -> Tez_repr.t + +val get_deposits : context -> Tez_repr.t Signature.Public_key_hash.Map.t + +type error += Gas_limit_too_high (* `Permanent *) + +val check_gas_limit : t -> 'a Gas_limit_repr.Arith.t -> unit tzresult + +val set_gas_limit : t -> 'a Gas_limit_repr.Arith.t -> t + +val set_gas_unlimited : t -> t + +val gas_level : t -> Gas_limit_repr.t + +val gas_consumed : since:t -> until:t -> Gas_limit_repr.Arith.fp + +val block_gas_level : t -> Gas_limit_repr.Arith.fp + +val init_storage_space_to_pay : t -> t + +val update_storage_space_to_pay : t -> Z.t -> t + +val update_allocated_contracts_count : t -> t + +val clear_storage_space_to_pay : t -> t * Z.t * int + +type error += Undefined_operation_nonce (* `Permanent *) + +val init_origination_nonce : t -> Operation_hash.t -> t + +val origination_nonce : t -> Contract_repr.origination_nonce tzresult + +val increment_origination_nonce : + t -> (t * Contract_repr.origination_nonce) tzresult + +val unset_origination_nonce : t -> t + +(** {1 Generic accessors} *) + +type key = string list + +type value = bytes + +(** All context manipulation functions. This signature is included + as-is for direct context accesses, and used in {!Storage_functors} + to provide restricted views to the context. *) +module type T = sig + type t + + type context = t + + (** Tells if the key is already defined as a value. *) + val mem : context -> key -> bool Lwt.t + + (** Tells if the key is already defined as a directory. *) + val dir_mem : context -> key -> bool Lwt.t + + (** Retrieve the value from the storage bucket ; returns a + {!Storage_error Missing_key} if the key is not set. *) + val get : context -> key -> value tzresult Lwt.t + + (** Retrieves the value from the storage bucket ; returns [None] if + the data is not initialized. *) + val get_option : context -> key -> value option Lwt.t + + (** Allocates the storage bucket and initializes it ; returns a + {!Storage_error Existing_key} if the bucket exists. *) + val init : context -> key -> value -> context tzresult Lwt.t + + (** Updates the content of the bucket ; returns a {!Storage_error + Missing_key} if the value does not exists. *) + val set : context -> key -> value -> context tzresult Lwt.t + + (** Allocates the data and initializes it with a value ; just + updates it if the bucket exists. *) + val init_set : context -> key -> value -> context Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + value is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. *) + val set_option : context -> key -> value option -> context Lwt.t + + (** Delete the storage bucket ; returns a {!Storage_error + Missing_key} if the bucket does not exists. *) + val delete : context -> key -> context tzresult Lwt.t + + (** Removes the storage bucket and its contents ; does nothing if the + bucket does not exists. *) + val remove : context -> key -> context Lwt.t + + (** Recursively removes all the storage buckets and contents ; does + nothing if no bucket exists. *) + val remove_rec : context -> key -> context Lwt.t + + val copy : context -> from:key -> to_:key -> context tzresult Lwt.t + + (** Iterator on all the items of a given directory. *) + val fold : + context -> + key -> + init:'a -> + f:(Context.key_or_dir -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + + (** Recursively list all subkeys of a given key. *) + val keys : context -> key -> key list Lwt.t + + (** Recursive iterator on all the subkeys of a given key. *) + val fold_keys : + context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + (** Internally used in {!Storage_functors} to escape from a view. *) + val project : context -> root_context + + (** Internally used in {!Storage_functors} to retrieve a full key + from partial key relative a view. *) + val absolute_key : context -> key -> key + + (** Internally used in {!Storage_functors} to consume gas from + within a view. *) + val consume_gas : context -> Gas_limit_repr.cost -> context tzresult + + (** Check if consume_gas will fail *) + val check_enough_gas : context -> Gas_limit_repr.cost -> unit tzresult + + val description : context Storage_description.t +end + +include T with type t := t and type context := context + +(** Initialize the local nonce used for preventing a script to + duplicate an internal operation to replay it. *) +val reset_internal_nonce : context -> context + +(** Increments the internal operation nonce. *) +val fresh_internal_nonce : context -> (context * int) tzresult + +(** Mark an internal operation nonce as taken. *) +val record_internal_nonce : context -> int -> context + +(** Check is the internal operation nonce has been taken. *) +val internal_nonce_already_recorded : context -> int -> bool + +(** Returns a map where to each endorser's pkh is associated the list of its + endorsing slots (in decreasing order) for a given level. *) +val allowed_endorsements : + context -> + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t + +(** Keep track of the number of endorsements that are included in a block *) +val included_endorsements : context -> int + +(** Initializes the map of allowed endorsements, this function must only be + called once. *) +val init_endorsements : + context -> + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t -> + context + +(** Marks an endorsement in the map as used. *) +val record_endorsement : context -> Signature.Public_key_hash.t -> context + +val fold_map_temporary_lazy_storage_ids : + context -> + (Lazy_storage_kind.Temp_ids.t -> Lazy_storage_kind.Temp_ids.t * 'res) -> + context * 'res + +val map_temporary_lazy_storage_ids_s : + context -> + (Lazy_storage_kind.Temp_ids.t -> + (context * Lazy_storage_kind.Temp_ids.t) Lwt.t) -> + context Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/raw_level_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/raw_level_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..c795ad5887048a404341bc55a6584b4557fa3115 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/raw_level_repr.ml @@ -0,0 +1,94 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = int32 + +type raw_level = t + +include (Compare.Int32 : Compare.S with type t := t) + +let encoding = Data_encoding.int32 + +let pp ppf level = Format.fprintf ppf "%ld" level + +let rpc_arg = + let construct raw_level = Int32.to_string raw_level in + let destruct str = + Int32.of_string_opt str |> Option.to_result ~none:"Cannot parse level" + in + RPC_arg.make + ~descr:"A level integer" + ~name:"block_level" + ~construct + ~destruct + () + +let root = 0l + +let succ = Int32.succ + +let pred l = if l = 0l then None else Some (Int32.pred l) + +let diff = Int32.sub + +let to_int32 l = l + +let of_int32_exn l = + if Compare.Int32.(l >= 0l) then l else invalid_arg "Level_repr.of_int32" + +type error += Unexpected_level of Int32.t (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"unexpected_level" + ~title:"Unexpected level" + ~description:"Level must be non-negative." + ~pp:(fun ppf l -> + Format.fprintf + ppf + "The level is %s but should be non-negative." + (Int32.to_string l)) + Data_encoding.(obj1 (req "level" int32)) + (function Unexpected_level l -> Some l | _ -> None) + (fun l -> Unexpected_level l) + +let of_int32 l = try Ok (of_int32_exn l) with _ -> error (Unexpected_level l) + +module Index = struct + type t = raw_level + + let path_length = 1 + + let to_path level l = Int32.to_string level :: l + + let of_path = function [s] -> Int32.of_string_opt s | _ -> None + + let rpc_arg = rpc_arg + + let encoding = encoding + + let compare = compare +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/raw_level_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/raw_level_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..0f7dad593f867ceadac77d4a844d64e5674d40e4 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/raw_level_repr.mli @@ -0,0 +1,55 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** The shell's notion of a level: an integer indicating the number of blocks + since genesis: genesis is 0, all other blocks have increasing levels from + there. *) +type t + +type raw_level = t + +val encoding : raw_level Data_encoding.t + +val rpc_arg : raw_level RPC_arg.arg + +val pp : Format.formatter -> raw_level -> unit + +include Compare.S with type t := raw_level + +val to_int32 : raw_level -> int32 + +val of_int32_exn : int32 -> raw_level + +val of_int32 : int32 -> raw_level tzresult + +val diff : raw_level -> raw_level -> int32 + +val root : raw_level + +val succ : raw_level -> raw_level + +val pred : raw_level -> raw_level option + +module Index : Storage_description.INDEX with type t = raw_level diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/roll_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/roll_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..74b47360b2ace54d0ad6efac2f2fdcd620a3ba57 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/roll_repr.ml @@ -0,0 +1,65 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Compare.Int32 + +type roll = t + +let encoding = Data_encoding.int32 + +let first = 0l + +let succ i = Int32.succ i + +let random sequence ~bound = Seed_repr.take_int32 sequence bound + +let rpc_arg = RPC_arg.like RPC_arg.int32 "roll" + +let to_int32 v = v + +module Index = struct + type t = roll + + let path_length = 3 + + let to_path roll l = + (Int32.to_string @@ Int32.logand roll (Int32.of_int 0xff)) + :: ( Int32.to_string + @@ Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 0xff) + ) + :: Int32.to_string roll :: l + + let of_path = function + | _ :: _ :: s :: _ -> + Int32.of_string_opt s + | _ -> + None + + let rpc_arg = rpc_arg + + let encoding = encoding + + let compare = compare +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/roll_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/roll_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..cb792b0128e73203abec091ee1aadf019aa356a1 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/roll_repr.mli @@ -0,0 +1,44 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = private int32 + +type roll = t + +val encoding : roll Data_encoding.t + +val rpc_arg : roll RPC_arg.t + +val random : Seed_repr.sequence -> bound:roll -> roll * Seed_repr.sequence + +val first : roll + +val succ : roll -> roll + +val to_int32 : roll -> Int32.t + +val ( = ) : roll -> roll -> bool + +module Index : Storage_description.INDEX with type t = roll diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/roll_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/roll_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..9bc5c52a6f6ef9115f6c68acfbc137c672d4be8f --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/roll_storage.ml @@ -0,0 +1,590 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Misc + +type error += + | (* `Permanent *) Consume_roll_change + | (* `Permanent *) No_roll_for_delegate + | (* `Permanent *) No_roll_snapshot_for_cycle of Cycle_repr.t + | (* `Permanent *) Unregistered_delegate of Signature.Public_key_hash.t + +let () = + let open Data_encoding in + (* Consume roll change *) + register_error_kind + `Permanent + ~id:"contract.manager.consume_roll_change" + ~title:"Consume roll change" + ~description:"Change is not enough to consume a roll." + ~pp:(fun ppf () -> + Format.fprintf ppf "Not enough change to consume a roll.") + empty + (function Consume_roll_change -> Some () | _ -> None) + (fun () -> Consume_roll_change) ; + (* No roll for delegate *) + register_error_kind + `Permanent + ~id:"contract.manager.no_roll_for_delegate" + ~title:"No roll for delegate" + ~description:"Delegate has no roll." + ~pp:(fun ppf () -> Format.fprintf ppf "Delegate has no roll.") + empty + (function No_roll_for_delegate -> Some () | _ -> None) + (fun () -> No_roll_for_delegate) ; + (* No roll snapshot for cycle *) + register_error_kind + `Permanent + ~id:"contract.manager.no_roll_snapshot_for_cycle" + ~title:"No roll snapshot for cycle" + ~description: + "A snapshot of the rolls distribution does not exist for this cycle." + ~pp:(fun ppf c -> + Format.fprintf + ppf + "A snapshot of the rolls distribution does not exist for cycle %a" + Cycle_repr.pp + c) + (obj1 (req "cycle" Cycle_repr.encoding)) + (function No_roll_snapshot_for_cycle c -> Some c | _ -> None) + (fun c -> No_roll_snapshot_for_cycle c) ; + (* Unregistered delegate *) + register_error_kind + `Permanent + ~id:"contract.manager.unregistered_delegate" + ~title:"Unregistered delegate" + ~description:"A contract cannot be delegated to an unregistered delegate" + ~pp:(fun ppf k -> + Format.fprintf + ppf + "The provided public key (with hash %a) is not registered as valid \ + delegate key." + Signature.Public_key_hash.pp + k) + (obj1 (req "hash" Signature.Public_key_hash.encoding)) + (function Unregistered_delegate k -> Some k | _ -> None) + (fun k -> Unregistered_delegate k) + +let get_contract_delegate ctxt contract = + Storage.Contract.Delegate.get_option ctxt contract + +let delegate_pubkey ctxt delegate = + Storage.Contract.Manager.get_option + ctxt + (Contract_repr.implicit_contract delegate) + >>=? function + | None | Some (Manager_repr.Hash _) -> + fail (Unregistered_delegate delegate) + | Some (Manager_repr.Public_key pk) -> + return pk + +let clear_cycle ctxt cycle = + Storage.Roll.Snapshot_for_cycle.get ctxt cycle + >>=? fun index -> + Storage.Roll.Snapshot_for_cycle.delete ctxt cycle + >>=? fun ctxt -> + Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index + >>=? fun ctxt -> + Storage.Roll.Owner.delete_snapshot ctxt (cycle, index) >|= ok + +let fold ctxt ~f init = + Storage.Roll.Next.get ctxt + >>=? fun last -> + let rec loop ctxt roll acc = + if Roll_repr.(roll = last) then return acc + else + Storage.Roll.Owner.get_option ctxt roll + >>=? function + | None -> + loop ctxt (Roll_repr.succ roll) acc + | Some delegate -> + f roll delegate acc + >>=? fun acc -> loop ctxt (Roll_repr.succ roll) acc + in + loop ctxt Roll_repr.first init + +let snapshot_rolls_for_cycle ctxt cycle = + Storage.Roll.Snapshot_for_cycle.get ctxt cycle + >>=? fun index -> + Storage.Roll.Snapshot_for_cycle.set ctxt cycle (index + 1) + >>=? fun ctxt -> + Storage.Roll.Owner.snapshot ctxt (cycle, index) + >>=? fun ctxt -> + Storage.Roll.Next.get ctxt + >>=? fun last -> Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last + +(* NOTE: Deletes all snapshots for a given cycle that are not randomly selected. *) +let freeze_rolls_for_cycle ctxt cycle = + Storage.Roll.Snapshot_for_cycle.get ctxt cycle + >>=? fun max_index -> + Storage.Seed.For_cycle.get ctxt cycle + >>=? fun seed -> + let rd = Seed_repr.initialize_new seed [Bytes.of_string "roll_snapshot"] in + let seq = Seed_repr.sequence rd 0l in + let selected_index = + Seed_repr.take_int32 seq (Int32.of_int max_index) |> fst |> Int32.to_int + in + Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index + >>=? fun ctxt -> + fold_left_s + (fun ctxt index -> + if Compare.Int.(index = selected_index) then return ctxt + else + Storage.Roll.Owner.delete_snapshot ctxt (cycle, index) + >>= fun ctxt -> + Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index) + ctxt + Misc.(0 --> (max_index - 1)) + +(* Roll selection *) +module Random = struct + let int32_to_bytes i = + let b = Bytes.make 4 '0' in + TzEndian.set_int32 b 0 i ; b + + let level_random seed use (level : Level_repr.t) = + let position = level.Level_repr.cycle_position in + Seed_repr.initialize_new + seed + [Bytes.of_string ("level " ^ use ^ ":"); int32_to_bytes position] + + let owner c kind (level : Level_repr.t) offset = + let cycle = level.Level_repr.cycle in + Seed_storage.for_cycle c cycle + >>=? fun random_seed -> + let rd = level_random random_seed kind level in + let sequence = Seed_repr.sequence rd (Int32.of_int offset) in + Storage.Roll.Snapshot_for_cycle.get c cycle + >>=? fun index -> + Storage.Roll.Last_for_snapshot.get (c, cycle) index + >>=? fun bound -> + let rec loop sequence = + let (roll, sequence) = Roll_repr.random sequence ~bound in + Storage.Roll.Owner.Snapshot.get_option c ((cycle, index), roll) + >>=? function None -> loop sequence | Some delegate -> return delegate + in + Storage.Roll.Owner.snapshot_exists c (cycle, index) + >>= fun snapshot_exists -> + error_unless snapshot_exists (No_roll_snapshot_for_cycle cycle) + >>?= fun () -> loop sequence +end + +let baking_rights_owner c level ~priority = + Random.owner c "baking" level priority + +let endorsement_rights_owner c level ~slot = + Random.owner c "endorsement" level slot + +let traverse_rolls ctxt head = + let rec loop acc roll = + Storage.Roll.Successor.get_option ctxt roll + >>=? function + | None -> return (List.rev acc) | Some next -> loop (next :: acc) next + in + loop [head] head + +let get_rolls ctxt delegate = + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? function + | None -> return_nil | Some head_roll -> traverse_rolls ctxt head_roll + +let count_rolls ctxt delegate = + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? function + | None -> + return 0 + | Some head_roll -> + let rec loop acc roll = + Storage.Roll.Successor.get_option ctxt roll + >>=? function None -> return acc | Some next -> loop (succ acc) next + in + loop 1 head_roll + +let get_change ctxt delegate = + Storage.Roll.Delegate_change.get_option ctxt delegate + >|=? Option.value ~default:Tez_repr.zero + +module Delegate = struct + let fresh_roll ctxt = + Storage.Roll.Next.get ctxt + >>=? fun roll -> + Storage.Roll.Next.set ctxt (Roll_repr.succ roll) + >|=? fun ctxt -> (roll, ctxt) + + let get_limbo_roll ctxt = + Storage.Roll.Limbo.get_option ctxt + >>=? function + | None -> + fresh_roll ctxt + >>=? fun (roll, ctxt) -> + Storage.Roll.Limbo.init ctxt roll >|=? fun ctxt -> (roll, ctxt) + | Some roll -> + return (roll, ctxt) + + let consume_roll_change ctxt delegate = + let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in + Storage.Roll.Delegate_change.get ctxt delegate + >>=? fun change -> + record_trace Consume_roll_change Tez_repr.(change -? tokens_per_roll) + >>?= fun new_change -> + Storage.Roll.Delegate_change.set ctxt delegate new_change + + let recover_roll_change ctxt delegate = + let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in + Storage.Roll.Delegate_change.get ctxt delegate + >>=? fun change -> + Tez_repr.(change +? tokens_per_roll) + >>?= fun new_change -> + Storage.Roll.Delegate_change.set ctxt delegate new_change + + let pop_roll_from_delegate ctxt delegate = + recover_roll_change ctxt delegate + >>=? fun ctxt -> + (* beginning: + delegate : roll -> successor_roll -> ... + limbo : limbo_head -> ... + *) + Storage.Roll.Limbo.get_option ctxt + >>=? fun limbo_head -> + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? function + | None -> + fail No_roll_for_delegate + | Some roll -> + Storage.Roll.Owner.delete ctxt roll + >>=? fun ctxt -> + Storage.Roll.Successor.get_option ctxt roll + >>=? fun successor_roll -> + Storage.Roll.Delegate_roll_list.set_option ctxt delegate successor_roll + >>= fun ctxt -> + (* delegate : successor_roll -> ... + roll ------^ + limbo : limbo_head -> ... *) + Storage.Roll.Successor.set_option ctxt roll limbo_head + >>= fun ctxt -> + (* delegate : successor_roll -> ... + roll ------v + limbo : limbo_head -> ... *) + Storage.Roll.Limbo.init_set ctxt roll + >|= fun ctxt -> + (* delegate : successor_roll -> ... + limbo : roll -> limbo_head -> ... *) + ok (roll, ctxt) + + let create_roll_in_delegate ctxt delegate delegate_pk = + consume_roll_change ctxt delegate + >>=? fun ctxt -> + (* beginning: + delegate : delegate_head -> ... + limbo : roll -> limbo_successor -> ... + *) + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? fun delegate_head -> + get_limbo_roll ctxt + >>=? fun (roll, ctxt) -> + Storage.Roll.Owner.init ctxt roll delegate_pk + >>=? fun ctxt -> + Storage.Roll.Successor.get_option ctxt roll + >>=? fun limbo_successor -> + Storage.Roll.Limbo.set_option ctxt limbo_successor + >>= fun ctxt -> + (* delegate : delegate_head -> ... + roll ------v + limbo : limbo_successor -> ... *) + Storage.Roll.Successor.set_option ctxt roll delegate_head + >>= fun ctxt -> + (* delegate : delegate_head -> ... + roll ------^ + limbo : limbo_successor -> ... *) + Storage.Roll.Delegate_roll_list.init_set ctxt delegate roll + (* delegate : roll -> delegate_head -> ... + limbo : limbo_successor -> ... *) + >|= ok + + let ensure_inited ctxt delegate = + Storage.Roll.Delegate_change.mem ctxt delegate + >>= function + | true -> + return ctxt + | false -> + Storage.Roll.Delegate_change.init ctxt delegate Tez_repr.zero + + let is_inactive ctxt delegate = + Storage.Contract.Inactive_delegate.mem + ctxt + (Contract_repr.implicit_contract delegate) + >>= fun inactive -> + if inactive then return inactive + else + Storage.Contract.Delegate_desactivation.get_option + ctxt + (Contract_repr.implicit_contract delegate) + >|=? function + | Some last_active_cycle -> + let ({Level_repr.cycle = current_cycle} : Level_repr.t) = + Raw_context.current_level ctxt + in + Cycle_repr.(last_active_cycle < current_cycle) + | None -> + (* This case is only when called from `set_active`, when creating + a contract. *) + false + + let add_amount ctxt delegate amount = + ensure_inited ctxt delegate + >>=? fun ctxt -> + let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in + Storage.Roll.Delegate_change.get ctxt delegate + >>=? fun change -> + Tez_repr.(amount +? change) + >>?= fun change -> + Storage.Roll.Delegate_change.set ctxt delegate change + >>=? fun ctxt -> + delegate_pubkey ctxt delegate + >>=? fun delegate_pk -> + let rec loop ctxt change = + if Tez_repr.(change < tokens_per_roll) then return ctxt + else + Tez_repr.(change -? tokens_per_roll) + >>?= fun change -> + create_roll_in_delegate ctxt delegate delegate_pk + >>=? fun ctxt -> loop ctxt change + in + is_inactive ctxt delegate + >>=? fun inactive -> + if inactive then return ctxt + else + loop ctxt change + >>=? fun ctxt -> + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? fun rolls -> + match rolls with + | None -> + return ctxt + | Some _ -> + Storage.Active_delegates_with_rolls.add ctxt delegate >|= ok + + let remove_amount ctxt delegate amount = + let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in + let rec loop ctxt change = + if Tez_repr.(amount <= change) then return (ctxt, change) + else + pop_roll_from_delegate ctxt delegate + >>=? fun (_, ctxt) -> + Tez_repr.(change +? tokens_per_roll) + >>?= fun change -> loop ctxt change + in + Storage.Roll.Delegate_change.get ctxt delegate + >>=? fun change -> + is_inactive ctxt delegate + >>=? fun inactive -> + ( if inactive then return (ctxt, change) + else + loop ctxt change + >>=? fun (ctxt, change) -> + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? fun rolls -> + match rolls with + | None -> + Storage.Active_delegates_with_rolls.del ctxt delegate + >|= fun ctxt -> ok (ctxt, change) + | Some _ -> + return (ctxt, change) ) + >>=? fun (ctxt, change) -> + Tez_repr.(change -? amount) + >>?= fun change -> Storage.Roll.Delegate_change.set ctxt delegate change + + let set_inactive ctxt delegate = + ensure_inited ctxt delegate + >>=? fun ctxt -> + let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in + Storage.Roll.Delegate_change.get ctxt delegate + >>=? fun change -> + Storage.Contract.Inactive_delegate.add + ctxt + (Contract_repr.implicit_contract delegate) + >>= fun ctxt -> + Storage.Active_delegates_with_rolls.del ctxt delegate + >>= fun ctxt -> + let rec loop ctxt change = + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? function + | None -> + return (ctxt, change) + | Some _roll -> + pop_roll_from_delegate ctxt delegate + >>=? fun (_, ctxt) -> + Tez_repr.(change +? tokens_per_roll) + >>?= fun change -> loop ctxt change + in + loop ctxt change + >>=? fun (ctxt, change) -> + Storage.Roll.Delegate_change.set ctxt delegate change + + let set_active ctxt delegate = + is_inactive ctxt delegate + >>=? fun inactive -> + let current_cycle = (Raw_context.current_level ctxt).cycle in + let preserved_cycles = Constants_storage.preserved_cycles ctxt in + (* When the delegate is new or inactive, she will become active in + `1+preserved_cycles`, and we allow `preserved_cycles` for the + delegate to start baking. When the delegate is active, we only + give her at least `preserved_cycles` after the current cycle + before to be deactivated. *) + Storage.Contract.Delegate_desactivation.get_option + ctxt + (Contract_repr.implicit_contract delegate) + >>=? fun current_expiration -> + let expiration = + match current_expiration with + | None -> + Cycle_repr.add current_cycle (1 + (2 * preserved_cycles)) + | Some current_expiration -> + let delay = + if inactive then 1 + (2 * preserved_cycles) + else 1 + preserved_cycles + in + let updated = Cycle_repr.add current_cycle delay in + Cycle_repr.max current_expiration updated + in + Storage.Contract.Delegate_desactivation.init_set + ctxt + (Contract_repr.implicit_contract delegate) + expiration + >>= fun ctxt -> + if not inactive then return ctxt + else + ensure_inited ctxt delegate + >>=? fun ctxt -> + let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in + Storage.Roll.Delegate_change.get ctxt delegate + >>=? fun change -> + Storage.Contract.Inactive_delegate.del + ctxt + (Contract_repr.implicit_contract delegate) + >>= fun ctxt -> + delegate_pubkey ctxt delegate + >>=? fun delegate_pk -> + let rec loop ctxt change = + if Tez_repr.(change < tokens_per_roll) then return ctxt + else + Tez_repr.(change -? tokens_per_roll) + >>?= fun change -> + create_roll_in_delegate ctxt delegate delegate_pk + >>=? fun ctxt -> loop ctxt change + in + loop ctxt change + >>=? fun ctxt -> + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? fun rolls -> + match rolls with + | None -> + return ctxt + | Some _ -> + Storage.Active_delegates_with_rolls.add ctxt delegate >|= ok +end + +module Contract = struct + let add_amount c contract amount = + get_contract_delegate c contract + >>=? function + | None -> return c | Some delegate -> Delegate.add_amount c delegate amount + + let remove_amount c contract amount = + get_contract_delegate c contract + >>=? function + | None -> + return c + | Some delegate -> + Delegate.remove_amount c delegate amount +end + +let init ctxt = Storage.Roll.Next.init ctxt Roll_repr.first + +let init_first_cycles ctxt = + let preserved = Constants_storage.preserved_cycles ctxt in + (* Precompute rolls for cycle (0 --> preserved_cycles) *) + fold_left_s + (fun ctxt c -> + let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in + Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 + >>=? fun ctxt -> + snapshot_rolls_for_cycle ctxt cycle + >>=? fun ctxt -> freeze_rolls_for_cycle ctxt cycle) + ctxt + (0 --> preserved) + >>=? fun ctxt -> + let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 1)) in + (* Precomputed a snapshot for cycle (preserved_cycles + 1) *) + Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 + >>=? fun ctxt -> + snapshot_rolls_for_cycle ctxt cycle + >>=? fun ctxt -> + (* Prepare storage for storing snapshots for cycle (preserved_cycles+2) *) + let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 2)) in + Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 + +let snapshot_rolls ctxt = + let current_level = Raw_context.current_level ctxt in + let preserved = Constants_storage.preserved_cycles ctxt in + let cycle = Cycle_repr.add current_level.cycle (preserved + 2) in + snapshot_rolls_for_cycle ctxt cycle + +let cycle_end ctxt last_cycle = + let preserved = Constants_storage.preserved_cycles ctxt in + ( match Cycle_repr.sub last_cycle preserved with + | None -> + return ctxt + | Some cleared_cycle -> + clear_cycle ctxt cleared_cycle ) + >>=? fun ctxt -> + let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved + 1) in + freeze_rolls_for_cycle ctxt frozen_roll_cycle + >>=? fun ctxt -> + Storage.Roll.Snapshot_for_cycle.init + ctxt + (Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle)) + 0 + +let update_tokens_per_roll ctxt new_tokens_per_roll = + let constants = Raw_context.constants ctxt in + let old_tokens_per_roll = constants.tokens_per_roll in + Raw_context.patch_constants ctxt (fun constants -> + {constants with Constants_repr.tokens_per_roll = new_tokens_per_roll}) + >>= fun ctxt -> + let decrease = Tez_repr.(new_tokens_per_roll < old_tokens_per_roll) in + ( if decrease then Tez_repr.(old_tokens_per_roll -? new_tokens_per_roll) + else Tez_repr.(new_tokens_per_roll -? old_tokens_per_roll) ) + >>?= fun abs_diff -> + Storage.Delegates.fold ctxt (Ok ctxt) (fun pkh ctxt_opt -> + ctxt_opt + >>?= fun ctxt -> + count_rolls ctxt pkh + >>=? fun rolls -> + Tez_repr.(abs_diff *? Int64.of_int rolls) + >>?= fun amount -> + if decrease then Delegate.add_amount ctxt pkh amount + else Delegate.remove_amount ctxt pkh amount) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/roll_storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/roll_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..6d0ca323dac30fb815e89c3d2b837196a3ec4773 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/roll_storage.mli @@ -0,0 +1,129 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** + Basic roll manipulation. + + If storage related to roll (i.e. `Storage.Roll`) is not used + outside of this module, this interface enforces the invariant that a + roll is always either in the limbo list or in a contract list. +*) + +type error += + | (* `Permanent *) Consume_roll_change + | (* `Permanent *) No_roll_for_delegate + | (* `Permanent *) No_roll_snapshot_for_cycle of Cycle_repr.t + | (* `Permanent *) Unregistered_delegate of Signature.Public_key_hash.t + +val init : Raw_context.t -> Raw_context.t tzresult Lwt.t + +val init_first_cycles : Raw_context.t -> Raw_context.t tzresult Lwt.t + +val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t + +val snapshot_rolls : Raw_context.t -> Raw_context.t tzresult Lwt.t + +val fold : + Raw_context.t -> + f:(Roll_repr.roll -> Signature.Public_key.t -> 'a -> 'a tzresult Lwt.t) -> + 'a -> + 'a tzresult Lwt.t + +val baking_rights_owner : + Raw_context.t -> + Level_repr.t -> + priority:int -> + Signature.Public_key.t tzresult Lwt.t + +val endorsement_rights_owner : + Raw_context.t -> + Level_repr.t -> + slot:int -> + Signature.Public_key.t tzresult Lwt.t + +module Delegate : sig + val is_inactive : + Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t + + val add_amount : + Raw_context.t -> + Signature.Public_key_hash.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t + + val remove_amount : + Raw_context.t -> + Signature.Public_key_hash.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t + + val set_inactive : + Raw_context.t -> + Signature.Public_key_hash.t -> + Raw_context.t tzresult Lwt.t + + val set_active : + Raw_context.t -> + Signature.Public_key_hash.t -> + Raw_context.t tzresult Lwt.t +end + +module Contract : sig + val add_amount : + Raw_context.t -> + Contract_repr.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t + + val remove_amount : + Raw_context.t -> + Contract_repr.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t +end + +val delegate_pubkey : + Raw_context.t -> + Signature.Public_key_hash.t -> + Signature.Public_key.t tzresult Lwt.t + +val get_rolls : + Raw_context.t -> + Signature.Public_key_hash.t -> + Roll_repr.t list tzresult Lwt.t + +val get_change : + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t + +val update_tokens_per_roll : + Raw_context.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t + +(**/**) + +val get_contract_delegate : + Raw_context.t -> + Contract_repr.t -> + Signature.Public_key_hash.t option tzresult Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/sapling_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/sapling_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..8ae12914e66effda5240a005c64f0e101d395f4e --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/sapling_repr.ml @@ -0,0 +1,95 @@ +(* The MIT License (MIT) + * + * Copyright (c) 2019-2020 Nomadic Labs + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. *) + +type transaction = Sapling.UTXO.transaction + +let transaction_encoding = Sapling.UTXO.transaction_encoding + +(* The two data structures in the state are all ordered by position, a diff + contains the elements starting from an offset position up to the most recent + position. A diff can be applied to a state stored in a context to obtain a + new state. + Diffs are used by the Michelson interpreter during the evaluation of smart + contracts to keep a temporary state that may be discarded. + Diffs are also returned by an RPC to allow a client to synchronize its own + state with the chain. + *) +type diff = { + commitments_and_ciphertexts : + (Sapling.Commitment.t * Sapling.Ciphertext.t) list; + nullifiers : Sapling.Nullifier.t list; +} + +let diff_encoding = + let open Data_encoding in + conv + (fun d -> (d.commitments_and_ciphertexts, d.nullifiers)) + (fun (commitments_and_ciphertexts, nullifiers) -> + ( match commitments_and_ciphertexts with + | [] -> + () + | (_cm_hd, ct_hd) :: rest -> + let memo_size = Sapling.Ciphertext.get_memo_size ct_hd in + List.iter + (fun (_cm, ct) -> + assert ( + Compare.Int.(Sapling.Ciphertext.get_memo_size ct = memo_size) + )) + rest ) ; + {commitments_and_ciphertexts; nullifiers}) + (obj2 + (req + "commitments_and_ciphertexts" + (list (tup2 Sapling.Commitment.encoding Sapling.Ciphertext.encoding))) + (req "nullifiers" (list Sapling.Nullifier.encoding))) + +module Memo_size = struct + type t = int + + let encoding = Data_encoding.uint16 + + let equal = Compare.Int.( = ) + + let max_uint16 = 0xffff + + let max_uint16_z = Z.of_int max_uint16 + + let err = + Error + ( "a positive 16-bit integer (between 0 and " ^ string_of_int max_uint16 + ^ ")" ) + + let parse_z z = + if Compare.Z.(Z.zero <= z) && Compare.Z.(z <= max_uint16_z) then + Ok (Z.to_int z) + else err + + let unparse_to_z = Z.of_int +end + +let transaction_get_memo_size (transaction : Sapling.UTXO.transaction) = + match transaction.outputs with + | [] -> + None + | {ciphertext; _} :: _ -> + (* Encoding ensures all ciphertexts have the same memo size. *) + Some (Sapling.Ciphertext.get_memo_size ciphertext) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/sapling_services.ml b/src/proto_008_PtEdo2Zk/lib_protocol/sapling_services.ml new file mode 100644 index 0000000000000000000000000000000000000000..dc5675c97e19fbd2d3b90bb5980f77b403cec87e --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/sapling_services.ml @@ -0,0 +1,100 @@ +(* The MIT License (MIT) + * + * Copyright (c) 2019-2020 Nomadic Labs + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. *) + +open Alpha_context + +let custom_root = + ( RPC_path.(open_root / "context" / "sapling") + : RPC_context.t RPC_path.context ) + +type diff_query = { + offset_commitment : Int64.t option; + offset_nullifier : Int64.t option; +} + +module S = struct + module Args = struct + type ('query, 'output) t = { + name : string; + description : string; + query : 'query RPC_query.t; + output : 'output Data_encoding.t; + f : context -> Sapling.Id.t -> 'query -> 'output tzresult Lwt.t; + } + + let get_diff_query : diff_query RPC_query.t = + let open RPC_query in + query (fun offset_commitment offset_nullifier -> + {offset_commitment; offset_nullifier}) + |+ opt_field + ~descr: + "Commitments and ciphertexts are returned from the specified \ + offset up to the most recent." + "offset_commitment" + RPC_arg.int64 + (fun {offset_commitment; _} -> offset_commitment) + |+ opt_field + ~descr: + "Nullifiers are returned from the specified offset up to the \ + most recent." + "offset_nullifier" + RPC_arg.int64 + (fun {offset_nullifier; _} -> offset_nullifier) + |> seal + + let encoding = + let open Data_encoding in + merge_objs + (obj1 (req "root" Sapling.root_encoding)) + Sapling.diff_encoding + + let get_diff = + { + name = "get_diff"; + description = + "Returns the root and a diff of a state starting from an optional \ + offset which is zero by default."; + query = get_diff_query; + output = encoding; + f = + (fun ctxt id {offset_commitment; offset_nullifier} -> + Sapling.get_diff ctxt id ?offset_commitment ?offset_nullifier ()); + } + end + + let make_service Args.{name; description; query; output; f} = + let path = RPC_path.(custom_root /: Sapling.rpc_arg / name) in + let service = RPC_service.get_service ~description ~query ~output path in + (service, fun ctxt id q () -> f ctxt id q) + + let get_diff = make_service Args.get_diff +end + +let register () = + let reg (service, f) = Services_registration.register1 service f in + reg S.get_diff + +let mk_call1 (service, _f) ctxt block id q = + RPC_context.make_call1 service ctxt block id q () + +let get_diff ctxt block id ?offset_commitment ?offset_nullifier () = + mk_call1 S.get_diff ctxt block id {offset_commitment; offset_nullifier} diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/sapling_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/sapling_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..41b9d4a39f32c6265e9c3722cb38e67b8840af30 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/sapling_storage.ml @@ -0,0 +1,512 @@ +(* The MIT License (MIT) + * + * Copyright (c) 2019-2020 Nomadic Labs + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. *) + +module Commitments : sig + val init : Raw_context.t -> Storage.Sapling.id -> Raw_context.t Lwt.t + + val default_root : Sapling.Hash.t + + val get_root : + Raw_context.t -> + Storage.Sapling.id -> + (Raw_context.t * Sapling.Hash.t) tzresult Lwt.t + + val add : + Raw_context.t -> + Storage.Sapling.id -> + Sapling.Commitment.t list -> + int64 -> + (Raw_context.t * int) tzresult Lwt.t + + val get_from : + Raw_context.t -> + Storage.Sapling.id -> + int64 -> + Sapling.Commitment.t list tzresult Lwt.t +end = struct + module H = Sapling.Hash + + (** Incremental Merkle Tree + * + * A tree of height h contains 2^h leaves and h+1 levels of nodes with + * leaves at level 0 and root at level h. + * + * The leaves are commitments and the tree it is treated as always filled + * with a default value H.uncommitted. This allows to have proofs of + * membership, or witnesses, of fixed size. + * + * All the nodes at the same level of an empty tree have the same hash, + * which can be computed from the default value of the leaves. This is + * stored in the [uncommitted] list. + * + * Any subtree filled with default values is represented by the Empty + * constructor and given its height it's possible to compute its hash + * using the [uncommitted] list. + * + * The leaves are indexed by their position [pos], ranging from 0 to + * (2^h)-1. The encoding of [pos] limits the possible size of the tree. + * In any case the only valid height for the Sapling library is 32, so even + * if the library encodes positions as uint64, they never exceed uint32. + * + * The tree is incremental in the sense that leaves cannot be modified but + * only added and exclusively in successive positions. + * + * Given that elements are added and retrieved by position, it is possible + * to use this information to efficiently navigate the tree. + * Given a tree of height [h] and a position [pos], if pos < pow2 (h-1) only + * the left subtree needs to be inspected recursively. Otherwise only the + * right needs to be visited, decreasing [pos] by [pow2 (h-1)]. + * + * In order to avoid storing the height for each subtree (or worse + * recomputing it), each function with suffix `_height` expects the height + * of the tree as parameter. These functions are only for internal use and + * are later aliased by functions using the default height of a Sapling + * incremental Merkle tree. + * + * Each node of the tree is indexed starting from the root at index 1, + * followed by its left child at index 2, right child at index 3 and so on + * until the last leaf at index 2^(depth+1)-1, or in terms of height + * 2^(32 - height +1) -1. + * The functions left and right return the index of the left and right child + * of a node. + *) + + let pow2 h = Int64.(shift_left 1L h) + + let max_height = 32 + + let max_size = pow2 max_height + + let assert_node node height = + assert ( + let first_of_height = pow2 (max_height - height) in + let first_of_next_height = Int64.shift_left first_of_height 1 in + Compare.Int64.(node >= first_of_height && node < first_of_next_height) ) + + let assert_height height = + assert (Compare.Int.(height >= 0 && height <= max_height)) + + let assert_pos pos height = + assert (Compare.Int64.(pos >= 0L && pos <= pow2 height)) + + let default_root = H.uncommitted max_height + + let init = Storage.Sapling.commitments_init + + let get_root_height ctx id node height = + assert_node node height ; + assert_height height ; + Storage.Sapling.Commitments.get_option (ctx, id) node + >|=? function + | (ctx, None) -> + let hash = H.uncommitted height in + (ctx, hash) + | (ctx, Some hash) -> + (ctx, hash) + + let left node = Int64.mul node 2L + + let right node = Int64.(add (mul node 2L) 1L) + + (* Not tail-recursive *) + let rec split_at n l = + if Compare.Int64.(n = 0L) then ([], l) + else + match l with + | [] -> + ([], l) + | x :: xs -> + let (l1, l2) = split_at Int64.(pred n) xs in + (x :: l1, l2) + + (* [insert tree height pos cms] inserts the list of commitments + [cms] in the tree [tree] of height [height] at the next position [pos]. + Returns the context, the size of the added storage, and the hash of the + node. Not tail-recursive. + Pre: incremental tree /\ + size tree + List.length cms <= pow2 height /\ + pos = size tree /\ + Post: incremental tree /\ + to_list (insert tree height pos cms) = to_list t @ cms *) + let rec insert ctx id node height pos cms = + assert_node node height ; + assert_height height ; + assert_pos pos height ; + match (height, cms) with + | (_, []) -> + get_root_height ctx id node height >|=? fun (ctx, h) -> (ctx, 0, h) + | (0, [cm]) -> + let h = H.of_commitment cm in + Storage.Sapling.Commitments.init (ctx, id) node h + >|=? fun (ctx, size) -> (ctx, size, h) + | _ -> + let height = height - 1 in + ( if Compare.Int64.(pos < pow2 height) then + let at = Int64.(sub (pow2 height) pos) in + let (cml, cmr) = split_at at cms in + insert ctx id (left node) height pos cml + >>=? fun (ctx, size_l, hl) -> + insert ctx id (right node) height 0L cmr + >|=? fun (ctx, size_r, hr) -> (ctx, size_l + size_r, hl, hr) + else + get_root_height ctx id (left node) height + >>=? fun (ctx, hl) -> + let pos = Int64.(sub pos (pow2 height)) in + insert ctx id (right node) height pos cms + >|=? fun (ctx, size_r, hr) -> (ctx, size_r, hl, hr) ) + >>=? fun (ctx, size_children, hl, hr) -> + let h = H.merkle_hash ~height hl hr in + Storage.Sapling.Commitments.init_set (ctx, id) node h + >|=? fun (ctx, size, _existing) -> (ctx, size + size_children, h) + + let rec fold_from_height ctx id node ~pos ~f ~acc height = + assert_node node height ; + assert_height height ; + assert_pos pos height ; + Storage.Sapling.Commitments.get_option (ctx, id) node + (* we don't count gas for this function, it is called only by RPC *) + >>=? function + | (_ctx, None) -> + return acc + | (_ctx, Some h) -> + if Compare.Int.(height = 0) then return (f acc h) + else + let full = pow2 (height - 1) in + if Compare.Int64.(pos < full) then + fold_from_height ctx id (left node) ~pos ~f ~acc (height - 1) + >>=? fun acc -> + (* Setting pos to 0 folds on the whole right subtree *) + fold_from_height ctx id (right node) ~pos:0L ~f ~acc (height - 1) + else + let pos = Int64.(sub pos full) in + fold_from_height ctx id (right node) ~pos ~f ~acc (height - 1) + + let root_node = 1L + + let get_root ctx id = get_root_height ctx id root_node max_height + + (* Expects pos to be the next position to insert. Pos is also the number of + inserted leaves. + A commitment should always be added together with a corresponding + ciphertext in the same position. + [insert] is not tail-recursive so we put a hard limit on the size of the + list of commitments. The use of [split_at] has O(n logn) complexity that is + less relevant on a smaller list. *) + let add ctx id cms pos = + let l = List.length cms in + assert (Compare.Int.(l <= 1000)) ; + let n' = Int64.(add pos (of_int l)) in + assert (Compare.Int64.(n' <= max_size)) ; + insert ctx id root_node max_height pos cms + >|=? fun (ctx, size, _h) -> (ctx, size) + + let get_from ctx id pos = + fold_from_height + ctx + id + root_node + ~pos + ~f:(fun acc c -> H.to_commitment c :: acc) + ~acc:[] + max_height + >|=? fun l -> List.rev l +end + +module Ciphertexts = struct + let init ctx id = Storage.Sapling.ciphertexts_init ctx id + + (* a ciphertext should always be added together with a corresponding + commitment in the same position *) + let add ctx id c pos = Storage.Sapling.Ciphertexts.init (ctx, id) pos c + + let get_from ctx id offset = + let rec aux (ctx, acc) pos = + Storage.Sapling.Ciphertexts.get_option (ctx, id) pos + >>=? fun (ctx, c) -> + match c with + | None -> + return (ctx, List.rev acc) + | Some c -> + aux (ctx, c :: acc) (Int64.succ pos) + in + aux (ctx, []) offset +end + +(* Collection of nullifiers w/o duplicates, append-only. It has a dual + implementation with a hash map for constant `mem` and with a ordered set to + retrieve by position. *) +module Nullifiers = struct + let init = Storage.Sapling.nullifiers_init + + let size ctx id = Storage.Sapling.Nullifiers_size.get (ctx, id) + + let mem ctx id nf = Storage.Sapling.Nullifiers_hashed.mem (ctx, id) nf + + (* Allows for duplicates as they are already checked by verify_update before + updating the state. + Not tail-recursive so we put a hard limit on the size of the + list of nullifiers. *) + let add ctx id nfs = + assert (Compare.Int.(List.length nfs <= 1000)) ; + size ctx id + >>=? fun nf_start_pos -> + fold_right_s + (fun nf (ctx, pos, acc_size) -> + Storage.Sapling.Nullifiers_hashed.init (ctx, id) nf + >>=? fun (ctx, size) -> + Storage.Sapling.Nullifiers_ordered.init (ctx, id) pos nf + >|=? fun ctx -> (ctx, Int64.succ pos, Z.add acc_size (Z.of_int size))) + nfs + (ctx, nf_start_pos, Z.zero) + >>=? fun (ctx, nf_end_pos, size) -> + Storage.Sapling.Nullifiers_size.set (ctx, id) nf_end_pos + >|=? fun ctx -> (ctx, size) + + let get_from ctx id offset = + let rec aux acc pos = + Storage.Sapling.Nullifiers_ordered.get_option (ctx, id) pos + >>=? function + | None -> + return @@ List.rev acc + | Some c -> + aux (c :: acc) (Int64.succ pos) + in + aux [] offset +end + +(** Bounded queue of roots. The full size is initialized with the default + uncommitted root, that's why roots storage doesn't need to be carbonated. + A maximum of one new root is added per protocol level. + If multiple transactions for the same shielded pool are processed during the + same contract call or several calls in the same block, only the last root + will be stored. + This property prevents transactions in the same block from depending on each + other and guarantees that a transaction will be valid for a least two hours + (hence the 120 size) after being forged. *) +module Roots = struct + let size = 120l + + (* pos is the index of the last inserted element *) + + let get ctx id = + Storage.Sapling.Roots_pos.get (ctx, id) + >>=? fun pos -> Storage.Sapling.Roots.get (ctx, id) pos + + let init ctx id = + let rec aux ctx pos = + if Compare.Int32.(pos < 0l) then return ctx + else + Storage.Sapling.Roots.init (ctx, id) pos Commitments.default_root + >>=? fun ctx -> aux ctx (Int32.pred pos) + in + aux ctx (Int32.pred size) + >>=? fun ctx -> + Storage.Sapling.Roots_pos.init (ctx, id) 0l + >>=? fun ctx -> + let level = (Raw_context.current_level ctx).level in + Storage.Sapling.Roots_level.init (ctx, id) level + + let mem ctx id root = + Storage.Sapling.Roots_pos.get (ctx, id) + >>=? fun start_pos -> + let rec aux pos = + Storage.Sapling.Roots.get (ctx, id) pos + >>=? fun hash -> + if Compare.Int.(Sapling.Hash.compare hash root = 0) then return true + else + let pos = Int32.(pred pos) in + let pos = if Compare.Int32.(pos < 0l) then Int32.pred size else pos in + if Compare.Int32.(pos = start_pos) then return false else aux pos + in + aux start_pos + + (* allows duplicates *) + let add ctx id root = + Storage.Sapling.Roots_pos.get (ctx, id) + >>=? fun pos -> + let level = (Raw_context.current_level ctx).level in + Storage.Sapling.Roots_level.get (ctx, id) + >>=? fun stored_level -> + if Raw_level_repr.(stored_level = level) then + (* if there is another add during the same level, it will over-write on + the same position *) + Storage.Sapling.Roots.init_set (ctx, id) pos root >|= ok + else + (* it's the first add for this level *) + Storage.Sapling.Roots_level.set (ctx, id) level + >>=? fun ctx -> + let pos = Int32.rem (Int32.succ pos) size in + Storage.Sapling.Roots_pos.set (ctx, id) pos + >>=? fun ctx -> Storage.Sapling.Roots.init_set (ctx, id) pos root >|= ok +end + +(** This type links the permanent state stored in the context at the specified + id together with the ephemeral diff managed by the Michelson + interpreter. After a successful execution the diff can be applied to update + the state at id. The first time a state is created its id is None, one will + be assigned after the first application. *) +type state = { + id : Lazy_storage_kind.Sapling_state.Id.t option; + diff : Sapling_repr.diff; + memo_size : Sapling_repr.Memo_size.t; +} + +let empty_diff = + Sapling_repr.{commitments_and_ciphertexts = []; nullifiers = []} + +let empty_state ?id ~memo_size () = {id; diff = empty_diff; memo_size} + +(** Returns a state from an existing id. *) +let state_from_id ctxt id = + Storage.Sapling.Memo_size.get (ctxt, id) + >|=? fun memo_size -> ({id = Some id; diff = empty_diff; memo_size}, ctxt) + +let rpc_arg = Storage.Sapling.rpc_arg + +let get_memo_size ctx id = Storage.Sapling.Memo_size.get (ctx, id) + +let init ctx id ~memo_size = + Storage.Sapling.Memo_size.init_set (ctx, id) memo_size + >>= fun ctx -> + Storage.Sapling.Commitments_size.init_set (ctx, id) Int64.zero + >>= fun ctx -> + Commitments.init ctx id + >>= fun ctx -> + Nullifiers.init ctx id + >>= fun ctx -> + Roots.init ctx id >>=? fun ctx -> Ciphertexts.init ctx id >|= ok + +(* Gas costs for apply_diff. *) +let sapling_apply_diff_cost ~inputs ~outputs = + Z.add + (Z.of_int 1_300_000) + (Z.add + (Z.mul (Z.of_int inputs) (Z.of_int 5_000)) + (Z.mul (Z.of_int outputs) (Z.of_int 55_000))) + +(** Applies a diff to a state id stored in the context. Updates Commitments, + Ciphertexts and Nullifiers using the diff and updates the Roots using the + new Commitments tree. *) +let apply_diff ctx id diff = + let open Sapling_repr in + let nb_commitments = List.length diff.commitments_and_ciphertexts in + let nb_nullifiers = List.length diff.nullifiers in + Raw_context.consume_gas + ctx + (sapling_apply_diff_cost ~inputs:nb_nullifiers ~outputs:nb_commitments) + >>?= fun ctx -> + Storage.Sapling.Commitments_size.get (ctx, id) + >>=? fun cm_start_pos -> + let cms = List.rev_map fst diff.commitments_and_ciphertexts in + Commitments.add ctx id cms cm_start_pos + >>=? fun (ctx, size) -> + Storage.Sapling.Commitments_size.set + (ctx, id) + (Int64.add cm_start_pos (Int64.of_int nb_commitments)) + >>=? fun ctx -> + fold_right_s + (fun (_cm, cp) (ctx, pos, acc_size) -> + Ciphertexts.add ctx id cp pos + >|=? fun (ctx, size) -> + (ctx, Int64.succ pos, Z.add acc_size (Z.of_int size))) + diff.commitments_and_ciphertexts + (ctx, cm_start_pos, Z.of_int size) + >>=? fun (ctx, _ct_end_pos, size) -> + Nullifiers.add ctx id diff.nullifiers + >>=? fun (ctx, size_nf) -> + let size = Z.add size size_nf in + match diff.commitments_and_ciphertexts with + | [] -> + (* avoids adding duplicates to Roots *) + return (ctx, size) + | _ :: _ -> + Commitments.get_root ctx id + >>=? fun (ctx, root) -> Roots.add ctx id root >|=? fun ctx -> (ctx, size) + +let add {id; diff; memo_size} cm_cipher_list = + assert ( + List.for_all + (fun (_cm, cipher) -> + Compare.Int.(Sapling.Ciphertext.get_memo_size cipher = memo_size)) + cm_cipher_list ) ; + { + id; + diff = + { + diff with + commitments_and_ciphertexts = + List.rev cm_cipher_list @ diff.commitments_and_ciphertexts; + }; + memo_size; + } + +let root_mem ctx {id} tested_root = + match id with + | Some id -> + Roots.mem ctx id tested_root + | None -> + return + Compare.Int.( + Sapling.Hash.compare tested_root Commitments.default_root = 0) + +(* to avoid a double spend we need to check the disk AND the diff *) +let nullifiers_mem ctx {id; diff} nf = + let exists_in_diff = + List.exists + (fun v -> Compare.Int.(Sapling.Nullifier.compare nf v = 0)) + diff.nullifiers + in + if exists_in_diff then return (ctx, true) + else + match id with + | None -> + return (ctx, false) + | Some id -> + Nullifiers.mem ctx id nf + +(* Allows for duplicates as they are already checked by verify_update before + updating the state. *) +let nullifiers_add {id; diff; memo_size} nf = + {id; diff = {diff with nullifiers = nf :: diff.nullifiers}; memo_size} + +type root = Sapling.Hash.t + +let root_encoding = Sapling.Hash.encoding + +let get_diff ctx id ?(offset_commitment = 0L) ?(offset_nullifier = 0L) () = + if + not + Sapling.Commitment.( + valid_position offset_commitment && valid_position offset_nullifier) + then failwith "Invalid argument." + else + Commitments.get_from ctx id offset_commitment + >>=? fun commitments -> + Roots.get ctx id + >>=? fun root -> + Nullifiers.get_from ctx id offset_nullifier + >>=? fun nullifiers -> + Ciphertexts.get_from ctx id offset_commitment + (* we don't count gas for RPCs *) + >|=? fun (_ctx, ciphertexts) -> + let commitments_and_ciphertexts = List.combine commitments ciphertexts in + (root, Sapling_repr.{commitments_and_ciphertexts; nullifiers}) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/sapling_validator.ml b/src/proto_008_PtEdo2Zk/lib_protocol/sapling_validator.ml new file mode 100644 index 0000000000000000000000000000000000000000..bafb7df54e7103cbf0f43e05a2b03cca3168e4c5 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/sapling_validator.ml @@ -0,0 +1,110 @@ +(* The MIT License (MIT) + * + * Copyright (c) 2019-2020 Nomadic Labs + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. *) + +(* Check that each nullifier is not already present in the state and add it. + Important to avoid spending the same input twice in a transaction. *) +let rec check_and_update_nullifiers ctxt state inputs = + match inputs with + | [] -> + return (ctxt, Some state) + | input :: inputs -> ( + Sapling_storage.nullifiers_mem ctxt state Sapling.UTXO.(input.nf) + >>=? function + | (ctxt, true) -> + return (ctxt, None) + | (ctxt, false) -> + let state = + Sapling_storage.nullifiers_add state Sapling.UTXO.(input.nf) + in + check_and_update_nullifiers ctxt state inputs ) + +let verify_update : + Raw_context.t -> + Sapling_storage.state -> + Sapling_repr.transaction -> + string -> + (Raw_context.t * (Int64.t * Sapling_storage.state) option) tzresult Lwt.t = + fun ctxt state transaction key -> + (* Check the transaction *) + (* To avoid overflowing the balance, the number of inputs and outputs must be + bounded. + Ciphertexts' memo_size must match the state's memo_size. + These constraints are already enforced at the encoding level. *) + assert (Compare.Int.(List.compare_length_with transaction.inputs 5208 <= 0)) ; + assert (Compare.Int.(List.compare_length_with transaction.outputs 2019 <= 0)) ; + let pass = + List.for_all + (fun output -> + Compare.Int.( + Sapling.Ciphertext.get_memo_size Sapling.UTXO.(output.ciphertext) + = state.memo_size)) + transaction.outputs + in + if not pass then return (ctxt, None) + else + (* Check the root is a recent state *) + Sapling_storage.root_mem ctxt state transaction.root + >>=? fun pass -> + if not pass then return (ctxt, None) + else + check_and_update_nullifiers ctxt state transaction.inputs + >|=? function + | (ctxt, None) -> + (ctxt, None) + | (ctxt, Some state) -> + Sapling.Verification.with_verification_ctx (fun vctx -> + let pass = + (* Check all the output ZK proofs *) + List.for_all + (fun output -> Sapling.Verification.check_output vctx output) + transaction.outputs + in + if not pass then (ctxt, None) + else + let pass = + (* Check all the input Zk proofs and signatures *) + List.for_all + (fun input -> + Sapling.Verification.check_spend + vctx + input + transaction.root + key) + transaction.inputs + in + if not pass then (ctxt, None) + else + let pass = + (* Check the signature and balance of the whole transaction *) + Sapling.Verification.final_check vctx transaction key + in + if not pass then (ctxt, None) + else + (* update tree *) + let list_to_add = + List.map + (fun output -> + Sapling.UTXO.(output.cm, output.ciphertext)) + transaction.outputs + in + let state = Sapling_storage.add state list_to_add in + (ctxt, Some (transaction.balance, state))) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_expr_hash.ml b/src/proto_008_PtEdo2Zk/lib_protocol/script_expr_hash.ml new file mode 100644 index 0000000000000000000000000000000000000000..2c7f93a04bb0a2e8a32bb081b035a5daff212984 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_expr_hash.ml @@ -0,0 +1,40 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let script_expr_hash = "\013\044\064\027" (* expr(54) *) + +include Blake2B.Make + (Base58) + (struct + let name = "script_expr" + + let title = "A script expression ID" + + let b58check_prefix = script_expr_hash + + let size = None + end) + +let () = Base58.check_encoded_prefix b58check_encoding "expr" 54 diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_int_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/script_int_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..9ee84138091da2ac1a7d82a98457fb0597b683cd --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_int_repr.ml @@ -0,0 +1,104 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type n = Natural_tag + +type z = Integer_tag + +type 't num = Z.t + +let compare x y = Z.compare x y + +let zero = Z.zero + +let zero_n = Z.zero + +let to_string x = Z.to_string x + +let of_string s = try Some (Z.of_string s) with _ -> None + +let of_int32 n = Z.of_int64 @@ Int64.of_int32 n + +let to_int64 x = try Some (Z.to_int64 x) with _ -> None + +let of_int64 n = Z.of_int64 n + +let to_int x = try Some (Z.to_int x) with _ -> None + +let of_int n = Z.of_int n + +let of_zint x = x + +let to_zint x = x + +let add x y = Z.add x y + +let sub x y = Z.sub x y + +let mul x y = Z.mul x y + +let ediv x y = + try + let (q, r) = Z.ediv_rem x y in + Some (q, r) + with _ -> None + +let add_n = add + +let mul_n = mul + +let ediv_n = ediv + +let abs x = Z.abs x + +let is_nat x = if Compare.Z.(x < Z.zero) then None else Some x + +let neg x = Z.neg x + +let int x = x + +let shift_left x y = + if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None + else + let y = Z.to_int y in + Some (Z.shift_left x y) + +let shift_right x y = + if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None + else + let y = Z.to_int y in + Some (Z.shift_right x y) + +let shift_left_n = shift_left + +let shift_right_n = shift_right + +let logor x y = Z.logor x y + +let logxor x y = Z.logxor x y + +let logand x y = Z.logand x y + +let lognot x = Z.lognot x diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_int_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/script_int_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..fb4a766745c0ded3d4647f5622e99066249c3ace --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_int_repr.mli @@ -0,0 +1,146 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** The types for arbitrary precision integers in Michelson. + The type variable ['t] is always [n] or [z], + [n num] and [z num] are incompatible. + + This is internally a [Z.t]. + This module mostly adds signedness preservation guarantees. *) +type 't num + +(** Flag for natural numbers. *) +type n = Natural_tag + +(** Flag for relative numbers. *) +type z = Integer_tag + +(** Natural zero. *) +val zero_n : n num + +(** Relative zero. *) +val zero : z num + +(** Compare two numbers as if they were *) +val compare : 'a num -> 'a num -> int + +(** Conversion to an OCaml [string] in decimal notation. *) +val to_string : _ num -> string + +(** Conversion from an OCaml [string]. + Returns [None] in case of an invalid notation. + Supports [+] and [-] sign modifiers, and [0x], [0o] and [0b] base modifiers. *) +val of_string : string -> z num option + +(** Conversion from an OCaml [int32]. *) +val of_int32 : int32 -> z num + +(** Conversion to an OCaml [int64], returns [None] on overflow. *) +val to_int64 : _ num -> int64 option + +(** Conversion from an OCaml [int64]. *) +val of_int64 : int64 -> z num + +(** Conversion to an OCaml [int], returns [None] on overflow. *) +val to_int : _ num -> int option + +(** Conversion from an OCaml [int]. *) +val of_int : int -> z num + +(** Conversion from a Zarith integer ([Z.t]). *) +val of_zint : Z.t -> z num + +(** Conversion to a Zarith integer ([Z.t]). *) +val to_zint : 'a num -> Z.t + +(** Addition between naturals. *) +val add_n : n num -> n num -> n num + +(** Multiplication between naturals. *) +val mul_n : n num -> n num -> n num + +(** Euclidean division between naturals. + [ediv_n n d] returns [None] if divisor is zero, + or [Some (q, r)] where [n = d * q + r] and [[0 <= r < d]] otherwise. *) +val ediv_n : n num -> n num -> (n num * n num) option + +(** Sign agnostic addition. + Use {!add_n} when working with naturals to preserve the sign. *) +val add : _ num -> _ num -> z num + +(** Sign agnostic subtraction. + Use {!sub_n} when working with naturals to preserve the sign. *) +val sub : _ num -> _ num -> z num + +(** Sign agnostic multiplication. + Use {!mul_n} when working with naturals to preserve the sign. *) +val mul : _ num -> _ num -> z num + +(** Sign agnostic euclidean division. + [ediv n d] returns [None] if divisor is zero, + or [Some (q, r)] where [n = d * q + r] and [[0 <= r < |d|]] otherwise. + Use {!ediv_n} when working with naturals to preserve the sign. *) +val ediv : _ num -> _ num -> (z num * n num) option + +(** Compute the absolute value of a relative, turning it into a natural. *) +val abs : z num -> n num + +(** Partial identity over [N]. *) +val is_nat : z num -> n num option + +(** Negates a number. *) +val neg : _ num -> z num + +(** Turns a natural into a relative, not changing its value. *) +val int : n num -> z num + +(** Reverses each bit in the representation of the number. + Also applies to the sign. *) +val lognot : _ num -> z num + +(** Shifts the natural to the left of a number of bits between 0 and 256. + Returns [None] if the amount is too high. *) +val shift_left_n : n num -> n num -> n num option + +(** Shifts the natural to the right of a number of bits between 0 and 256. + Returns [None] if the amount is too high. *) +val shift_right_n : n num -> n num -> n num option + +(** Shifts the number to the left of a number of bits between 0 and 256. + Returns [None] if the amount is too high. *) +val shift_left : 'a num -> n num -> 'a num option + +(** Shifts the number to the right of a number of bits between 0 and 256. + Returns [None] if the amount is too high. *) +val shift_right : 'a num -> n num -> 'a num option + +(** Applies a boolean or operation to each bit. *) +val logor : 'a num -> 'a num -> 'a num + +(** Applies a boolean and operation to each bit. *) +val logand : _ num -> n num -> n num + +(** Applies a boolean xor operation to each bit. *) +val logxor : n num -> n num -> n num diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_interpreter.ml b/src/proto_008_PtEdo2Zk/lib_protocol/script_interpreter.ml new file mode 100644 index 0000000000000000000000000000000000000000..95916b1367bd00cfba5bc2bdfc8c6584d0ea41f8 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_interpreter.ml @@ -0,0 +1,1554 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script +open Script_typed_ir +open Script_ir_translator + +(* ---- Run-time errors -----------------------------------------------------*) + +type execution_trace = + (Script.location * Gas.t * (Script.expr * string option) list) list + +type error += + | Reject of Script.location * Script.expr * execution_trace option + +type error += Overflow of Script.location * execution_trace option + +type error += Runtime_contract_error : Contract.t * Script.expr -> error + +type error += Bad_contract_parameter of Contract.t (* `Permanent *) + +type error += Cannot_serialize_failure + +type error += Cannot_serialize_storage + +type error += Michelson_too_many_recursive_calls + +let () = + let open Data_encoding in + let trace_encoding = + list + @@ obj3 + (req "location" Script.location_encoding) + (req "gas" Gas.encoding) + (req + "stack" + (list (obj2 (req "item" Script.expr_encoding) (opt "annot" string)))) + in + (* Reject *) + register_error_kind + `Temporary + ~id:"michelson_v1.script_rejected" + ~title:"Script failed" + ~description:"A FAILWITH instruction was reached" + (obj3 + (req "location" Script.location_encoding) + (req "with" Script.expr_encoding) + (opt "trace" trace_encoding)) + (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None) + (fun (loc, v, trace) -> Reject (loc, v, trace)) ; + (* Overflow *) + register_error_kind + `Temporary + ~id:"michelson_v1.script_overflow" + ~title:"Script failed (overflow error)" + ~description: + "A FAIL instruction was reached due to the detection of an overflow" + (obj2 + (req "location" Script.location_encoding) + (opt "trace" trace_encoding)) + (function Overflow (loc, trace) -> Some (loc, trace) | _ -> None) + (fun (loc, trace) -> Overflow (loc, trace)) ; + (* Runtime contract error *) + register_error_kind + `Temporary + ~id:"michelson_v1.runtime_error" + ~title:"Script runtime error" + ~description:"Toplevel error for all runtime script errors" + (obj2 + (req "contract_handle" Contract.encoding) + (req "contract_code" Script.expr_encoding)) + (function + | Runtime_contract_error (contract, expr) -> + Some (contract, expr) + | _ -> + None) + (fun (contract, expr) -> Runtime_contract_error (contract, expr)) ; + (* Bad contract parameter *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_contract_parameter" + ~title:"Contract supplied an invalid parameter" + ~description: + "Either no parameter was supplied to a contract with a non-unit \ + parameter type, a non-unit parameter was passed to an account, or a \ + parameter was supplied of the wrong type" + Data_encoding.(obj1 (req "contract" Contract.encoding)) + (function Bad_contract_parameter c -> Some c | _ -> None) + (fun c -> Bad_contract_parameter c) ; + (* Cannot serialize failure *) + register_error_kind + `Temporary + ~id:"michelson_v1.cannot_serialize_failure" + ~title:"Not enough gas to serialize argument of FAILWITH" + ~description: + "Argument of FAILWITH was too big to be serialized with the provided gas" + Data_encoding.empty + (function Cannot_serialize_failure -> Some () | _ -> None) + (fun () -> Cannot_serialize_failure) ; + (* Cannot serialize storage *) + register_error_kind + `Temporary + ~id:"michelson_v1.cannot_serialize_storage" + ~title:"Not enough gas to serialize execution storage" + ~description: + "The returned storage was too big to be serialized with the provided gas" + Data_encoding.empty + (function Cannot_serialize_storage -> Some () | _ -> None) + (fun () -> Cannot_serialize_storage) ; + (* Michelson Stack Overflow *) + register_error_kind + `Permanent + ~id:"michelson_v1.interp_too_many_recursive_calls" + ~title:"Too many recursive calls during interpretation" + ~description: + "Too many recursive calls were needed for interpretation of a Michelson \ + script" + Data_encoding.empty + (function Michelson_too_many_recursive_calls -> Some () | _ -> None) + (fun () -> Michelson_too_many_recursive_calls) + +(* ---- interpreter ---------------------------------------------------------*) + +module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter + +let rec interp_stack_prefix_preserving_operation : + type fbef bef faft aft result. + (fbef -> (faft * result) tzresult Lwt.t) -> + (fbef, faft, bef, aft) stack_prefix_preservation_witness -> + bef -> + (aft * result) tzresult Lwt.t = + fun f n stk -> + match (n, stk) with + | ( Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))), + ( v0, + ( v1, + ( v2, + ( v3, + ( v4, + ( v5, + ( v6, + (v7, (v8, (v9, (va, (vb, (vc, (vd, (ve, (vf, rest))))))))) + ) ) ) ) ) ) ) ) -> + interp_stack_prefix_preserving_operation f n rest + >|=? fun (rest', result) -> + ( ( v0, + ( v1, + ( v2, + ( v3, + ( v4, + ( v5, + ( v6, + ( v7, + (v8, (v9, (va, (vb, (vc, (vd, (ve, (vf, rest')))))))) + ) ) ) ) ) ) ) ), + result ) + | (Prefix (Prefix (Prefix (Prefix n))), (v0, (v1, (v2, (v3, rest))))) -> + interp_stack_prefix_preserving_operation f n rest + >|=? fun (rest', result) -> ((v0, (v1, (v2, (v3, rest')))), result) + | (Prefix n, (v, rest)) -> + interp_stack_prefix_preserving_operation f n rest + >|=? fun (rest', result) -> ((v, rest'), result) + | (Rest, v) -> + f v + +type step_constants = { + source : Contract.t; + payer : Contract.t; + self : Contract.t; + amount : Tez.t; + chain_id : Chain_id.t; +} + +module type STEP_LOGGER = sig + val log_interp : + context -> ('bef, 'aft) Script_typed_ir.descr -> 'bef -> unit + + val log_entry : context -> ('bef, 'aft) Script_typed_ir.descr -> 'bef -> unit + + val log_exit : context -> ('bef, 'aft) Script_typed_ir.descr -> 'aft -> unit + + val get_log : unit -> execution_trace option tzresult Lwt.t +end + +type logger = (module STEP_LOGGER) + +module No_trace : STEP_LOGGER = struct + let log_interp _ctxt _descr _stack = () + + let log_entry _ctxt _descr _stack = () + + let log_exit _ctxt _descr _stack = () + + let get_log () = return_none +end + +let cost_of_instr : type b a. (b, a) descr -> b -> Gas.cost = + fun descr stack -> + match (descr.instr, stack) with + | (Drop, _) -> + Interp_costs.drop + | (Dup, _) -> + Interp_costs.dup + | (Swap, _) -> + Interp_costs.swap + | (Const _, _) -> + Interp_costs.push + | (Cons_some, _) -> + Interp_costs.cons_some + | (Cons_none _, _) -> + Interp_costs.cons_none + | (If_none _, _) -> + Interp_costs.if_none + | (Cons_pair, _) -> + Interp_costs.cons_pair + | (Unpair, _) -> + Interp_costs.unpair + | (Car, _) -> + Interp_costs.car + | (Cdr, _) -> + Interp_costs.cdr + | (Cons_left, _) -> + Interp_costs.cons_left + | (Cons_right, _) -> + Interp_costs.cons_right + | (If_left _, _) -> + Interp_costs.if_left + | (Cons_list, _) -> + Interp_costs.cons_list + | (Nil, _) -> + Interp_costs.nil + | (If_cons _, _) -> + Interp_costs.if_cons + | (List_map _, (list, _)) -> + Interp_costs.list_map list + | (List_size, _) -> + Interp_costs.list_size + | (List_iter _, (l, _)) -> + Interp_costs.list_iter l + | (Empty_set _, _) -> + Interp_costs.empty_set + | (Set_iter _, (set, _)) -> + Interp_costs.set_iter set + | (Set_mem, (v, (set, _))) -> + Interp_costs.set_mem v set + | (Set_update, (v, (_, (set, _)))) -> + Interp_costs.set_update v set + | (Set_size, _) -> + Interp_costs.set_size + | (Empty_map _, _) -> + Interp_costs.empty_map + | (Map_map _, (map, _)) -> + Interp_costs.map_map map + | (Map_iter _, (map, _)) -> + Interp_costs.map_iter map + | (Map_mem, (v, (map, _rest))) -> + Interp_costs.map_mem v map + | (Map_get, (v, (map, _rest))) -> + Interp_costs.map_get v map + | (Map_update, (k, (_, (map, _)))) -> + Interp_costs.map_update k map + | (Map_get_and_update, (k, (_, (map, _)))) -> + Interp_costs.map_get_and_update k map + | (Map_size, _) -> + Interp_costs.map_size + | (Empty_big_map _, _) -> + Interp_costs.empty_map + | (Big_map_mem, (key, (map, _))) -> + Interp_costs.map_mem key map.diff + | (Big_map_get, (key, (map, _))) -> + Interp_costs.map_get key map.diff + | (Big_map_update, (key, (_, (map, _)))) -> + Interp_costs.map_update key map.diff + | (Big_map_get_and_update, (key, (_, (map, _)))) -> + Interp_costs.map_get_and_update key map.diff + | (Add_seconds_to_timestamp, (n, (t, _))) -> + Interp_costs.add_seconds_timestamp n t + | (Add_timestamp_to_seconds, (t, (n, _))) -> + Interp_costs.add_seconds_timestamp n t + | (Sub_timestamp_seconds, (t, (n, _))) -> + Interp_costs.sub_seconds_timestamp n t + | (Diff_timestamps, (t1, (t2, _))) -> + Interp_costs.diff_timestamps t1 t2 + | (Concat_string_pair, (x, (y, _))) -> + Interp_costs.concat_string_pair x y + | (Concat_string, (ss, _)) -> + Interp_costs.concat_string_precheck ss + | (Slice_string, (_offset, (_length, (s, _)))) -> + Interp_costs.slice_string s + | (String_size, _) -> + Interp_costs.string_size + | (Concat_bytes_pair, (x, (y, _))) -> + Interp_costs.concat_bytes_pair x y + | (Concat_bytes, (ss, _)) -> + Interp_costs.concat_string_precheck ss + | (Slice_bytes, (_offset, (_length, (s, _)))) -> + Interp_costs.slice_bytes s + | (Bytes_size, _) -> + Interp_costs.bytes_size + | (Add_tez, _) -> + Interp_costs.add_tez + | (Sub_tez, _) -> + Interp_costs.sub_tez + | (Mul_teznat, (_, (n, _))) -> + Interp_costs.mul_teznat n + | (Mul_nattez, (n, (_, _))) -> + Interp_costs.mul_teznat n + | (Or, _) -> + Interp_costs.bool_or + | (And, _) -> + Interp_costs.bool_and + | (Xor, _) -> + Interp_costs.bool_xor + | (Not, _) -> + Interp_costs.bool_not + | (Is_nat, _) -> + Interp_costs.is_nat + | (Abs_int, (x, _)) -> + Interp_costs.abs_int x + | (Int_nat, _) -> + Interp_costs.int_nat + | (Neg_int, (x, _)) -> + Interp_costs.neg_int x + | (Neg_nat, (x, _)) -> + Interp_costs.neg_nat x + | (Add_intint, (x, (y, _))) -> + Interp_costs.add_bigint x y + | (Add_intnat, (x, (y, _))) -> + Interp_costs.add_bigint x y + | (Add_natint, (x, (y, _))) -> + Interp_costs.add_bigint x y + | (Add_natnat, (x, (y, _))) -> + Interp_costs.add_bigint x y + | (Sub_int, (x, (y, _))) -> + Interp_costs.sub_bigint x y + | (Mul_intint, (x, (y, _))) -> + Interp_costs.mul_bigint x y + | (Mul_intnat, (x, (y, _))) -> + Interp_costs.mul_bigint x y + | (Mul_natint, (x, (y, _))) -> + Interp_costs.mul_bigint x y + | (Mul_natnat, (x, (y, _))) -> + Interp_costs.mul_bigint x y + | (Ediv_teznat, (x, (y, _))) -> + Interp_costs.ediv_teznat x y + | (Ediv_tez, _) -> + Interp_costs.ediv_tez + | (Ediv_intint, (x, (y, _))) -> + Interp_costs.ediv_bigint x y + | (Ediv_intnat, (x, (y, _))) -> + Interp_costs.ediv_bigint x y + | (Ediv_natint, (x, (y, _))) -> + Interp_costs.ediv_bigint x y + | (Ediv_natnat, (x, (y, _))) -> + Interp_costs.ediv_bigint x y + | (Lsl_nat, (x, _)) -> + Interp_costs.lsl_nat x + | (Lsr_nat, (x, _)) -> + Interp_costs.lsr_nat x + | (Or_nat, (x, (y, _))) -> + Interp_costs.or_nat x y + | (And_nat, (x, (y, _))) -> + Interp_costs.and_nat x y + | (And_int_nat, (x, (y, _))) -> + Interp_costs.and_nat x y + | (Xor_nat, (x, (y, _))) -> + Interp_costs.xor_nat x y + | (Not_int, (x, _)) -> + Interp_costs.not_nat x + | (Not_nat, (x, _)) -> + Interp_costs.not_nat x + | (Seq _, _) -> + Interp_costs.seq + | (If _, _) -> + Interp_costs.if_ + | (Loop _, _) -> + Interp_costs.loop + | (Loop_left _, _) -> + Interp_costs.loop_left + | (Dip _, _) -> + Interp_costs.dip + | (Exec, _) -> + Interp_costs.exec + | (Apply _, _) -> + Interp_costs.apply + | (Lambda _, _) -> + Interp_costs.push + | (Failwith _, _) -> + Gas.free + | (Nop, _) -> + Interp_costs.nop + | (Compare ty, (a, (b, _))) -> + Interp_costs.compare ty a b + | (Eq, _) -> + Interp_costs.neq + | (Neq, _) -> + Interp_costs.neq + | (Lt, _) -> + Interp_costs.neq + | (Le, _) -> + Interp_costs.neq + | (Gt, _) -> + Interp_costs.neq + | (Ge, _) -> + Interp_costs.neq + | (Pack _, _) -> + Gas.free + | (Unpack _, _) -> + Gas.free + | (Address, _) -> + Interp_costs.address + | (Contract _, _) -> + Interp_costs.contract + | (Transfer_tokens, _) -> + Interp_costs.transfer_tokens + | (Implicit_account, _) -> + Interp_costs.implicit_account + | (Set_delegate, _) -> + Interp_costs.set_delegate + | (Balance, _) -> + Interp_costs.balance + | (Level, _) -> + Interp_costs.level + | (Now, _) -> + Interp_costs.now + | (Check_signature, (key, (_, (message, _)))) -> + Interp_costs.check_signature key message + | (Hash_key, (pk, _)) -> + Interp_costs.hash_key pk + | (Blake2b, (bytes, _)) -> + Interp_costs.blake2b bytes + | (Sha256, (bytes, _)) -> + Interp_costs.sha256 bytes + | (Sha512, (bytes, _)) -> + Interp_costs.sha512 bytes + | (Source, _) -> + Interp_costs.source + | (Sender, _) -> + Interp_costs.source + | (Self _, _) -> + Interp_costs.self + | (Self_address, _) -> + Interp_costs.self + | (Amount, _) -> + Interp_costs.amount + | (Dig (n, _), _) -> + Interp_costs.dign n + | (Dug (n, _), _) -> + Interp_costs.dugn n + | (Dipn (n, _, _), _) -> + Interp_costs.dipn n + | (Dropn (n, _), _) -> + Interp_costs.dropn n + | (ChainId, _) -> + Interp_costs.chain_id + | (Create_contract _, _) -> + Interp_costs.create_contract + | (Never, (_, _)) -> + . + | (Voting_power, _) -> + Interp_costs.voting_power + | (Total_voting_power, _) -> + Interp_costs.total_voting_power + | (Keccak, (bytes, _)) -> + Interp_costs.keccak bytes + | (Sha3, (bytes, _)) -> + Interp_costs.sha3 bytes + | (Add_bls12_381_g1, _) -> + Interp_costs.add_bls12_381_g1 + | (Add_bls12_381_g2, _) -> + Interp_costs.add_bls12_381_g2 + | (Add_bls12_381_fr, _) -> + Interp_costs.add_bls12_381_fr + | (Mul_bls12_381_g1, _) -> + Interp_costs.mul_bls12_381_g1 + | (Mul_bls12_381_g2, _) -> + Interp_costs.mul_bls12_381_g2 + | (Mul_bls12_381_fr, _) -> + Interp_costs.mul_bls12_381_fr + | (Mul_bls12_381_fr_z, _) -> + Interp_costs.mul_bls12_381_fr_z + | (Mul_bls12_381_z_fr, _) -> + Interp_costs.mul_bls12_381_fr_z + | (Int_bls12_381_fr, _) -> + Interp_costs.int_bls12_381_fr + | (Neg_bls12_381_g1, _) -> + Interp_costs.neg_bls12_381_g1 + | (Neg_bls12_381_g2, _) -> + Interp_costs.neg_bls12_381_g2 + | (Neg_bls12_381_fr, _) -> + Interp_costs.neg_bls12_381_fr + | (Pairing_check_bls12_381, (pairs, _)) -> + Interp_costs.pairing_check_bls12_381 pairs + | (Comb (n, _), _) -> + Interp_costs.comb n + | (Uncomb (n, _), _) -> + Interp_costs.uncomb n + | (Comb_get (n, _), _) -> + Interp_costs.comb_get n + | (Comb_set (n, _), _) -> + Interp_costs.comb_set n + | (Dup_n (n, _), _) -> + Interp_costs.dupn n + | (Sapling_empty_state _, _) -> + Interp_costs.sapling_empty_state + | (Sapling_verify_update, (tx, _)) -> + let inputs = List.length tx.inputs in + let outputs = List.length tx.outputs in + Interp_costs.sapling_verify_update ~inputs ~outputs + | (Ticket, _) -> + Interp_costs.ticket + | (Read_ticket, _) -> + Interp_costs.read_ticket + | (Split_ticket, (ticket, ((amount_a, amount_b), _))) -> + Interp_costs.split_ticket ticket.amount amount_a amount_b + | (Join_tickets ty, ((ticket_a, ticket_b), _)) -> + Interp_costs.join_tickets ty ticket_a ticket_b + +let unpack ctxt ~ty ~bytes = + Gas.check_enough ctxt (Script.serialized_cost bytes) + >>?= fun () -> + if + Compare.Int.(Bytes.length bytes >= 1) + && Compare.Int.(TzEndian.get_uint8 bytes 0 = 0x05) + then + let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in + match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with + | None -> + Lwt.return + ( Gas.consume ctxt (Interp_costs.unpack_failed bytes) + >|? fun ctxt -> (None, ctxt) ) + | Some expr -> ( + Gas.consume ctxt (Script.deserialized_cost expr) + >>?= fun ctxt -> + parse_data + ctxt + ~legacy:false + ~allow_forged:false + ty + (Micheline.root expr) + >|= function + | Ok (value, ctxt) -> + ok (Some value, ctxt) + | Error _ignored -> + Gas.consume ctxt (Interp_costs.unpack_failed bytes) + >|? fun ctxt -> (None, ctxt) ) + else return (None, ctxt) + +let rec step_bounded : + type b a. + logger -> + stack_depth:int -> + context -> + step_constants -> + (b, a) descr -> + b -> + (a * context) tzresult Lwt.t = + fun logger ~stack_depth ctxt step_constants ({instr; loc; _} as descr) stack -> + let gas = cost_of_instr descr stack in + Gas.consume ctxt gas + >>?= fun ctxt -> + let module Log = (val logger) in + Log.log_entry ctxt descr stack ; + let logged_return : a * context -> (a * context) tzresult Lwt.t = + fun (ret, ctxt) -> + Log.log_exit ctxt descr ret ; + return (ret, ctxt) + in + let non_terminal_recursion ~ctxt ?(stack_depth = stack_depth + 1) descr stack + = + if Compare.Int.(stack_depth >= 10_000) then + fail Michelson_too_many_recursive_calls + else step_bounded logger ~stack_depth ctxt step_constants descr stack + in + match (instr, stack) with + (* stack ops *) + | (Drop, (_, rest)) -> + logged_return (rest, ctxt) + | (Dup, (v, rest)) -> + logged_return ((v, (v, rest)), ctxt) + | (Swap, (vi, (vo, rest))) -> + logged_return ((vo, (vi, rest)), ctxt) + | (Const v, rest) -> + logged_return ((v, rest), ctxt) + (* options *) + | (Cons_some, (v, rest)) -> + logged_return ((Some v, rest), ctxt) + | (Cons_none _, rest) -> + logged_return ((None, rest), ctxt) + | (If_none (bt, _), (None, rest)) -> + step_bounded logger ~stack_depth ctxt step_constants bt rest + | (If_none (_, bf), (Some v, rest)) -> + step_bounded logger ~stack_depth ctxt step_constants bf (v, rest) + (* pairs *) + | (Cons_pair, (a, (b, rest))) -> + logged_return (((a, b), rest), ctxt) + | (Unpair, ((a, b), rest)) -> + logged_return ((a, (b, rest)), ctxt) + | (Car, ((a, _), rest)) -> + logged_return ((a, rest), ctxt) + | (Cdr, ((_, b), rest)) -> + logged_return ((b, rest), ctxt) + (* unions *) + | (Cons_left, (v, rest)) -> + logged_return ((L v, rest), ctxt) + | (Cons_right, (v, rest)) -> + logged_return ((R v, rest), ctxt) + | (If_left (bt, _), (L v, rest)) -> + step_bounded logger ~stack_depth ctxt step_constants bt (v, rest) + | (If_left (_, bf), (R v, rest)) -> + step_bounded logger ~stack_depth ctxt step_constants bf (v, rest) + (* lists *) + | (Cons_list, (hd, (tl, rest))) -> + logged_return ((list_cons hd tl, rest), ctxt) + | (Nil, rest) -> + logged_return ((list_empty, rest), ctxt) + | (If_cons (_, bf), ({elements = []; _}, rest)) -> + step_bounded logger ~stack_depth ctxt step_constants bf rest + | (If_cons (bt, _), ({elements = hd :: tl; length}, rest)) -> + let tl = {elements = tl; length = length - 1} in + step_bounded logger ~stack_depth ctxt step_constants bt (hd, (tl, rest)) + | (List_map body, (list, rest)) -> + let rec loop rest ctxt l acc = + match l with + | [] -> + let result = {elements = List.rev acc; length = list.length} in + return ((result, rest), ctxt) + | hd :: tl -> + non_terminal_recursion ~ctxt body (hd, rest) + >>=? fun ((hd, rest), ctxt) -> loop rest ctxt tl (hd :: acc) + in + loop rest ctxt list.elements [] + >>=? fun (res, ctxt) -> logged_return (res, ctxt) + | (List_size, (list, rest)) -> + logged_return ((Script_int.(abs (of_int list.length)), rest), ctxt) + | (List_iter body, (l, init)) -> + let rec loop ctxt l stack = + match l with + | [] -> + return (stack, ctxt) + | hd :: tl -> + non_terminal_recursion ~ctxt body (hd, stack) + >>=? fun (stack, ctxt) -> loop ctxt tl stack + in + loop ctxt l.elements init + >>=? fun (res, ctxt) -> logged_return (res, ctxt) + (* sets *) + | (Empty_set t, rest) -> + logged_return ((empty_set t, rest), ctxt) + | (Set_iter body, (set, init)) -> + let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in + let rec loop ctxt l stack = + match l with + | [] -> + return (stack, ctxt) + | hd :: tl -> + non_terminal_recursion ~ctxt body (hd, stack) + >>=? fun (stack, ctxt) -> loop ctxt tl stack + in + loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt) + | (Set_mem, (v, (set, rest))) -> + logged_return ((set_mem v set, rest), ctxt) + | (Set_update, (v, (presence, (set, rest)))) -> + logged_return ((set_update v presence set, rest), ctxt) + | (Set_size, (set, rest)) -> + logged_return ((set_size set, rest), ctxt) + (* maps *) + | (Empty_map (t, _), rest) -> + logged_return ((empty_map t, rest), ctxt) + | (Map_map body, (map, rest)) -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop rest ctxt l acc = + match l with + | [] -> + return ((acc, rest), ctxt) + | ((k, _) as hd) :: tl -> + non_terminal_recursion ~ctxt body (hd, rest) + >>=? fun ((hd, rest), ctxt) -> + loop rest ctxt tl (map_update k (Some hd) acc) + in + loop rest ctxt l (empty_map (map_key_ty map)) + >>=? fun (res, ctxt) -> logged_return (res, ctxt) + | (Map_iter body, (map, init)) -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop ctxt l stack = + match l with + | [] -> + return (stack, ctxt) + | hd :: tl -> + non_terminal_recursion ~ctxt body (hd, stack) + >>=? fun (stack, ctxt) -> loop ctxt tl stack + in + loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt) + | (Map_mem, (v, (map, rest))) -> + logged_return ((map_mem v map, rest), ctxt) + | (Map_get, (v, (map, rest))) -> + logged_return ((map_get v map, rest), ctxt) + | (Map_update, (k, (v, (map, rest)))) -> + logged_return ((map_update k v map, rest), ctxt) + | (Map_get_and_update, (k, (v, (map, rest)))) -> + let map' = map_update k v map in + let v' = map_get k map in + logged_return ((v', (map', rest)), ctxt) + | (Map_size, (map, rest)) -> + logged_return ((map_size map, rest), ctxt) + (* Big map operations *) + | (Empty_big_map (tk, tv), rest) -> + logged_return ((Script_ir_translator.empty_big_map tk tv, rest), ctxt) + | (Big_map_mem, (key, (map, rest))) -> + Script_ir_translator.big_map_mem ctxt key map + >>=? fun (res, ctxt) -> logged_return ((res, rest), ctxt) + | (Big_map_get, (key, (map, rest))) -> + Script_ir_translator.big_map_get ctxt key map + >>=? fun (res, ctxt) -> logged_return ((res, rest), ctxt) + | (Big_map_update, (key, (maybe_value, (map, rest)))) -> + let big_map = Script_ir_translator.big_map_update key maybe_value map in + logged_return ((big_map, rest), ctxt) + | (Big_map_get_and_update, (k, (v, (map, rest)))) -> + let map' = Script_ir_translator.big_map_update k v map in + Script_ir_translator.big_map_get ctxt k map + >>=? fun (v', ctxt) -> logged_return ((v', (map', rest)), ctxt) + (* timestamp operations *) + | (Add_seconds_to_timestamp, (n, (t, rest))) -> + let result = Script_timestamp.add_delta t n in + logged_return ((result, rest), ctxt) + | (Add_timestamp_to_seconds, (t, (n, rest))) -> + let result = Script_timestamp.add_delta t n in + logged_return ((result, rest), ctxt) + | (Sub_timestamp_seconds, (t, (s, rest))) -> + let result = Script_timestamp.sub_delta t s in + logged_return ((result, rest), ctxt) + | (Diff_timestamps, (t1, (t2, rest))) -> + let result = Script_timestamp.diff t1 t2 in + logged_return ((result, rest), ctxt) + (* string operations *) + | (Concat_string_pair, (x, (y, rest))) -> + let s = String.concat "" [x; y] in + logged_return ((s, rest), ctxt) + | (Concat_string, (ss, rest)) -> + (* The cost for this fold_left has been paid upfront *) + let total_length = + List.fold_left + (fun acc s -> Z.add acc (Z.of_int (String.length s))) + Z.zero + ss.elements + in + Gas.consume ctxt (Interp_costs.concat_string total_length) + >>?= fun ctxt -> + let s = String.concat "" ss.elements in + logged_return ((s, rest), ctxt) + | (Slice_string, (offset, (length, (s, rest)))) -> + let s_length = Z.of_int (String.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + logged_return + ( (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), + ctxt ) + else logged_return ((None, rest), ctxt) + | (String_size, (s, rest)) -> + logged_return ((Script_int.(abs (of_int (String.length s))), rest), ctxt) + (* bytes operations *) + | (Concat_bytes_pair, (x, (y, rest))) -> + let s = Bytes.cat x y in + logged_return ((s, rest), ctxt) + | (Concat_bytes, (ss, rest)) -> + (* The cost for this fold_left has been paid upfront *) + let total_length = + List.fold_left + (fun acc s -> Z.add acc (Z.of_int (Bytes.length s))) + Z.zero + ss.elements + in + Gas.consume ctxt (Interp_costs.concat_string total_length) + >>?= fun ctxt -> + let s = Bytes.concat Bytes.empty ss.elements in + logged_return ((s, rest), ctxt) + | (Slice_bytes, (offset, (length, (s, rest)))) -> + let s_length = Z.of_int (Bytes.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + logged_return + ((Some (Bytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + else logged_return ((None, rest), ctxt) + | (Bytes_size, (s, rest)) -> + logged_return ((Script_int.(abs (of_int (Bytes.length s))), rest), ctxt) + (* currency operations *) + | (Add_tez, (x, (y, rest))) -> + Tez.(x +? y) >>?= fun res -> logged_return ((res, rest), ctxt) + | (Sub_tez, (x, (y, rest))) -> + Tez.(x -? y) >>?= fun res -> logged_return ((res, rest), ctxt) + | (Mul_teznat, (x, (y, rest))) -> ( + match Script_int.to_int64 y with + | None -> + Log.get_log () >>=? fun log -> fail (Overflow (loc, log)) + | Some y -> + Tez.(x *? y) >>?= fun res -> logged_return ((res, rest), ctxt) ) + | (Mul_nattez, (y, (x, rest))) -> ( + match Script_int.to_int64 y with + | None -> + Log.get_log () >>=? fun log -> fail (Overflow (loc, log)) + | Some y -> + Tez.(x *? y) >>?= fun res -> logged_return ((res, rest), ctxt) ) + (* boolean operations *) + | (Or, (x, (y, rest))) -> + logged_return ((x || y, rest), ctxt) + | (And, (x, (y, rest))) -> + logged_return ((x && y, rest), ctxt) + | (Xor, (x, (y, rest))) -> + logged_return ((Compare.Bool.(x <> y), rest), ctxt) + | (Not, (x, rest)) -> + logged_return ((not x, rest), ctxt) + (* integer operations *) + | (Is_nat, (x, rest)) -> + logged_return ((Script_int.is_nat x, rest), ctxt) + | (Abs_int, (x, rest)) -> + logged_return ((Script_int.abs x, rest), ctxt) + | (Int_nat, (x, rest)) -> + logged_return ((Script_int.int x, rest), ctxt) + | (Neg_int, (x, rest)) -> + logged_return ((Script_int.neg x, rest), ctxt) + | (Neg_nat, (x, rest)) -> + logged_return ((Script_int.neg x, rest), ctxt) + | (Add_intint, (x, (y, rest))) -> + logged_return ((Script_int.add x y, rest), ctxt) + | (Add_intnat, (x, (y, rest))) -> + logged_return ((Script_int.add x y, rest), ctxt) + | (Add_natint, (x, (y, rest))) -> + logged_return ((Script_int.add x y, rest), ctxt) + | (Add_natnat, (x, (y, rest))) -> + logged_return ((Script_int.add_n x y, rest), ctxt) + | (Sub_int, (x, (y, rest))) -> + logged_return ((Script_int.sub x y, rest), ctxt) + | (Mul_intint, (x, (y, rest))) -> + logged_return ((Script_int.mul x y, rest), ctxt) + | (Mul_intnat, (x, (y, rest))) -> + logged_return ((Script_int.mul x y, rest), ctxt) + | (Mul_natint, (x, (y, rest))) -> + logged_return ((Script_int.mul x y, rest), ctxt) + | (Mul_natnat, (x, (y, rest))) -> + logged_return ((Script_int.mul_n x y, rest), ctxt) + | (Ediv_teznat, (x, (y, rest))) -> + let x = Script_int.of_int64 (Tez.to_mutez x) in + let result = + match Script_int.ediv x y with + | None -> + None + | Some (q, r) -> ( + match (Script_int.to_int64 q, Script_int.to_int64 r) with + | (Some q, Some r) -> ( + match (Tez.of_mutez q, Tez.of_mutez r) with + | (Some q, Some r) -> + Some (q, r) + (* Cannot overflow *) + | _ -> + assert false ) + (* Cannot overflow *) + | _ -> + assert false ) + in + logged_return ((result, rest), ctxt) + | (Ediv_tez, (x, (y, rest))) -> + let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in + let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in + let result = + match Script_int.ediv_n x y with + | None -> + None + | Some (q, r) -> ( + match Script_int.to_int64 r with + | None -> + assert false (* Cannot overflow *) + | Some r -> ( + match Tez.of_mutez r with + | None -> + assert false (* Cannot overflow *) + | Some r -> + Some (q, r) ) ) + in + logged_return ((result, rest), ctxt) + | (Ediv_intint, (x, (y, rest))) -> + logged_return ((Script_int.ediv x y, rest), ctxt) + | (Ediv_intnat, (x, (y, rest))) -> + logged_return ((Script_int.ediv x y, rest), ctxt) + | (Ediv_natint, (x, (y, rest))) -> + logged_return ((Script_int.ediv x y, rest), ctxt) + | (Ediv_natnat, (x, (y, rest))) -> + logged_return ((Script_int.ediv_n x y, rest), ctxt) + | (Lsl_nat, (x, (y, rest))) -> ( + match Script_int.shift_left_n x y with + | None -> + Log.get_log () >>=? fun log -> fail (Overflow (loc, log)) + | Some x -> + logged_return ((x, rest), ctxt) ) + | (Lsr_nat, (x, (y, rest))) -> ( + match Script_int.shift_right_n x y with + | None -> + Log.get_log () >>=? fun log -> fail (Overflow (loc, log)) + | Some r -> + logged_return ((r, rest), ctxt) ) + | (Or_nat, (x, (y, rest))) -> + logged_return ((Script_int.logor x y, rest), ctxt) + | (And_nat, (x, (y, rest))) -> + logged_return ((Script_int.logand x y, rest), ctxt) + | (And_int_nat, (x, (y, rest))) -> + logged_return ((Script_int.logand x y, rest), ctxt) + | (Xor_nat, (x, (y, rest))) -> + logged_return ((Script_int.logxor x y, rest), ctxt) + | (Not_int, (x, rest)) -> + logged_return ((Script_int.lognot x, rest), ctxt) + | (Not_nat, (x, rest)) -> + logged_return ((Script_int.lognot x, rest), ctxt) + (* control *) + | (Seq (hd, tl), stack) -> + non_terminal_recursion ~ctxt hd stack + >>=? fun (trans, ctxt) -> + step_bounded logger ~stack_depth ctxt step_constants tl trans + | (If (bt, _), (true, rest)) -> + step_bounded logger ~stack_depth ctxt step_constants bt rest + | (If (_, bf), (false, rest)) -> + step_bounded logger ~stack_depth ctxt step_constants bf rest + | (Loop body, (true, rest)) -> + non_terminal_recursion ~ctxt body rest + >>=? fun (trans, ctxt) -> + step_bounded logger ~stack_depth ctxt step_constants descr trans + | (Loop _, (false, rest)) -> + logged_return (rest, ctxt) + | (Loop_left body, (L v, rest)) -> + non_terminal_recursion ~ctxt body (v, rest) + >>=? fun (trans, ctxt) -> + step_bounded logger ~stack_depth ctxt step_constants descr trans + | (Loop_left _, (R v, rest)) -> + logged_return ((v, rest), ctxt) + | (Dip b, (ign, rest)) -> + non_terminal_recursion ~ctxt b rest + >>=? fun (res, ctxt) -> logged_return ((ign, res), ctxt) + | (Exec, (arg, (Lam (code, _), rest))) -> + Log.log_interp ctxt code (arg, ()) ; + non_terminal_recursion ~ctxt code (arg, ()) + >>=? fun ((res, ()), ctxt) -> logged_return ((res, rest), ctxt) + | (Apply capture_ty, (capture, (lam, rest))) -> ( + let (Lam (descr, expr)) = lam in + let (Item_t (full_arg_ty, _, _)) = descr.bef in + unparse_data ctxt Optimized capture_ty capture + >>=? fun (const_expr, ctxt) -> + unparse_ty ctxt capture_ty + >>?= fun (ty_expr, ctxt) -> + match full_arg_ty with + | Pair_t ((capture_ty, _, _), (arg_ty, _, _), _) -> + let arg_stack_ty = Item_t (arg_ty, Empty_t, None) in + let const_descr = + ( { + loc = descr.loc; + bef = arg_stack_ty; + aft = Item_t (capture_ty, arg_stack_ty, None); + instr = Const capture; + } + : (_, _) descr ) + in + let pair_descr = + ( { + loc = descr.loc; + bef = Item_t (capture_ty, arg_stack_ty, None); + aft = Item_t (full_arg_ty, Empty_t, None); + instr = Cons_pair; + } + : (_, _) descr ) + in + let seq_descr = + ( { + loc = descr.loc; + bef = arg_stack_ty; + aft = Item_t (full_arg_ty, Empty_t, None); + instr = Seq (const_descr, pair_descr); + } + : (_, _) descr ) + in + let full_descr = + ( { + loc = descr.loc; + bef = arg_stack_ty; + aft = descr.aft; + instr = Seq (seq_descr, descr); + } + : (_, _) descr ) + in + let full_expr = + Micheline.Seq + ( 0, + [ Prim (0, I_PUSH, [ty_expr; const_expr], []); + Prim (0, I_PAIR, [], []); + expr ] ) + in + let lam' = Lam (full_descr, full_expr) in + logged_return ((lam', rest), ctxt) + | _ -> + assert false ) + | (Lambda lam, rest) -> + logged_return ((lam, rest), ctxt) + | (Failwith tv, (v, _)) -> + trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) + >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + Log.get_log () >>=? fun log -> fail (Reject (loc, v, log)) + | (Nop, stack) -> + logged_return (stack, ctxt) + (* comparison *) + | (Compare ty, (a, (b, rest))) -> + logged_return + ( ( Script_int.of_int @@ Script_ir_translator.compare_comparable ty a b, + rest ), + ctxt ) + (* comparators *) + | (Eq, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres = 0) in + logged_return ((cmpres, rest), ctxt) + | (Neq, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <> 0) in + logged_return ((cmpres, rest), ctxt) + | (Lt, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres < 0) in + logged_return ((cmpres, rest), ctxt) + | (Le, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <= 0) in + logged_return ((cmpres, rest), ctxt) + | (Gt, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres > 0) in + logged_return ((cmpres, rest), ctxt) + | (Ge, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres >= 0) in + logged_return ((cmpres, rest), ctxt) + (* packing *) + | (Pack t, (value, rest)) -> + Script_ir_translator.pack_data ctxt t value + >>=? fun (bytes, ctxt) -> logged_return ((bytes, rest), ctxt) + | (Unpack ty, (bytes, rest)) -> + unpack ctxt ~ty ~bytes + >>=? fun (opt, ctxt) -> logged_return ((opt, rest), ctxt) + (* protocol *) + | (Address, ((_, address), rest)) -> + logged_return ((address, rest), ctxt) + | (Contract (t, entrypoint), (contract, rest)) -> ( + match (contract, entrypoint) with + | ((contract, "default"), entrypoint) | ((contract, entrypoint), "default") + -> + Script_ir_translator.parse_contract_for_script + ~legacy:false + ctxt + loc + t + contract + ~entrypoint + >>=? fun (ctxt, maybe_contract) -> + logged_return ((maybe_contract, rest), ctxt) + | _ -> + logged_return ((None, rest), ctxt) ) + | (Transfer_tokens, (p, (amount, ((tp, (destination, entrypoint)), rest)))) + -> + collect_lazy_storage ctxt tp p + >>?= fun (to_duplicate, ctxt) -> + let to_update = no_lazy_storage_id in + extract_lazy_storage_diff + ctxt + Optimized + tp + p + ~to_duplicate + ~to_update + ~temporary:true + >>=? fun (p, lazy_storage_diff, ctxt) -> + unparse_data ctxt Optimized tp p + >>=? fun (p, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost p) + >>?= fun ctxt -> + let operation = + Transaction + { + amount; + destination; + entrypoint; + parameters = Script.lazy_expr (Micheline.strip_locations p); + } + in + fresh_internal_nonce ctxt + >>?= fun (ctxt, nonce) -> + logged_return + ( ( ( Internal_operation + {source = step_constants.self; operation; nonce}, + lazy_storage_diff ), + rest ), + ctxt ) + | (Implicit_account, (key, rest)) -> + let contract = Contract.implicit_contract key in + logged_return (((Unit_t None, (contract, "default")), rest), ctxt) + | ( Create_contract (storage_type, param_type, Lam (_, code), root_name), + (* Removed the instruction's arguments manager, spendable and delegatable *) + (delegate, (credit, (init, rest))) ) -> + unparse_ty ctxt param_type + >>?= fun (unparsed_param_type, ctxt) -> + let unparsed_param_type = + Script_ir_translator.add_field_annot root_name None unparsed_param_type + in + unparse_ty ctxt storage_type + >>?= fun (unparsed_storage_type, ctxt) -> + let code = + Micheline.strip_locations + (Seq + ( 0, + [ Prim (0, K_parameter, [unparsed_param_type], []); + Prim (0, K_storage, [unparsed_storage_type], []); + Prim (0, K_code, [code], []) ] )) + in + collect_lazy_storage ctxt storage_type init + >>?= fun (to_duplicate, ctxt) -> + let to_update = no_lazy_storage_id in + extract_lazy_storage_diff + ctxt + Optimized + storage_type + init + ~to_duplicate + ~to_update + ~temporary:true + >>=? fun (init, lazy_storage_diff, ctxt) -> + unparse_data ctxt Optimized storage_type init + >>=? fun (storage, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost storage) + >>?= fun ctxt -> + let storage = Micheline.strip_locations storage in + Contract.fresh_contract_from_current_nonce ctxt + >>?= fun (ctxt, contract) -> + let operation = + Origination + { + credit; + delegate; + preorigination = Some contract; + script = + { + code = Script.lazy_expr code; + storage = Script.lazy_expr storage; + }; + } + in + fresh_internal_nonce ctxt + >>?= fun (ctxt, nonce) -> + logged_return + ( ( ( Internal_operation + {source = step_constants.self; operation; nonce}, + lazy_storage_diff ), + ((contract, "default"), rest) ), + ctxt ) + | (Set_delegate, (delegate, rest)) -> + let operation = Delegation delegate in + fresh_internal_nonce ctxt + >>?= fun (ctxt, nonce) -> + logged_return + ( ( ( Internal_operation + {source = step_constants.self; operation; nonce}, + None ), + rest ), + ctxt ) + | (Balance, rest) -> + Contract.get_balance_carbonated ctxt step_constants.self + >>=? fun (ctxt, balance) -> logged_return ((balance, rest), ctxt) + | (Level, rest) -> + let level = + (Level.current ctxt).level |> Raw_level.to_int32 |> Script_int.of_int32 + |> Script_int.abs + in + logged_return ((level, rest), ctxt) + | (Now, rest) -> + let now = Script_timestamp.now ctxt in + logged_return ((now, rest), ctxt) + | (Check_signature, (key, (signature, (message, rest)))) -> + let res = Signature.check key signature message in + logged_return ((res, rest), ctxt) + | (Hash_key, (key, rest)) -> + logged_return ((Signature.Public_key.hash key, rest), ctxt) + | (Blake2b, (bytes, rest)) -> + let hash = Raw_hashes.blake2b bytes in + logged_return ((hash, rest), ctxt) + | (Sha256, (bytes, rest)) -> + let hash = Raw_hashes.sha256 bytes in + logged_return ((hash, rest), ctxt) + | (Sha512, (bytes, rest)) -> + let hash = Raw_hashes.sha512 bytes in + logged_return ((hash, rest), ctxt) + | (Source, rest) -> + logged_return (((step_constants.payer, "default"), rest), ctxt) + | (Sender, rest) -> + logged_return (((step_constants.source, "default"), rest), ctxt) + | (Self (t, entrypoint), rest) -> + logged_return (((t, (step_constants.self, entrypoint)), rest), ctxt) + | (Self_address, rest) -> + logged_return (((step_constants.self, "default"), rest), ctxt) + | (Amount, rest) -> + logged_return ((step_constants.amount, rest), ctxt) + | (Dig (_n, n'), stack) -> + interp_stack_prefix_preserving_operation + (fun (v, rest) -> return (rest, v)) + n' + stack + >>=? fun (aft, x) -> logged_return ((x, aft), ctxt) + | (Dug (_n, n'), (v, rest)) -> + interp_stack_prefix_preserving_operation + (fun stk -> return ((v, stk), ())) + n' + rest + >>=? fun (aft, ()) -> logged_return (aft, ctxt) + | (Dipn (n, n', b), stack) -> + interp_stack_prefix_preserving_operation + (fun stk -> + non_terminal_recursion + ~ctxt + b + stk + (* This is a cheap upper bound of the number recursive calls to + `interp_stack_prefix_preserving_operation`, which does + ((n / 16) + log2 (n % 16)) iterations *) + ~stack_depth:(stack_depth + 4 + (n / 16))) + n' + stack + >>=? fun (aft, ctxt') -> logged_return (aft, ctxt') + | (Dropn (_n, n'), stack) -> + interp_stack_prefix_preserving_operation + (fun stk -> return (stk, stk)) + n' + stack + >>=? fun (_, rest) -> logged_return (rest, ctxt) + | (Sapling_empty_state {memo_size}, stack) -> + logged_return ((Sapling.empty_state ~memo_size (), stack), ctxt) + | (Sapling_verify_update, (transaction, (state, rest))) -> ( + let address = Contract.to_b58check step_constants.self in + let chain_id = Chain_id.to_b58check step_constants.chain_id in + let anti_replay = address ^ chain_id in + Sapling.verify_update ctxt state transaction anti_replay + >>=? fun (ctxt, balance_state_opt) -> + match balance_state_opt with + | Some (balance, state) -> + logged_return + ((Some (Script_int.of_int64 balance, state), rest), ctxt) + | None -> + logged_return ((None, rest), ctxt) ) + | (ChainId, rest) -> + logged_return ((step_constants.chain_id, rest), ctxt) + | (Never, (_, _)) -> + . + | (Voting_power, (key_hash, rest)) -> + Vote.get_voting_power ctxt key_hash + >>=? fun (ctxt, rolls) -> + logged_return ((Script_int.(abs (of_int32 rolls)), rest), ctxt) + | (Total_voting_power, rest) -> + Vote.get_total_voting_power ctxt + >>=? fun (ctxt, rolls) -> + logged_return ((Script_int.(abs (of_int32 rolls)), rest), ctxt) + | (Keccak, (bytes, rest)) -> + let hash = Raw_hashes.keccak256 bytes in + logged_return ((hash, rest), ctxt) + | (Sha3, (bytes, rest)) -> + let hash = Raw_hashes.sha3_256 bytes in + logged_return ((hash, rest), ctxt) + | (Add_bls12_381_g1, (x, (y, rest))) -> + logged_return ((Bls12_381.G1.add x y, rest), ctxt) + | (Add_bls12_381_g2, (x, (y, rest))) -> + logged_return ((Bls12_381.G2.add x y, rest), ctxt) + | (Add_bls12_381_fr, (x, (y, rest))) -> + logged_return ((Bls12_381.Fr.add x y, rest), ctxt) + | (Mul_bls12_381_g1, (x, (y, rest))) -> + logged_return ((Bls12_381.G1.mul x y, rest), ctxt) + | (Mul_bls12_381_g2, (x, (y, rest))) -> + logged_return ((Bls12_381.G2.mul x y, rest), ctxt) + | (Mul_bls12_381_fr, (x, (y, rest))) -> + logged_return ((Bls12_381.Fr.mul x y, rest), ctxt) + | (Mul_bls12_381_fr_z, (x, (y, rest))) -> + let x = Bls12_381.Fr.of_z (Script_int.to_zint x) in + let res = (Bls12_381.Fr.mul x y, rest) in + logged_return (res, ctxt) + | (Mul_bls12_381_z_fr, (y, (x, rest))) -> + let x = Bls12_381.Fr.of_z (Script_int.to_zint x) in + let res = (Bls12_381.Fr.mul x y, rest) in + logged_return (res, ctxt) + | (Int_bls12_381_fr, (x, rest)) -> + logged_return ((Script_int.of_zint (Bls12_381.Fr.to_z x), rest), ctxt) + | (Neg_bls12_381_g1, (x, rest)) -> + logged_return ((Bls12_381.G1.negate x, rest), ctxt) + | (Neg_bls12_381_g2, (x, rest)) -> + logged_return ((Bls12_381.G2.negate x, rest), ctxt) + | (Neg_bls12_381_fr, (x, rest)) -> + logged_return ((Bls12_381.Fr.negate x, rest), ctxt) + | (Pairing_check_bls12_381, (pairs, rest)) -> + let check = + match pairs.elements with + | [] -> + true + | pairs -> + Bls12_381.( + miller_loop pairs |> final_exponentiation_opt + |> Option.map Gt.(eq one)) + |> Option.value ~default:false + in + logged_return ((check, rest), ctxt) + | (Comb (_, witness), stack) -> + let rec aux : + type before after. + (before, after) comb_gadt_witness -> before -> after = + fun witness stack -> + match (witness, stack) with + | (Comb_one, stack) -> + stack + | (Comb_succ witness', (a, tl)) -> + let (b, tl') = aux witness' tl in + ((a, b), tl') + in + logged_return (aux witness stack, ctxt) + | (Uncomb (_, witness), stack) -> + let rec aux : + type before after. + (before, after) uncomb_gadt_witness -> before -> after = + fun witness stack -> + match (witness, stack) with + | (Uncomb_one, stack) -> + stack + | (Uncomb_succ witness', ((a, b), tl)) -> + (a, aux witness' (b, tl)) + in + logged_return (aux witness stack, ctxt) + | (Comb_get (_, witness), (comb, stack)) -> + let rec aux : + type before after. + (before, after) comb_get_gadt_witness -> before -> after = + fun witness comb -> + match (witness, comb) with + | (Comb_get_zero, v) -> + v + | (Comb_get_one, (a, _)) -> + a + | (Comb_get_plus_two witness', (_, b)) -> + aux witness' b + in + logged_return ((aux witness comb, stack), ctxt) + | (Comb_set (_, witness), (value, (comb, stack))) -> + let rec aux : + type value before after. + (value, before, after) comb_set_gadt_witness -> + value -> + before -> + after = + fun witness value item -> + match (witness, item) with + | (Comb_set_zero, _) -> + value + | (Comb_set_one, (_hd, tl)) -> + (value, tl) + | (Comb_set_plus_two witness', (hd, tl)) -> + (hd, aux witness' value tl) + in + logged_return ((aux witness value comb, stack), ctxt) + | (Dup_n (_, witness), stack) -> + let rec aux : + type before after. + (before, after) dup_n_gadt_witness -> before -> after = + fun witness stack -> + match (witness, stack) with + | (Dup_n_zero, (a, _)) -> + a + | (Dup_n_succ witness', (_, tl)) -> + aux witness' tl + in + logged_return ((aux witness stack, stack), ctxt) + (* Tickets *) + | (Ticket, (contents, (amount, rest))) -> + let ticketer = (step_constants.self, "default") in + logged_return (({ticketer; contents; amount}, rest), ctxt) + | (Read_ticket, (({ticketer; contents; amount}, _) as stack)) -> + logged_return (((ticketer, (contents, amount)), stack), ctxt) + | (Split_ticket, (ticket, ((amount_a, amount_b), rest))) -> + let result = + if + Compare.Int.( + Script_int.(compare (add_n amount_a amount_b) ticket.amount) = 0) + then + Some + ({ticket with amount = amount_a}, {ticket with amount = amount_b}) + else None + in + logged_return ((result, rest), ctxt) + | (Join_tickets contents_ty, ((ticket_a, ticket_b), rest)) -> + let result = + if + Compare.Int.( + compare_address ticket_a.ticketer ticket_b.ticketer = 0 + && compare_comparable + contents_ty + ticket_a.contents + ticket_b.contents + = 0) + then + Some + { + ticketer = ticket_a.ticketer; + contents = ticket_a.contents; + amount = Script_int.add_n ticket_a.amount ticket_b.amount; + } + else None + in + logged_return ((result, rest), ctxt) + +let step : + type b a. + logger -> + context -> + step_constants -> + (b, a) descr -> + b -> + (a * context) tzresult Lwt.t = + step_bounded ~stack_depth:0 + +let interp : + type p r. + logger -> + context -> + step_constants -> + (p, r) lambda -> + p -> + (r * context) tzresult Lwt.t = + fun logger ctxt step_constants (Lam (code, _)) arg -> + let stack = (arg, ()) in + let module Log = (val logger) in + Log.log_interp ctxt code stack ; + step logger ctxt step_constants code stack + >|=? fun ((ret, ()), ctxt) -> (ret, ctxt) + +(* ---- contract handling ---------------------------------------------------*) +let execute logger ctxt mode step_constants ~entrypoint ~internal + unparsed_script arg : + ( Script.expr + * packed_internal_operation list + * context + * Lazy_storage.diffs option ) + tzresult + Lwt.t = + parse_script ctxt unparsed_script ~legacy:true ~allow_forged_in_storage:true + >>=? fun (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt) -> + record_trace + (Bad_contract_parameter step_constants.self) + (find_entrypoint arg_type ~root_name entrypoint) + >>?= fun (box, _) -> + trace + (Bad_contract_parameter step_constants.self) + (parse_data ctxt ~legacy:false ~allow_forged:internal arg_type (box arg)) + >>=? fun (arg, ctxt) -> + Script.force_decode_in_context ctxt unparsed_script.code + >>?= fun (script_code, ctxt) -> + Script_ir_translator.collect_lazy_storage ctxt arg_type arg + >>?= fun (to_duplicate, ctxt) -> + Script_ir_translator.collect_lazy_storage ctxt storage_type storage + >>?= fun (to_update, ctxt) -> + trace + (Runtime_contract_error (step_constants.self, script_code)) + (interp logger ctxt step_constants code (arg, storage)) + >>=? fun ((ops, storage), ctxt) -> + Script_ir_translator.extract_lazy_storage_diff + ctxt + mode + ~temporary:false + ~to_duplicate + ~to_update + storage_type + storage + >>=? fun (storage, lazy_storage_diff, ctxt) -> + trace + Cannot_serialize_storage + ( unparse_data ctxt mode storage_type storage + >>=? fun (storage, ctxt) -> + Lwt.return + ( Gas.consume ctxt (Script.strip_locations_cost storage) + >>? fun ctxt -> ok (Micheline.strip_locations storage, ctxt) ) ) + >|=? fun (storage, ctxt) -> + let (ops, op_diffs) = List.split ops.elements in + let lazy_storage_diff = + match + List.flatten + (List.map (Option.value ~default:[]) (op_diffs @ [lazy_storage_diff])) + with + | [] -> + None + | diff -> + Some diff + in + (storage, ops, ctxt, lazy_storage_diff) + +type execution_result = { + ctxt : context; + storage : Script.expr; + lazy_storage_diff : Lazy_storage.diffs option; + operations : packed_internal_operation list; +} + +let execute ?(logger = (module No_trace : STEP_LOGGER)) ctxt mode + step_constants ~script ~entrypoint ~parameter ~internal = + execute + logger + ctxt + mode + step_constants + ~entrypoint + ~internal + script + (Micheline.root parameter) + >|=? fun (storage, operations, ctxt, lazy_storage_diff) -> + {ctxt; storage; lazy_storage_diff; operations} diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_interpreter.mli b/src/proto_008_PtEdo2Zk/lib_protocol/script_interpreter.mli new file mode 100644 index 0000000000000000000000000000000000000000..9d2f9147da7e837984e5d971f7f898eb0772c6f5 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_interpreter.mli @@ -0,0 +1,106 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +type execution_trace = + (Script.location * Gas.t * (Script.expr * string option) list) list + +type error += + | Reject of Script.location * Script.expr * execution_trace option + +type error += Overflow of Script.location * execution_trace option + +type error += Runtime_contract_error : Contract.t * Script.expr -> error + +type error += Bad_contract_parameter of Contract.t (* `Permanent *) + +type error += Cannot_serialize_failure + +type error += Cannot_serialize_storage + +type error += Michelson_too_many_recursive_calls + +type execution_result = { + ctxt : context; + storage : Script.expr; + lazy_storage_diff : Lazy_storage.diffs option; + operations : packed_internal_operation list; +} + +type step_constants = { + source : Contract.t; + payer : Contract.t; + self : Contract.t; + amount : Tez.t; + chain_id : Chain_id.t; +} + +(** [STEP_LOGGER] is the module type of logging + modules as passed to the Michelson interpreter. + Note that logging must be performed by side-effects + on an underlying log structure. *) +module type STEP_LOGGER = sig + (** [log_interp] is called at each call of the internal + function [interp]. [interp] is called when starting + the interpretation of a script and subsequently + at each [Exec] instruction. *) + val log_interp : + context -> ('bef, 'aft) Script_typed_ir.descr -> 'bef -> unit + + (** [log_entry] is called {i before} executing + each instruction but {i after} gas for + this instruction has been successfully consumed. *) + val log_entry : context -> ('bef, 'aft) Script_typed_ir.descr -> 'bef -> unit + + (** [log_exit] is called {i after} executing each + instruction. *) + val log_exit : context -> ('bef, 'aft) Script_typed_ir.descr -> 'aft -> unit + + (** [get_log] allows to obtain an execution trace, if + any was produced. *) + val get_log : unit -> execution_trace option tzresult Lwt.t +end + +type logger = (module STEP_LOGGER) + +val step : + logger -> + context -> + step_constants -> + ('bef, 'aft) Script_typed_ir.descr -> + 'bef -> + ('aft * context) tzresult Lwt.t + +val execute : + ?logger:logger -> + Alpha_context.t -> + Script_ir_translator.unparsing_mode -> + step_constants -> + script:Script.t -> + entrypoint:string -> + parameter:Script.expr -> + internal:bool -> + execution_result tzresult Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_annot.ml b/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_annot.ml new file mode 100644 index 0000000000000000000000000000000000000000..0b1080ecad2c57b7e07458d5304ec95484559a45 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_annot.ml @@ -0,0 +1,608 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Micheline +open Script_tc_errors +open Script_typed_ir + +let default_now_annot = Some (Var_annot "now") + +let default_amount_annot = Some (Var_annot "amount") + +let default_balance_annot = Some (Var_annot "balance") + +let default_level_annot = Some (Var_annot "level") + +let default_steps_annot = Some (Var_annot "steps") + +let default_source_annot = Some (Var_annot "source") + +let default_sender_annot = Some (Var_annot "sender") + +let default_self_annot = Some (Var_annot "self") + +let default_arg_annot = Some (Var_annot "arg") + +let default_param_annot = Some (Var_annot "parameter") + +let default_storage_annot = Some (Var_annot "storage") + +let default_car_annot = Some (Field_annot "car") + +let default_cdr_annot = Some (Field_annot "cdr") + +let default_contract_annot = Some (Field_annot "contract") + +let default_addr_annot = Some (Field_annot "address") + +let default_manager_annot = Some (Field_annot "manager") + +let default_pack_annot = Some (Field_annot "packed") + +let default_unpack_annot = Some (Field_annot "unpacked") + +let default_slice_annot = Some (Field_annot "slice") + +let default_elt_annot = Some (Field_annot "elt") + +let default_key_annot = Some (Field_annot "key") + +let default_hd_annot = Some (Field_annot "hd") + +let default_tl_annot = Some (Field_annot "tl") + +let default_some_annot = Some (Field_annot "some") + +let default_left_annot = Some (Field_annot "left") + +let default_right_annot = Some (Field_annot "right") + +let default_binding_annot = Some (Field_annot "bnd") + +let default_sapling_state_annot = Some (Var_annot "sapling") + +let default_sapling_balance_annot = Some (Var_annot "sapling_balance") + +let unparse_type_annot : type_annot option -> string list = function + | None -> + [] + | Some (Type_annot a) -> + [":" ^ a] + +let unparse_var_annot : var_annot option -> string list = function + | None -> + [] + | Some (Var_annot a) -> + ["@" ^ a] + +let unparse_field_annot : field_annot option -> string list = function + | None -> + [] + | Some (Field_annot a) -> + ["%" ^ a] + +let field_to_var_annot : field_annot option -> var_annot option = function + | None -> + None + | Some (Field_annot s) -> + Some (Var_annot s) + +let type_to_var_annot : type_annot option -> var_annot option = function + | None -> + None + | Some (Type_annot s) -> + Some (Var_annot s) + +let var_to_field_annot : var_annot option -> field_annot option = function + | None -> + None + | Some (Var_annot s) -> + Some (Field_annot s) + +let default_annot ~default = function None -> default | annot -> annot + +let gen_access_annot : + var_annot option -> + ?default:field_annot option -> + field_annot option -> + var_annot option = + fun value_annot ?(default = None) field_annot -> + match (value_annot, field_annot, default) with + | (None, None, _) | (Some _, None, None) | (None, Some (Field_annot ""), _) + -> + None + | (None, Some (Field_annot f), _) -> + Some (Var_annot f) + | (Some (Var_annot v), (None | Some (Field_annot "")), Some (Field_annot f)) + -> + Some (Var_annot (String.concat "." [v; f])) + | (Some (Var_annot v), Some (Field_annot f), _) -> + Some (Var_annot (String.concat "." [v; f])) + +let merge_type_annot : + legacy:bool -> + type_annot option -> + type_annot option -> + type_annot option tzresult = + fun ~legacy annot1 annot2 -> + match (annot1, annot2) with + | (None, None) | (Some _, None) | (None, Some _) -> + ok_none + | (Some (Type_annot a1), Some (Type_annot a2)) -> + if legacy || String.equal a1 a2 then ok annot1 + else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2)) + +let merge_field_annot : + legacy:bool -> + field_annot option -> + field_annot option -> + field_annot option tzresult = + fun ~legacy annot1 annot2 -> + match (annot1, annot2) with + | (None, None) | (Some _, None) | (None, Some _) -> + ok_none + | (Some (Field_annot a1), Some (Field_annot a2)) -> + if legacy || String.equal a1 a2 then ok annot1 + else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2)) + +let merge_var_annot : var_annot option -> var_annot option -> var_annot option + = + fun annot1 annot2 -> + match (annot1, annot2) with + | (None, None) | (Some _, None) | (None, Some _) -> + None + | (Some (Var_annot a1), Some (Var_annot a2)) -> + if String.equal a1 a2 then annot1 else None + +let error_unexpected_annot loc annot = + match annot with + | [] -> + ok_unit + | _ :: _ -> + error (Unexpected_annotation loc) + +(* Check that the predicate p holds on all s.[k] for k >= i *) +let string_iter p s i = + let len = String.length s in + let rec aux i = + if Compare.Int.(i >= len) then ok_unit + else p s.[i] >>? fun () -> aux (i + 1) + in + aux i + +(* Valid annotation characters as defined by the allowed_annot_char function from lib_micheline/micheline_parser *) +let check_char loc = function + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' | '%' | '@' | '0' .. '9' -> + ok_unit + | _ -> + error (Unexpected_annotation loc) + +(* This constant is defined in lib_micheline/micheline_parser which is not available in the environment. *) +let max_annot_length = 255 + +type annot_opt = + | Field_annot_opt of string option + | Type_annot_opt of string option + | Var_annot_opt of string option + +let parse_annots loc ?(allow_special_var = false) + ?(allow_special_field = false) l = + (* allow empty annotations as wildcards but otherwise only accept + annotations that start with [a-zA-Z_] *) + let sub_or_wildcard ~specials wrap s acc = + let mem_char c cs = List.exists (Char.equal c) cs in + let len = String.length s in + ( if Compare.Int.(len > max_annot_length) then + error (Unexpected_annotation loc) + else ok_unit ) + >>? fun () -> + if Compare.Int.(len = 1) then ok @@ (wrap None :: acc) + else + match s.[1] with + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> + (* check that all characters are valid*) + string_iter (check_char loc) s 2 + >>? fun () -> ok @@ (wrap (Some (String.sub s 1 (len - 1))) :: acc) + | '@' when Compare.Int.(len = 2) && mem_char '@' specials -> + ok @@ (wrap (Some "@") :: acc) + | '%' when mem_char '%' specials -> + if Compare.Int.(len = 2) then ok @@ (wrap (Some "%") :: acc) + else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') then + ok @@ (wrap (Some "%%") :: acc) + else error (Unexpected_annotation loc) + | _ -> + error (Unexpected_annotation loc) + in + List.fold_left + (fun acc s -> + acc + >>? fun acc -> + if Compare.Int.(String.length s = 0) then + error (Unexpected_annotation loc) + else + match s.[0] with + | ':' -> + sub_or_wildcard ~specials:[] (fun a -> Type_annot_opt a) s acc + | '@' -> + sub_or_wildcard + ~specials:(if allow_special_var then ['%'] else []) + (fun a -> Var_annot_opt a) + s + acc + | '%' -> + sub_or_wildcard + ~specials:(if allow_special_field then ['@'] else []) + (fun a -> Field_annot_opt a) + s + acc + | _ -> + error (Unexpected_annotation loc)) + ok_nil + l + >|? List.rev + +let opt_var_of_var_opt = function None -> None | Some a -> Some (Var_annot a) + +let opt_field_of_field_opt = function + | None -> + None + | Some a -> + Some (Field_annot a) + +let opt_type_of_type_opt = function + | None -> + None + | Some a -> + Some (Type_annot a) + +let classify_annot loc l : + (var_annot option list * type_annot option list * field_annot option list) + tzresult = + try + let (_, rv, _, rt, _, rf) = + List.fold_left + (fun (in_v, rv, in_t, rt, in_f, rf) a -> + match (a, in_v, rv, in_t, rt, in_f, rf) with + | (Var_annot_opt a, true, _, _, _, _, _) + | (Var_annot_opt a, false, [], _, _, _, _) -> + (true, opt_var_of_var_opt a :: rv, false, rt, false, rf) + | (Type_annot_opt a, _, _, true, _, _, _) + | (Type_annot_opt a, _, _, false, [], _, _) -> + (false, rv, true, opt_type_of_type_opt a :: rt, false, rf) + | (Field_annot_opt a, _, _, _, _, true, _) + | (Field_annot_opt a, _, _, _, _, false, []) -> + (false, rv, false, rt, true, opt_field_of_field_opt a :: rf) + | _ -> + raise Exit) + (false, [], false, [], false, []) + l + in + ok (List.rev rv, List.rev rt, List.rev rf) + with Exit -> error (Ungrouped_annotations loc) + +let get_one_annot loc = function + | [] -> + ok_none + | [a] -> + ok a + | _ -> + error (Unexpected_annotation loc) + +let get_two_annot loc = function + | [] -> + ok (None, None) + | [a] -> + ok (a, None) + | [a; b] -> + ok (a, b) + | _ -> + error (Unexpected_annotation loc) + +let parse_type_annot : int -> string list -> type_annot option tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars + >>? fun () -> + error_unexpected_annot loc fields >>? fun () -> get_one_annot loc types + +let parse_type_field_annot : + int -> string list -> (type_annot option * field_annot option) tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars + >>? fun () -> + get_one_annot loc types + >>? fun t -> get_one_annot loc fields >|? fun f -> (t, f) + +let parse_composed_type_annot : + int -> + string list -> + (type_annot option * field_annot option * field_annot option) tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars + >>? fun () -> + get_one_annot loc types + >>? fun t -> get_two_annot loc fields >|? fun (f1, f2) -> (t, f1, f2) + +let parse_field_annot : int -> string list -> field_annot option tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars + >>? fun () -> + error_unexpected_annot loc types >>? fun () -> get_one_annot loc fields + +let extract_field_annot : + Script.node -> (Script.node * field_annot option) tzresult = function + | Prim (loc, prim, args, annot) -> + let rec extract_first acc = function + | [] -> + (None, annot) + | s :: rest -> + if Compare.Int.(String.length s > 0) && Compare.Char.(s.[0] = '%') + then (Some s, List.rev_append acc rest) + else extract_first (s :: acc) rest + in + let (field_annot, annot) = extract_first [] annot in + ( match field_annot with + | None -> + ok_none + | Some field_annot -> + parse_field_annot loc [field_annot] ) + >|? fun field_annot -> (Prim (loc, prim, args, annot), field_annot) + | expr -> + ok (expr, None) + +let check_correct_field : + field_annot option -> field_annot option -> unit tzresult = + fun f1 f2 -> + match (f1, f2) with + | (None, _) | (_, None) -> + ok_unit + | (Some (Field_annot s1), Some (Field_annot s2)) -> + if String.equal s1 s2 then ok_unit + else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2)) + +let parse_var_annot : + int -> + ?default:var_annot option -> + string list -> + var_annot option tzresult = + fun loc ?default annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc types + >>? fun () -> + error_unexpected_annot loc fields + >>? fun () -> + get_one_annot loc vars + >|? function + | Some _ as a -> + a + | None -> ( + match default with Some a -> a | None -> None ) + +let split_last_dot = function + | None -> + (None, None) + | Some (Field_annot s) -> ( + match String.rindex_opt s '.' with + | None -> + (None, Some (Field_annot s)) + | Some i -> + let s1 = String.sub s 0 i in + let s2 = String.sub s (i + 1) (String.length s - i - 1) in + let f = + if Compare.String.equal s2 "car" || Compare.String.equal s2 "cdr" + then None + else Some (Field_annot s2) + in + (Some (Var_annot s1), f) ) + +let common_prefix v1 v2 = + match (v1, v2) with + | (Some (Var_annot s1), Some (Var_annot s2)) when Compare.String.equal s1 s2 + -> + v1 + | (Some _, None) -> + v1 + | (None, Some _) -> + v2 + | (_, _) -> + None + +let parse_constr_annot : + int -> + ?if_special_first:field_annot option -> + ?if_special_second:field_annot option -> + string list -> + ( var_annot option + * type_annot option + * field_annot option + * field_annot option ) + tzresult = + fun loc ?if_special_first ?if_special_second annot -> + parse_annots ~allow_special_field:true loc annot + >>? classify_annot loc + >>? fun (vars, types, fields) -> + get_one_annot loc vars + >>? fun v -> + get_one_annot loc types + >>? fun t -> + get_two_annot loc fields + >>? fun (f1, f2) -> + ( match (if_special_first, f1) with + | (Some special_var, Some (Field_annot "@")) -> + ok (split_last_dot special_var) + | (None, Some (Field_annot "@")) -> + error (Unexpected_annotation loc) + | (_, _) -> + ok (v, f1) ) + >>? fun (v1, f1) -> + ( match (if_special_second, f2) with + | (Some special_var, Some (Field_annot "@")) -> + ok (split_last_dot special_var) + | (None, Some (Field_annot "@")) -> + error (Unexpected_annotation loc) + | (_, _) -> + ok (v, f2) ) + >|? fun (v2, f2) -> + let v = match v with None -> common_prefix v1 v2 | Some _ -> v in + (v, t, f1, f2) + +let parse_two_var_annot : + int -> string list -> (var_annot option * var_annot option) tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc types + >>? fun () -> + error_unexpected_annot loc fields >>? fun () -> get_two_annot loc vars + +let var_annot_from_special : + field_name:field_annot option -> + default:var_annot option -> + value_annot:var_annot option -> + var_annot option -> + var_annot option = + fun ~field_name ~default ~value_annot v -> + match v with + | Some (Var_annot "%") -> + field_to_var_annot field_name + | Some (Var_annot "%%") -> + default + | Some _ -> + v + | None -> + value_annot + +let parse_destr_annot : + int -> + string list -> + default_accessor:field_annot option -> + field_name:field_annot option -> + pair_annot:var_annot option -> + value_annot:var_annot option -> + (var_annot option * field_annot option) tzresult = + fun loc annot ~default_accessor ~field_name ~pair_annot ~value_annot -> + parse_annots loc ~allow_special_var:true annot + >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc types + >>? fun () -> + get_one_annot loc vars + >>? fun v -> + get_one_annot loc fields + >|? fun f -> + let default = + gen_access_annot pair_annot field_name ~default:default_accessor + in + let v = var_annot_from_special ~field_name ~default ~value_annot v in + (v, f) + +let parse_unpair_annot : + int -> + string list -> + field_name_car:field_annot option -> + field_name_cdr:field_annot option -> + pair_annot:var_annot option -> + value_annot_car:var_annot option -> + value_annot_cdr:var_annot option -> + ( var_annot option + * var_annot option + * field_annot option + * field_annot option ) + tzresult = + fun loc + annot + ~field_name_car + ~field_name_cdr + ~pair_annot + ~value_annot_car + ~value_annot_cdr -> + parse_annots loc ~allow_special_var:true annot + >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc types + >>? fun () -> + get_two_annot loc vars + >>? fun (vcar, vcdr) -> + get_two_annot loc fields + >|? fun (fcar, fcdr) -> + let default_car = + gen_access_annot pair_annot field_name_car ~default:default_car_annot + in + let default_cdr = + gen_access_annot pair_annot field_name_cdr ~default:default_cdr_annot + in + let vcar = + var_annot_from_special + ~field_name:field_name_car + ~default:default_car + ~value_annot:value_annot_car + vcar + in + let vcdr = + var_annot_from_special + ~field_name:field_name_cdr + ~default:default_cdr + ~value_annot:value_annot_cdr + vcdr + in + (vcar, vcdr, fcar, fcdr) + +let parse_entrypoint_annot : + int -> + ?default:var_annot option -> + string list -> + (var_annot option * field_annot option) tzresult = + fun loc ?default annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc types + >>? fun () -> + get_one_annot loc fields + >>? fun f -> + get_one_annot loc vars + >|? function + | Some _ as a -> + (a, f) + | None -> ( + match default with Some a -> (a, f) | None -> (None, f) ) + +let parse_var_type_annot : + int -> string list -> (var_annot option * type_annot option) tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc fields + >>? fun () -> + get_one_annot loc vars + >>? fun v -> get_one_annot loc types >|? fun t -> (v, t) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_annot.mli b/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_annot.mli new file mode 100644 index 0000000000000000000000000000000000000000..1fd5bf59693359ee9e1cfdc7b2877014d0070e75 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_annot.mli @@ -0,0 +1,215 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script_typed_ir + +(** Default annotations *) + +val default_now_annot : var_annot option + +val default_amount_annot : var_annot option + +val default_balance_annot : var_annot option + +val default_level_annot : var_annot option + +val default_steps_annot : var_annot option + +val default_source_annot : var_annot option + +val default_sender_annot : var_annot option + +val default_self_annot : var_annot option + +val default_arg_annot : var_annot option + +val default_param_annot : var_annot option + +val default_storage_annot : var_annot option + +val default_sapling_state_annot : var_annot option + +val default_sapling_balance_annot : var_annot option + +val default_car_annot : field_annot option + +val default_cdr_annot : field_annot option + +val default_contract_annot : field_annot option + +val default_addr_annot : field_annot option + +val default_manager_annot : field_annot option + +val default_pack_annot : field_annot option + +val default_unpack_annot : field_annot option + +val default_slice_annot : field_annot option + +val default_elt_annot : field_annot option + +val default_key_annot : field_annot option + +val default_hd_annot : field_annot option + +val default_tl_annot : field_annot option + +val default_some_annot : field_annot option + +val default_left_annot : field_annot option + +val default_right_annot : field_annot option + +val default_binding_annot : field_annot option + +(** Unparse annotations to their string representation *) + +val unparse_type_annot : type_annot option -> string list + +val unparse_var_annot : var_annot option -> string list + +val unparse_field_annot : field_annot option -> string list + +(** Conversion functions between different annotation kinds *) + +val field_to_var_annot : field_annot option -> var_annot option + +val type_to_var_annot : type_annot option -> var_annot option + +val var_to_field_annot : var_annot option -> field_annot option + +(** Replace an annotation by its default value if it is [None] *) +val default_annot : default:'a option -> 'a option -> 'a option + +(** Generate annotation for field accesses, of the form [var.field1.field2] *) +val gen_access_annot : + var_annot option -> + ?default:field_annot option -> + field_annot option -> + var_annot option + +(** Merge type annotations. + @return an error {!Inconsistent_type_annotations} if they are both present + and different, unless [legacy] *) +val merge_type_annot : + legacy:bool -> + type_annot option -> + type_annot option -> + type_annot option tzresult + +(** Merge field annotations. + @return an error {!Inconsistent_type_annotations} if they are both present + and different, unless [legacy] *) +val merge_field_annot : + legacy:bool -> + field_annot option -> + field_annot option -> + field_annot option tzresult + +(** Merge variable annotations, does not fail ([None] if different). *) +val merge_var_annot : var_annot option -> var_annot option -> var_annot option + +(** @return an error {!Unexpected_annotation} in the monad the list is not empty. *) +val error_unexpected_annot : int -> 'a list -> unit tzresult + +(** Parse a type annotation only. *) +val parse_type_annot : int -> string list -> type_annot option tzresult + +(** Parse a field annotation only. *) +val parse_field_annot : int -> string list -> field_annot option tzresult + +(** Parse an annotation for composed types, of the form + [:ty_name %field] in any order. *) +val parse_type_field_annot : + int -> string list -> (type_annot option * field_annot option) tzresult + +(** Parse an annotation for composed types, of the form + [:ty_name %field1 %field2] in any order. *) +val parse_composed_type_annot : + int -> + string list -> + (type_annot option * field_annot option * field_annot option) tzresult + +(** Extract and remove a field annotation from a node *) +val extract_field_annot : + Script.node -> (Script.node * field_annot option) tzresult + +(** Check that field annotations match, used for field accesses. *) +val check_correct_field : + field_annot option -> field_annot option -> unit tzresult + +(** Instruction annotations parsing *) + +(** Parse a variable annotation, replaced by a default value if [None]. *) +val parse_var_annot : + int -> ?default:var_annot option -> string list -> var_annot option tzresult + +val parse_constr_annot : + int -> + ?if_special_first:field_annot option -> + ?if_special_second:field_annot option -> + string list -> + ( var_annot option + * type_annot option + * field_annot option + * field_annot option ) + tzresult + +val parse_two_var_annot : + int -> string list -> (var_annot option * var_annot option) tzresult + +val parse_destr_annot : + int -> + string list -> + default_accessor:field_annot option -> + field_name:field_annot option -> + pair_annot:var_annot option -> + value_annot:var_annot option -> + (var_annot option * field_annot option) tzresult + +val parse_unpair_annot : + int -> + string list -> + field_name_car:field_annot option -> + field_name_cdr:field_annot option -> + pair_annot:var_annot option -> + value_annot_car:var_annot option -> + value_annot_cdr:var_annot option -> + ( var_annot option + * var_annot option + * field_annot option + * field_annot option ) + tzresult + +val parse_entrypoint_annot : + int -> + ?default:var_annot option -> + string list -> + (var_annot option * field_annot option) tzresult + +val parse_var_type_annot : + int -> string list -> (var_annot option * type_annot option) tzresult diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_translator.ml b/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_translator.ml new file mode 100644 index 0000000000000000000000000000000000000000..fca7d2661cf3007e5302242bf947c45878720be1 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_translator.ml @@ -0,0 +1,7327 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Micheline +open Script +open Script_typed_ir +open Script_tc_errors +open Script_ir_annot +module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking +module Unparse_costs = Michelson_v1_gas.Cost_of.Unparsing + +type ex_comparable_ty = + | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty + +type ex_ty = Ex_ty : 'a ty -> ex_ty + +type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty + +type tc_context = + | Lambda : tc_context + | Dip : 'a stack_ty * tc_context -> tc_context + | Toplevel : { + storage_type : 'sto ty; + param_type : 'param ty; + root_name : field_annot option; + legacy_create_contract_literal : bool; + } + -> tc_context + +type unparsing_mode = Optimized | Readable | Optimized_legacy + +type type_logger = + int -> + (Script.expr * Script.annot) list -> + (Script.expr * Script.annot) list -> + unit + +let add_dip ty annot prev = + match prev with + | Lambda | Toplevel _ -> + Dip (Item_t (ty, Empty_t, annot), prev) + | Dip (stack, _) -> + Dip (Item_t (ty, stack, annot), prev) + +(* ---- Type size accounting ------------------------------------------------*) + +let rec comparable_type_size : type t. t comparable_ty -> int = + fun ty -> + (* No wildcard to force the update when comparable_ty changes. *) + match ty with + | Unit_key _ -> + 1 + | Never_key _ -> + 1 + | Int_key _ -> + 1 + | Nat_key _ -> + 1 + | Signature_key _ -> + 1 + | String_key _ -> + 1 + | Bytes_key _ -> + 1 + | Mutez_key _ -> + 1 + | Bool_key _ -> + 1 + | Key_hash_key _ -> + 1 + | Key_key _ -> + 1 + | Timestamp_key _ -> + 1 + | Chain_id_key _ -> + 1 + | Address_key _ -> + 1 + | Pair_key ((t1, _), (t2, _), _) -> + 1 + comparable_type_size t1 + comparable_type_size t2 + | Union_key ((t1, _), (t2, _), _) -> + 1 + comparable_type_size t1 + comparable_type_size t2 + | Option_key (t, _) -> + 1 + comparable_type_size t + +let rec type_size : type t. t ty -> int = + fun ty -> + match ty with + | Unit_t _ -> + 1 + | Int_t _ -> + 1 + | Nat_t _ -> + 1 + | Signature_t _ -> + 1 + | Bytes_t _ -> + 1 + | String_t _ -> + 1 + | Mutez_t _ -> + 1 + | Key_hash_t _ -> + 1 + | Key_t _ -> + 1 + | Timestamp_t _ -> + 1 + | Address_t _ -> + 1 + | Bool_t _ -> + 1 + | Operation_t _ -> + 1 + | Chain_id_t _ -> + 1 + | Never_t _ -> + 1 + | Bls12_381_g1_t _ -> + 1 + | Bls12_381_g2_t _ -> + 1 + | Bls12_381_fr_t _ -> + 1 + | Sapling_transaction_t _ -> + 1 + | Sapling_state_t _ -> + 1 + | Pair_t ((l, _, _), (r, _, _), _) -> + 1 + type_size l + type_size r + | Union_t ((l, _), (r, _), _) -> + 1 + type_size l + type_size r + | Lambda_t (arg, ret, _) -> + 1 + type_size arg + type_size ret + | Option_t (t, _) -> + 1 + type_size t + | List_t (t, _) -> + 1 + type_size t + | Ticket_t (t, _) -> + 1 + comparable_type_size t + | Set_t (k, _) -> + 1 + comparable_type_size k + | Map_t (k, v, _) -> + 1 + comparable_type_size k + type_size v + | Big_map_t (k, v, _) -> + 1 + comparable_type_size k + type_size v + | Contract_t (arg, _) -> + 1 + type_size arg + +let rec type_size_of_stack_head : type st. st stack_ty -> up_to:int -> int = + fun stack ~up_to -> + match stack with + | Empty_t -> + 0 + | Item_t (head, tail, _annot) -> + if Compare.Int.(up_to > 0) then + Compare.Int.max + (type_size head) + (type_size_of_stack_head tail ~up_to:(up_to - 1)) + else 0 + +(* This is the depth of the stack to inspect for sizes overflow. We + only need to check the produced types that can be larger than the + arguments. That's why Swap is 0 for instance as no type grows. + Constant sized types are not checked: it is assumed they are lower + than the bound (otherwise every program would be rejected). + + In a [(b, a) instr], it is the number of types in [a] that may exceed the + limit, knowing that types in [b] don't. + If the instr is parameterized by [(b', a') descr] then you may assume that + types in [a'] don't exceed the limit. +*) +let number_of_generated_growing_types : type b a. (b, a) instr -> int = + function + (* Constructors *) + | Const _ -> + 1 + | Cons_pair -> + 1 + | Cons_some -> + 1 + | Cons_none _ -> + 1 + | Cons_left -> + 1 + | Cons_right -> + 1 + | Nil -> + 1 + | Empty_set _ -> + 1 + | Empty_map _ -> + 1 + | Empty_big_map _ -> + 1 + | Lambda _ -> + 1 + | Self _ -> + 1 + | Contract _ -> + 1 + | Ticket -> + 1 + | Read_ticket -> + (* `pair address (pair T nat)` is bigger than `ticket T` *) + 1 + | Split_ticket -> + 1 + (* Magic constructor *) + | Unpack _ -> + 1 + (* Mappings *) + | List_map _ -> + 1 + | Map_map _ -> + 1 + (* Others: + - don't add types + - don't change types + - decrease type sizes + - produce only constants + - have types bounded by parameters + - etc. *) + | Drop -> + 0 + | Dup -> + 0 + | Swap -> + 0 + | Unpair -> + 0 + | Car -> + 0 + | Cdr -> + 0 + | If_none _ -> + 0 + | If_left _ -> + 0 + | Cons_list -> + 0 + | If_cons _ -> + 0 + | List_size -> + 0 + | List_iter _ -> + 0 + | Set_iter _ -> + 0 + | Set_mem -> + 0 + | Set_update -> + 0 + | Set_size -> + 0 + | Map_iter _ -> + 0 + | Map_mem -> + 0 + | Map_get -> + 0 + | Map_update -> + 0 + | Map_get_and_update -> + 0 + | Map_size -> + 0 + | Big_map_get -> + 0 + | Big_map_update -> + 0 + | Big_map_get_and_update -> + 0 + | Big_map_mem -> + 0 + | Concat_string -> + 0 + | Concat_string_pair -> + 0 + | Slice_string -> + 0 + | String_size -> + 0 + | Concat_bytes -> + 0 + | Concat_bytes_pair -> + 0 + | Slice_bytes -> + 0 + | Bytes_size -> + 0 + | Add_seconds_to_timestamp -> + 0 + | Add_timestamp_to_seconds -> + 0 + | Sub_timestamp_seconds -> + 0 + | Diff_timestamps -> + 0 + | Add_tez -> + 0 + | Sub_tez -> + 0 + | Mul_teznat -> + 0 + | Mul_nattez -> + 0 + | Ediv_teznat -> + 0 + | Ediv_tez -> + 0 + | Or -> + 0 + | And -> + 0 + | Xor -> + 0 + | Not -> + 0 + | Is_nat -> + 0 + | Neg_nat -> + 0 + | Neg_int -> + 0 + | Abs_int -> + 0 + | Int_nat -> + 0 + | Add_intint -> + 0 + | Add_intnat -> + 0 + | Add_natint -> + 0 + | Add_natnat -> + 0 + | Sub_int -> + 0 + | Mul_intint -> + 0 + | Mul_intnat -> + 0 + | Mul_natint -> + 0 + | Mul_natnat -> + 0 + | Ediv_intint -> + 0 + | Ediv_intnat -> + 0 + | Ediv_natint -> + 0 + | Ediv_natnat -> + 0 + | Lsl_nat -> + 0 + | Lsr_nat -> + 0 + | Or_nat -> + 0 + | And_nat -> + 0 + | And_int_nat -> + 0 + | Xor_nat -> + 0 + | Not_nat -> + 0 + | Not_int -> + 0 + | Seq _ -> + 0 + | If _ -> + 0 + | Loop _ -> + 0 + | Loop_left _ -> + 0 + | Dip _ -> + 0 + | Exec -> + 0 + | Apply _ -> + 0 + | Failwith _ -> + 0 + | Nop -> + 0 + | Compare _ -> + 0 + | Eq -> + 0 + | Neq -> + 0 + | Lt -> + 0 + | Gt -> + 0 + | Le -> + 0 + | Ge -> + 0 + | Address -> + 0 + | Transfer_tokens -> + 0 + | Implicit_account -> + 0 + | Create_contract _ -> + 0 + | Now -> + 0 + | Level -> + 0 + | Balance -> + 0 + | Check_signature -> + 0 + | Hash_key -> + 0 + | Blake2b -> + 0 + | Sha256 -> + 0 + | Sha512 -> + 0 + | Source -> + 0 + | Sender -> + 0 + | Amount -> + 0 + | Self_address -> + 0 + | Sapling_empty_state _ -> + 0 + | Sapling_verify_update -> + 0 + | Set_delegate -> + 0 + | Pack _ -> + 0 + | Dig _ -> + 0 + | Dug _ -> + 0 + | Dipn _ -> + 0 + | Dropn _ -> + 0 + | ChainId -> + 0 + | Never -> + 0 + | Voting_power -> + 0 + | Total_voting_power -> + 0 + | Keccak -> + 0 + | Sha3 -> + 0 + | Add_bls12_381_g1 -> + 0 + | Add_bls12_381_g2 -> + 0 + | Add_bls12_381_fr -> + 0 + | Mul_bls12_381_g1 -> + 0 + | Mul_bls12_381_g2 -> + 0 + | Mul_bls12_381_fr -> + 0 + | Mul_bls12_381_fr_z -> + 0 + | Mul_bls12_381_z_fr -> + 0 + | Int_bls12_381_fr -> + 0 + | Neg_bls12_381_g1 -> + 0 + | Neg_bls12_381_g2 -> + 0 + | Neg_bls12_381_fr -> + 0 + | Pairing_check_bls12_381 -> + 0 + | Uncomb _ -> + 0 + | Comb_get _ -> + 0 + | Comb _ -> + 1 + | Comb_set _ -> + 1 + | Dup_n _ -> + 0 + | Join_tickets _ -> + 0 + +(* ---- Error helpers -------------------------------------------------------*) + +let location = function + | Prim (loc, _, _, _) + | Int (loc, _) + | String (loc, _) + | Bytes (loc, _) + | Seq (loc, _) -> + loc + +let kind_equal a b = + match (a, b) with + | (Int_kind, Int_kind) + | (String_kind, String_kind) + | (Bytes_kind, Bytes_kind) + | (Prim_kind, Prim_kind) + | (Seq_kind, Seq_kind) -> + true + | _ -> + false + +let kind = function + | Int _ -> + Int_kind + | String _ -> + String_kind + | Bytes _ -> + Bytes_kind + | Prim _ -> + Prim_kind + | Seq _ -> + Seq_kind + +let unexpected expr exp_kinds exp_ns exp_prims = + match expr with + | Int (loc, _) -> + Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind) + | String (loc, _) -> + Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind) + | Bytes (loc, _) -> + Invalid_kind (loc, Prim_kind :: exp_kinds, Bytes_kind) + | Seq (loc, _) -> + Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind) + | Prim (loc, name, _, _) -> ( + let open Michelson_v1_primitives in + match (namespace name, exp_ns) with + | (Type_namespace, Type_namespace) + | (Instr_namespace, Instr_namespace) + | (Constant_namespace, Constant_namespace) -> + Invalid_primitive (loc, exp_prims, name) + | (ns, _) -> + Invalid_namespace (loc, name, exp_ns, ns) ) + +let check_kind kinds expr = + let kind = kind expr in + if List.exists (kind_equal kind) kinds then ok_unit + else + let loc = location expr in + error (Invalid_kind (loc, kinds, kind)) + +(* ---- Lists, Sets and Maps ----------------------------------------------- *) + +let list_empty : 'a Script_typed_ir.boxed_list = + let open Script_typed_ir in + {elements = []; length = 0} + +let list_cons : + 'a -> 'a Script_typed_ir.boxed_list -> 'a Script_typed_ir.boxed_list = + fun elt l -> + let open Script_typed_ir in + {length = 1 + l.length; elements = elt :: l.elements} + +let wrap_compare compare a b = + let res = compare a b in + if Compare.Int.(res = 0) then 0 else if Compare.Int.(res > 0) then 1 else -1 + +let compare_address (x, ex) (y, ey) = + let lres = Contract.compare x y in + if Compare.Int.(lres = 0) then Compare.String.compare ex ey else lres + +let rec compare_comparable : type a. a comparable_ty -> a -> a -> int = + fun kind -> + match kind with + | Unit_key _ -> + fun () () -> 0 + | Never_key _ -> ( + function _ -> . ) + | Signature_key _ -> + wrap_compare Signature.compare + | String_key _ -> + wrap_compare Compare.String.compare + | Bool_key _ -> + wrap_compare Compare.Bool.compare + | Mutez_key _ -> + wrap_compare Tez.compare + | Key_hash_key _ -> + wrap_compare Signature.Public_key_hash.compare + | Key_key _ -> + wrap_compare Signature.Public_key.compare + | Int_key _ -> + wrap_compare Script_int.compare + | Nat_key _ -> + wrap_compare Script_int.compare + | Timestamp_key _ -> + wrap_compare Script_timestamp.compare + | Address_key _ -> + wrap_compare compare_address + | Bytes_key _ -> + wrap_compare Compare.Bytes.compare + | Chain_id_key _ -> + wrap_compare Chain_id.compare + | Pair_key ((tl, _), (tr, _), _) -> + fun (lx, rx) (ly, ry) -> + let lres = compare_comparable tl lx ly in + if Compare.Int.(lres = 0) then compare_comparable tr rx ry else lres + | Union_key ((tl, _), (tr, _), _) -> ( + fun x y -> + match (x, y) with + | (L x, L y) -> + compare_comparable tl x y + | (L _, R _) -> + -1 + | (R _, L _) -> + 1 + | (R x, R y) -> + compare_comparable tr x y ) + | Option_key (t, _) -> ( + fun x y -> + match (x, y) with + | (None, None) -> + 0 + | (None, Some _) -> + -1 + | (Some _, None) -> + 1 + | (Some x, Some y) -> + compare_comparable t x y ) + +let empty_set : type a. a comparable_ty -> a set = + fun ty -> + let module OPS = Set.Make (struct + type t = a + + let compare = compare_comparable ty + end) in + ( module struct + type elt = a + + let elt_ty = ty + + module OPS = OPS + + let boxed = OPS.empty + + let size = 0 + end ) + +let set_update : type a. a -> bool -> a set -> a set = + fun v b (module Box) -> + ( module struct + type elt = a + + let elt_ty = Box.elt_ty + + module OPS = Box.OPS + + let boxed = + if b then Box.OPS.add v Box.boxed else Box.OPS.remove v Box.boxed + + let size = + let mem = Box.OPS.mem v Box.boxed in + if mem then if b then Box.size else Box.size - 1 + else if b then Box.size + 1 + else Box.size + end ) + +let set_mem : type elt. elt -> elt set -> bool = + fun v (module Box) -> Box.OPS.mem v Box.boxed + +let set_fold : type elt acc. (elt -> acc -> acc) -> elt set -> acc -> acc = + fun f (module Box) -> Box.OPS.fold f Box.boxed + +let set_size : type elt. elt set -> Script_int.n Script_int.num = + fun (module Box) -> Script_int.(abs (of_int Box.size)) + +let map_key_ty : type a b. (a, b) map -> a comparable_ty = + fun (module Box) -> Box.key_ty + +let empty_map : type a b. a comparable_ty -> (a, b) map = + fun ty -> + let module OPS = Map.Make (struct + type t = a + + let compare = compare_comparable ty + end) in + ( module struct + type key = a + + type value = b + + let key_ty = ty + + module OPS = OPS + + let boxed = (OPS.empty, 0) + end ) + +let map_get : type key value. key -> (key, value) map -> value option = + fun k (module Box) -> Box.OPS.find_opt k (fst Box.boxed) + +let map_update : type a b. a -> b option -> (a, b) map -> (a, b) map = + fun k v (module Box) -> + ( module struct + type key = a + + type value = b + + let key_ty = Box.key_ty + + module OPS = Box.OPS + + let boxed = + let (map, size) = Box.boxed in + let contains = Box.OPS.mem k map in + match v with + | Some v -> + (Box.OPS.add k v map, size + if contains then 0 else 1) + | None -> + (Box.OPS.remove k map, size - if contains then 1 else 0) + end ) + +let map_set : type a b. a -> b -> (a, b) map -> (a, b) map = + fun k v (module Box) -> + ( module struct + type key = a + + type value = b + + let key_ty = Box.key_ty + + module OPS = Box.OPS + + let boxed = + let (map, size) = Box.boxed in + (Box.OPS.add k v map, if Box.OPS.mem k map then size else size + 1) + end ) + +let map_mem : type key value. key -> (key, value) map -> bool = + fun k (module Box) -> Box.OPS.mem k (fst Box.boxed) + +let map_fold : + type key value acc. + (key -> value -> acc -> acc) -> (key, value) map -> acc -> acc = + fun f (module Box) -> Box.OPS.fold f (fst Box.boxed) + +let map_size : type key value. (key, value) map -> Script_int.n Script_int.num + = + fun (module Box) -> Script_int.(abs (of_int (snd Box.boxed))) + +(* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*) + +let rec ty_of_comparable_ty : type a. a comparable_ty -> a ty = function + | Unit_key tname -> + Unit_t tname + | Never_key tname -> + Never_t tname + | Int_key tname -> + Int_t tname + | Nat_key tname -> + Nat_t tname + | Signature_key tname -> + Signature_t tname + | String_key tname -> + String_t tname + | Bytes_key tname -> + Bytes_t tname + | Mutez_key tname -> + Mutez_t tname + | Bool_key tname -> + Bool_t tname + | Key_hash_key tname -> + Key_hash_t tname + | Key_key tname -> + Key_t tname + | Timestamp_key tname -> + Timestamp_t tname + | Address_key tname -> + Address_t tname + | Chain_id_key tname -> + Chain_id_t tname + | Pair_key ((l, al), (r, ar), tname) -> + Pair_t + ( (ty_of_comparable_ty l, al, None), + (ty_of_comparable_ty r, ar, None), + tname ) + | Union_key ((l, al), (r, ar), tname) -> + Union_t ((ty_of_comparable_ty l, al), (ty_of_comparable_ty r, ar), tname) + | Option_key (t, tname) -> + Option_t (ty_of_comparable_ty t, tname) + +let add_field_annot a var = function + | Prim (loc, prim, args, annots) -> + Prim + ( loc, + prim, + args, + annots @ unparse_field_annot a @ unparse_var_annot var ) + | expr -> + expr + +let rec unparse_comparable_ty : type a. a comparable_ty -> Script.node = + function + | Unit_key tname -> + Prim (-1, T_unit, [], unparse_type_annot tname) + | Never_key tname -> + Prim (-1, T_never, [], unparse_type_annot tname) + | Int_key tname -> + Prim (-1, T_int, [], unparse_type_annot tname) + | Nat_key tname -> + Prim (-1, T_nat, [], unparse_type_annot tname) + | Signature_key tname -> + Prim (-1, T_signature, [], unparse_type_annot tname) + | String_key tname -> + Prim (-1, T_string, [], unparse_type_annot tname) + | Bytes_key tname -> + Prim (-1, T_bytes, [], unparse_type_annot tname) + | Mutez_key tname -> + Prim (-1, T_mutez, [], unparse_type_annot tname) + | Bool_key tname -> + Prim (-1, T_bool, [], unparse_type_annot tname) + | Key_hash_key tname -> + Prim (-1, T_key_hash, [], unparse_type_annot tname) + | Key_key tname -> + Prim (-1, T_key, [], unparse_type_annot tname) + | Timestamp_key tname -> + Prim (-1, T_timestamp, [], unparse_type_annot tname) + | Address_key tname -> + Prim (-1, T_address, [], unparse_type_annot tname) + | Chain_id_key tname -> + Prim (-1, T_chain_id, [], unparse_type_annot tname) + | Pair_key ((l, al), (r, ar), pname) -> ( + let tl = add_field_annot al None (unparse_comparable_ty l) in + let tr = add_field_annot ar None (unparse_comparable_ty r) in + (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *) + (* Note that the folding does not happen if the pair on the right has a + field annotation because this annotation would be lost *) + match tr with + | Prim (_, T_pair, ts, []) -> + Prim (-1, T_pair, tl :: ts, unparse_type_annot pname) + | _ -> + Prim (-1, T_pair, [tl; tr], unparse_type_annot pname) ) + | Union_key ((l, al), (r, ar), tname) -> + let tl = add_field_annot al None (unparse_comparable_ty l) in + let tr = add_field_annot ar None (unparse_comparable_ty r) in + Prim (-1, T_or, [tl; tr], unparse_type_annot tname) + | Option_key (t, tname) -> + Prim (-1, T_option, [unparse_comparable_ty t], unparse_type_annot tname) + +let unparse_memo_size memo_size = + let z = Sapling.Memo_size.unparse_to_z memo_size in + Int (-1, z) + +let rec unparse_ty : + type a. context -> a ty -> (Script.node * context) tzresult = + fun ctxt ty -> + Gas.consume ctxt Unparse_costs.unparse_type_cycle + >>? fun ctxt -> + let return ctxt (name, args, annot) = + let result = Prim (-1, name, args, annot) in + ok (result, ctxt) + in + match ty with + | Unit_t tname -> + return ctxt (T_unit, [], unparse_type_annot tname) + | Int_t tname -> + return ctxt (T_int, [], unparse_type_annot tname) + | Nat_t tname -> + return ctxt (T_nat, [], unparse_type_annot tname) + | Signature_t tname -> + return ctxt (T_signature, [], unparse_type_annot tname) + | String_t tname -> + return ctxt (T_string, [], unparse_type_annot tname) + | Bytes_t tname -> + return ctxt (T_bytes, [], unparse_type_annot tname) + | Mutez_t tname -> + return ctxt (T_mutez, [], unparse_type_annot tname) + | Bool_t tname -> + return ctxt (T_bool, [], unparse_type_annot tname) + | Key_hash_t tname -> + return ctxt (T_key_hash, [], unparse_type_annot tname) + | Key_t tname -> + return ctxt (T_key, [], unparse_type_annot tname) + | Timestamp_t tname -> + return ctxt (T_timestamp, [], unparse_type_annot tname) + | Address_t tname -> + return ctxt (T_address, [], unparse_type_annot tname) + | Operation_t tname -> + return ctxt (T_operation, [], unparse_type_annot tname) + | Chain_id_t tname -> + return ctxt (T_chain_id, [], unparse_type_annot tname) + | Never_t tname -> + return ctxt (T_never, [], unparse_type_annot tname) + | Bls12_381_g1_t tname -> + return ctxt (T_bls12_381_g1, [], unparse_type_annot tname) + | Bls12_381_g2_t tname -> + return ctxt (T_bls12_381_g2, [], unparse_type_annot tname) + | Bls12_381_fr_t tname -> + return ctxt (T_bls12_381_fr, [], unparse_type_annot tname) + | Contract_t (ut, tname) -> + unparse_ty ctxt ut + >>? fun (t, ctxt) -> + return ctxt (T_contract, [t], unparse_type_annot tname) + | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname) -> + let annot = unparse_type_annot tname in + unparse_ty ctxt utl + >>? fun (utl, ctxt) -> + let tl = add_field_annot l_field l_var utl in + unparse_ty ctxt utr + >>? fun (utr, ctxt) -> + let tr = add_field_annot r_field r_var utr in + (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *) + (* Note that the folding does not happen if the pair on the right has an + annotation because this annotation would be lost *) + return + ctxt + ( match tr with + | Prim (_, T_pair, ts, []) -> + (T_pair, tl :: ts, annot) + | _ -> + (T_pair, [tl; tr], annot) ) + | Union_t ((utl, l_field), (utr, r_field), tname) -> + let annot = unparse_type_annot tname in + unparse_ty ctxt utl + >>? fun (utl, ctxt) -> + let tl = add_field_annot l_field None utl in + unparse_ty ctxt utr + >>? fun (utr, ctxt) -> + let tr = add_field_annot r_field None utr in + return ctxt (T_or, [tl; tr], annot) + | Lambda_t (uta, utr, tname) -> + unparse_ty ctxt uta + >>? fun (ta, ctxt) -> + unparse_ty ctxt utr + >>? fun (tr, ctxt) -> + return ctxt (T_lambda, [ta; tr], unparse_type_annot tname) + | Option_t (ut, tname) -> + let annot = unparse_type_annot tname in + unparse_ty ctxt ut + >>? fun (ut, ctxt) -> return ctxt (T_option, [ut], annot) + | List_t (ut, tname) -> + unparse_ty ctxt ut + >>? fun (t, ctxt) -> return ctxt (T_list, [t], unparse_type_annot tname) + | Ticket_t (ut, tname) -> + let t = unparse_comparable_ty ut in + return ctxt (T_ticket, [t], unparse_type_annot tname) + | Set_t (ut, tname) -> + let t = unparse_comparable_ty ut in + return ctxt (T_set, [t], unparse_type_annot tname) + | Map_t (uta, utr, tname) -> + let ta = unparse_comparable_ty uta in + unparse_ty ctxt utr + >>? fun (tr, ctxt) -> + return ctxt (T_map, [ta; tr], unparse_type_annot tname) + | Big_map_t (uta, utr, tname) -> + let ta = unparse_comparable_ty uta in + unparse_ty ctxt utr + >>? fun (tr, ctxt) -> + return ctxt (T_big_map, [ta; tr], unparse_type_annot tname) + | Sapling_transaction_t (memo_size, tname) -> + return + ctxt + ( T_sapling_transaction, + [unparse_memo_size memo_size], + unparse_type_annot tname ) + | Sapling_state_t (memo_size, tname) -> + return + ctxt + ( T_sapling_state, + [unparse_memo_size memo_size], + unparse_type_annot tname ) + +let rec strip_var_annots = function + | (Int _ | String _ | Bytes _) as atom -> + atom + | Seq (loc, args) -> + Seq (loc, List.map strip_var_annots args) + | Prim (loc, name, args, annots) -> + let not_var_annot s = Compare.Char.(s.[0] <> '@') in + let annots = List.filter not_var_annot annots in + Prim (loc, name, List.map strip_var_annots args, annots) + +let serialize_ty_for_error ctxt ty = + unparse_ty ctxt ty + >>? (fun (ty, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost ty) + >|? fun ctxt -> (Micheline.strip_locations (strip_var_annots ty), ctxt)) + |> record_trace Cannot_serialize_error + +let rec comparable_ty_of_ty : + type a. + context -> Script.location -> a ty -> (a comparable_ty * context) tzresult + = + fun ctxt loc ty -> + Gas.consume ctxt Typecheck_costs.comparable_ty_of_ty_cycle + >>? fun ctxt -> + match ty with + | Unit_t tname -> + ok ((Unit_key tname : a comparable_ty), ctxt) + | Never_t tname -> + ok (Never_key tname, ctxt) + | Int_t tname -> + ok (Int_key tname, ctxt) + | Nat_t tname -> + ok (Nat_key tname, ctxt) + | Signature_t tname -> + ok (Signature_key tname, ctxt) + | String_t tname -> + ok (String_key tname, ctxt) + | Bytes_t tname -> + ok (Bytes_key tname, ctxt) + | Mutez_t tname -> + ok (Mutez_key tname, ctxt) + | Bool_t tname -> + ok (Bool_key tname, ctxt) + | Key_hash_t tname -> + ok (Key_hash_key tname, ctxt) + | Key_t tname -> + ok (Key_key tname, ctxt) + | Timestamp_t tname -> + ok (Timestamp_key tname, ctxt) + | Address_t tname -> + ok (Address_key tname, ctxt) + | Chain_id_t tname -> + ok (Chain_id_key tname, ctxt) + | Pair_t ((l, al, _), (r, ar, _), pname) -> + comparable_ty_of_ty ctxt loc l + >>? fun (lty, ctxt) -> + comparable_ty_of_ty ctxt loc r + >|? fun (rty, ctxt) -> (Pair_key ((lty, al), (rty, ar), pname), ctxt) + | Union_t ((l, al), (r, ar), tname) -> + comparable_ty_of_ty ctxt loc l + >>? fun (lty, ctxt) -> + comparable_ty_of_ty ctxt loc r + >|? fun (rty, ctxt) -> (Union_key ((lty, al), (rty, ar), tname), ctxt) + | Option_t (tt, tname) -> + comparable_ty_of_ty ctxt loc tt + >|? fun (ty, ctxt) -> (Option_key (ty, tname), ctxt) + | Lambda_t _ + | List_t _ + | Ticket_t _ + | Set_t _ + | Map_t _ + | Big_map_t _ + | Contract_t _ + | Operation_t _ + | Bls12_381_fr_t _ + | Bls12_381_g1_t _ + | Bls12_381_g2_t _ + | Sapling_state_t _ + | Sapling_transaction_t _ -> + serialize_ty_for_error ctxt ty + >>? fun (t, _ctxt) -> error (Comparable_type_expected (loc, t)) + +let rec unparse_stack : + type a. + context -> + a stack_ty -> + ((Script.expr * Script.annot) list * context) tzresult = + fun ctxt -> function + | Empty_t -> + ok ([], ctxt) + | Item_t (ty, rest, annot) -> + unparse_ty ctxt ty + >>? fun (uty, ctxt) -> + unparse_stack ctxt rest + >|? fun (urest, ctxt) -> + ((strip_locations uty, unparse_var_annot annot) :: urest, ctxt) + +let serialize_stack_for_error ctxt stack_ty = + record_trace Cannot_serialize_error (unparse_stack ctxt stack_ty) + +let name_of_ty : type a. a ty -> type_annot option = function + | Unit_t tname -> + tname + | Int_t tname -> + tname + | Nat_t tname -> + tname + | String_t tname -> + tname + | Bytes_t tname -> + tname + | Mutez_t tname -> + tname + | Bool_t tname -> + tname + | Key_hash_t tname -> + tname + | Key_t tname -> + tname + | Timestamp_t tname -> + tname + | Address_t tname -> + tname + | Signature_t tname -> + tname + | Operation_t tname -> + tname + | Chain_id_t tname -> + tname + | Never_t tname -> + tname + | Contract_t (_, tname) -> + tname + | Pair_t (_, _, tname) -> + tname + | Union_t (_, _, tname) -> + tname + | Lambda_t (_, _, tname) -> + tname + | Option_t (_, tname) -> + tname + | List_t (_, tname) -> + tname + | Ticket_t (_, tname) -> + tname + | Set_t (_, tname) -> + tname + | Map_t (_, _, tname) -> + tname + | Big_map_t (_, _, tname) -> + tname + | Bls12_381_g1_t tname -> + tname + | Bls12_381_g2_t tname -> + tname + | Bls12_381_fr_t tname -> + tname + | Sapling_state_t (_, tname) -> + tname + | Sapling_transaction_t (_, tname) -> + tname + +(* ---- Tickets ------------------------------------------------------------ *) + +(* + All comparable types are dupable, this function exists only to not forget + checking this property when adding new types. +*) +let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function + | Unit_key _ + | Never_key _ + | Int_key _ + | Nat_key _ + | Signature_key _ + | String_key _ + | Bytes_key _ + | Mutez_key _ + | Bool_key _ + | Key_hash_key _ + | Key_key _ + | Timestamp_key _ + | Chain_id_key _ + | Address_key _ + | Pair_key _ + | Union_key _ + | Option_key _ -> + () + +let rec check_dupable_ty : + type a. context -> location -> a ty -> context tzresult = + fun ctxt loc ty -> + Gas.consume ctxt Typecheck_costs.check_dupable_cycle + >>? fun ctxt -> + match ty with + | Unit_t _ -> + ok ctxt + | Int_t _ -> + ok ctxt + | Nat_t _ -> + ok ctxt + | Signature_t _ -> + ok ctxt + | String_t _ -> + ok ctxt + | Bytes_t _ -> + ok ctxt + | Mutez_t _ -> + ok ctxt + | Key_hash_t _ -> + ok ctxt + | Key_t _ -> + ok ctxt + | Timestamp_t _ -> + ok ctxt + | Address_t _ -> + ok ctxt + | Bool_t _ -> + ok ctxt + | Contract_t (_, _) -> + ok ctxt + | Operation_t _ -> + ok ctxt + | Chain_id_t _ -> + ok ctxt + | Never_t _ -> + ok ctxt + | Bls12_381_g1_t _ -> + ok ctxt + | Bls12_381_g2_t _ -> + ok ctxt + | Bls12_381_fr_t _ -> + ok ctxt + | Sapling_state_t _ -> + ok ctxt + | Sapling_transaction_t _ -> + ok ctxt + | Ticket_t _ -> + error (Unexpected_ticket loc) + | Pair_t ((ty_a, _, _), (ty_b, _, _), _) -> + check_dupable_ty ctxt loc ty_a + >>? fun ctxt -> check_dupable_ty ctxt loc ty_b + | Union_t ((ty_a, _), (ty_b, _), _) -> + check_dupable_ty ctxt loc ty_a + >>? fun ctxt -> check_dupable_ty ctxt loc ty_b + | Lambda_t (_, _, _) -> + (* + Lambda are dupable as long as: + - they don't contain non-dupable values, e.g. in `PUSH` + (mosty non-dupable values should probably be considered forged) + - they are not the result of a partial application on a non-dupable + value. `APPLY` rejects non-packable types (because of `PUSH`). + Hence non-dupable should imply non-packable. + *) + ok ctxt + | Option_t (ty, _) -> + check_dupable_ty ctxt loc ty + | List_t (ty, _) -> + check_dupable_ty ctxt loc ty + | Set_t (key_ty, _) -> + let () = check_dupable_comparable_ty key_ty in + ok ctxt + | Map_t (key_ty, val_ty, _) -> + let () = check_dupable_comparable_ty key_ty in + check_dupable_ty ctxt loc val_ty + | Big_map_t (key_ty, val_ty, _) -> + let () = check_dupable_comparable_ty key_ty in + check_dupable_ty ctxt loc val_ty + +(* ---- Equality witnesses --------------------------------------------------*) + +type ('ta, 'tb) eq = Eq : ('same, 'same) eq + +let record_inconsistent ctxt ta tb = + record_trace_eval (fun () -> + serialize_ty_for_error ctxt ta + >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb + >|? fun (tb, _ctxt) -> Inconsistent_types (ta, tb)) + +let record_inconsistent_type_annotations ctxt loc ta tb = + record_trace_eval (fun () -> + serialize_ty_for_error ctxt ta + >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb + >|? fun (tb, _ctxt) -> Inconsistent_type_annotations (loc, ta, tb)) + +let rec merge_comparable_types : + type ta tb. + legacy:bool -> + context -> + ta comparable_ty -> + tb comparable_ty -> + ((ta comparable_ty, tb comparable_ty) eq * ta comparable_ty * context) + tzresult = + fun ~legacy ctxt ta tb -> + Gas.consume ctxt Typecheck_costs.merge_cycle + >>? fun ctxt -> + match (ta, tb) with + | (Unit_key annot_a, Unit_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> + ( (Eq : (ta comparable_ty, tb comparable_ty) eq), + (Unit_key annot : ta comparable_ty), + ctxt ) + | (Never_key annot_a, Never_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Never_key annot, ctxt) + | (Int_key annot_a, Int_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Int_key annot, ctxt) + | (Nat_key annot_a, Nat_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Nat_key annot, ctxt) + | (Signature_key annot_a, Signature_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Signature_key annot, ctxt) + | (String_key annot_a, String_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, String_key annot, ctxt) + | (Bytes_key annot_a, Bytes_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Bytes_key annot, ctxt) + | (Mutez_key annot_a, Mutez_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Mutez_key annot, ctxt) + | (Bool_key annot_a, Bool_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Bool_key annot, ctxt) + | (Key_hash_key annot_a, Key_hash_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Key_hash_key annot, ctxt) + | (Key_key annot_a, Key_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Key_key annot, ctxt) + | (Timestamp_key annot_a, Timestamp_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Timestamp_key annot, ctxt) + | (Chain_id_key annot_a, Chain_id_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Chain_id_key annot, ctxt) + | (Address_key annot_a, Address_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> (Eq, Address_key annot, ctxt) + | ( Pair_key ((left_a, annot_left_a), (right_a, annot_right_a), annot_a), + Pair_key ((left_b, annot_left_b), (right_b, annot_right_b), annot_b) ) -> + merge_type_annot ~legacy annot_a annot_b + >>? fun annot -> + merge_field_annot ~legacy annot_left_a annot_left_b + >>? fun annot_left -> + merge_field_annot ~legacy annot_right_a annot_right_b + >>? fun annot_right -> + merge_comparable_types ~legacy ctxt left_a left_b + >>? fun (Eq, left, ctxt) -> + merge_comparable_types ~legacy ctxt right_a right_b + >|? fun (Eq, right, ctxt) -> + ( (Eq : (ta comparable_ty, tb comparable_ty) eq), + Pair_key ((left, annot_left), (right, annot_right), annot), + ctxt ) + | ( Union_key ((left_a, annot_left_a), (right_a, annot_right_a), annot_a), + Union_key ((left_b, annot_left_b), (right_b, annot_right_b), annot_b) ) + -> + merge_type_annot ~legacy annot_a annot_b + >>? fun annot -> + merge_field_annot ~legacy annot_left_a annot_left_b + >>? fun annot_left -> + merge_field_annot ~legacy annot_right_a annot_right_b + >>? fun annot_right -> + merge_comparable_types ~legacy ctxt left_a left_b + >>? fun (Eq, left, ctxt) -> + merge_comparable_types ~legacy ctxt right_a right_b + >|? fun (Eq, right, ctxt) -> + ( (Eq : (ta comparable_ty, tb comparable_ty) eq), + Union_key ((left, annot_left), (right, annot_right), annot), + ctxt ) + | (Option_key (ta, annot_a), Option_key (tb, annot_b)) -> + merge_type_annot ~legacy annot_a annot_b + >>? fun annot -> + merge_comparable_types ~legacy ctxt ta tb + >|? fun (Eq, t, ctxt) -> + ( (Eq : (ta comparable_ty, tb comparable_ty) eq), + Option_key (t, annot), + ctxt ) + | (_, _) -> + serialize_ty_for_error ctxt (ty_of_comparable_ty ta) + >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt (ty_of_comparable_ty tb) + >>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb)) + +let comparable_ty_eq : + type ta tb. + context -> + ta comparable_ty -> + tb comparable_ty -> + ((ta comparable_ty, tb comparable_ty) eq * context) tzresult = + fun ctxt ta tb -> + merge_comparable_types ~legacy:true ctxt ta tb + >|? fun (eq, _ty, ctxt) -> (eq, ctxt) + +let merge_memo_sizes ms1 ms2 = + if Sapling.Memo_size.equal ms1 ms2 then ok ms1 + else error (Inconsistent_memo_sizes (ms1, ms2)) + +let merge_types : + type a b. + legacy:bool -> + context -> + Script.location -> + a ty -> + b ty -> + ((a ty, b ty) eq * a ty * context) tzresult = + fun ~legacy ctxt loc ty1 ty2 -> + let merge_type_annot tn1 tn2 = + merge_type_annot ~legacy tn1 tn2 + |> record_inconsistent_type_annotations ctxt loc ty1 ty2 + in + let rec help : + type ta tb. + context -> + ta ty -> + tb ty -> + ((ta ty, tb ty) eq * ta ty * context) tzresult = + fun ctxt ty1 ty2 -> help0 ctxt ty1 ty2 |> record_inconsistent ctxt ty1 ty2 + and help0 : + type ta tb. + context -> + ta ty -> + tb ty -> + ((ta ty, tb ty) eq * ta ty * context) tzresult = + fun ctxt ty1 ty2 -> + Gas.consume ctxt Typecheck_costs.merge_cycle + >>? fun ctxt -> + match (ty1, ty2) with + | (Unit_t tn1, Unit_t tn2) -> + merge_type_annot tn1 tn2 + >|? fun tname -> + ((Eq : (ta ty, tb ty) eq), (Unit_t tname : ta ty), ctxt) + | (Int_t tn1, Int_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Int_t tname, ctxt) + | (Nat_t tn1, Nat_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Nat_t tname, ctxt) + | (Key_t tn1, Key_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Key_t tname, ctxt) + | (Key_hash_t tn1, Key_hash_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Key_hash_t tname, ctxt) + | (String_t tn1, String_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, String_t tname, ctxt) + | (Bytes_t tn1, Bytes_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Bytes_t tname, ctxt) + | (Signature_t tn1, Signature_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Signature_t tname, ctxt) + | (Mutez_t tn1, Mutez_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Mutez_t tname, ctxt) + | (Timestamp_t tn1, Timestamp_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Timestamp_t tname, ctxt) + | (Address_t tn1, Address_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Address_t tname, ctxt) + | (Bool_t tn1, Bool_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Bool_t tname, ctxt) + | (Chain_id_t tn1, Chain_id_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Chain_id_t tname, ctxt) + | (Never_t tn1, Never_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Never_t tname, ctxt) + | (Operation_t tn1, Operation_t tn2) -> + merge_type_annot tn1 tn2 >|? fun tname -> (Eq, Operation_t tname, ctxt) + | (Bls12_381_g1_t tn1, Bls12_381_g1_t tn2) -> + merge_type_annot tn1 tn2 + >|? fun tname -> (Eq, Bls12_381_g1_t tname, ctxt) + | (Bls12_381_g2_t tn1, Bls12_381_g2_t tn2) -> + merge_type_annot tn1 tn2 + >|? fun tname -> (Eq, Bls12_381_g2_t tname, ctxt) + | (Bls12_381_fr_t tn1, Bls12_381_fr_t tn2) -> + merge_type_annot tn1 tn2 + >|? fun tname -> (Eq, Bls12_381_fr_t tname, ctxt) + | (Map_t (tal, tar, tn1), Map_t (tbl, tbr, tn2)) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + help ctxt tar tbr + >>? fun (Eq, value, ctxt) -> + merge_comparable_types ~legacy ctxt tal tbl + >|? fun (Eq, tk, ctxt) -> + ((Eq : (ta ty, tb ty) eq), Map_t (tk, value, tname), ctxt) + | (Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2)) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + help ctxt tar tbr + >>? fun (Eq, value, ctxt) -> + merge_comparable_types ~legacy ctxt tal tbl + >|? fun (Eq, tk, ctxt) -> + ((Eq : (ta ty, tb ty) eq), Big_map_t (tk, value, tname), ctxt) + | (Set_t (ea, tn1), Set_t (eb, tn2)) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + merge_comparable_types ~legacy ctxt ea eb + >|? fun (Eq, e, ctxt) -> + ((Eq : (ta ty, tb ty) eq), Set_t (e, tname), ctxt) + | (Ticket_t (ea, tn1), Ticket_t (eb, tn2)) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + merge_comparable_types ~legacy ctxt ea eb + >|? fun (Eq, e, ctxt) -> + ((Eq : (ta ty, tb ty) eq), Ticket_t (e, tname), ctxt) + | ( Pair_t ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1), + Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2) ) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + merge_field_annot ~legacy l_field1 l_field2 + >>? fun l_field -> + merge_field_annot ~legacy r_field1 r_field2 + >>? fun r_field -> + let l_var = merge_var_annot l_var1 l_var2 in + let r_var = merge_var_annot r_var1 r_var2 in + help ctxt tal tbl + >>? fun (Eq, left_ty, ctxt) -> + help ctxt tar tbr + >|? fun (Eq, right_ty, ctxt) -> + ( (Eq : (ta ty, tb ty) eq), + Pair_t ((left_ty, l_field, l_var), (right_ty, r_field, r_var), tname), + ctxt ) + | ( Union_t ((tal, tal_annot), (tar, tar_annot), tn1), + Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2) ) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + merge_field_annot ~legacy tal_annot tbl_annot + >>? fun left_annot -> + merge_field_annot ~legacy tar_annot tbr_annot + >>? fun right_annot -> + help ctxt tal tbl + >>? fun (Eq, left_ty, ctxt) -> + help ctxt tar tbr + >|? fun (Eq, right_ty, ctxt) -> + ( (Eq : (ta ty, tb ty) eq), + Union_t ((left_ty, left_annot), (right_ty, right_annot), tname), + ctxt ) + | (Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2)) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + help ctxt tal tbl + >>? fun (Eq, left_ty, ctxt) -> + help ctxt tar tbr + >|? fun (Eq, right_ty, ctxt) -> + ((Eq : (ta ty, tb ty) eq), Lambda_t (left_ty, right_ty, tname), ctxt) + | (Contract_t (tal, tn1), Contract_t (tbl, tn2)) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + help ctxt tal tbl + >|? fun (Eq, arg_ty, ctxt) -> + ((Eq : (ta ty, tb ty) eq), Contract_t (arg_ty, tname), ctxt) + | (Option_t (tva, tn1), Option_t (tvb, tn2)) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + help ctxt tva tvb + >|? fun (Eq, ty, ctxt) -> + ((Eq : (ta ty, tb ty) eq), Option_t (ty, tname), ctxt) + | (List_t (tva, tn1), List_t (tvb, tn2)) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + help ctxt tva tvb + >|? fun (Eq, ty, ctxt) -> + ((Eq : (ta ty, tb ty) eq), List_t (ty, tname), ctxt) + | (Sapling_state_t (ms1, tn1), Sapling_state_t (ms2, tn2)) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + merge_memo_sizes ms1 ms2 + >|? fun ms -> (Eq, Sapling_state_t (ms, tname), ctxt) + | (Sapling_transaction_t (ms1, tn1), Sapling_transaction_t (ms2, tn2)) -> + merge_type_annot tn1 tn2 + >>? fun tname -> + merge_memo_sizes ms1 ms2 + >|? fun ms -> (Eq, Sapling_transaction_t (ms, tname), ctxt) + | (_, _) -> + serialize_ty_for_error ctxt ty1 + >>? fun (ty1, ctxt) -> + serialize_ty_for_error ctxt ty2 + >>? fun (ty2, _ctxt) -> error (Inconsistent_types (ty1, ty2)) + in + help ctxt ty1 ty2 + [@@coq_axiom "non-top-level mutual recursion"] + +let ty_eq : + type ta tb. + context -> + Script.location -> + ta ty -> + tb ty -> + ((ta ty, tb ty) eq * context) tzresult = + fun ctxt loc ta tb -> + merge_types ~legacy:true ctxt loc ta tb >|? fun (eq, _ty, ctxt) -> (eq, ctxt) + +let merge_stacks : + type ta tb. + legacy:bool -> + Script.location -> + context -> + int -> + ta stack_ty -> + tb stack_ty -> + ((ta stack_ty, tb stack_ty) eq * ta stack_ty * context) tzresult = + fun ~legacy loc -> + let rec help : + type a b. + context -> + int -> + a stack_ty -> + b stack_ty -> + ((a stack_ty, b stack_ty) eq * a stack_ty * context) tzresult = + fun ctxt lvl stack1 stack2 -> + match (stack1, stack2) with + | (Empty_t, Empty_t) -> + ok (Eq, Empty_t, ctxt) + | (Item_t (ty1, rest1, annot1), Item_t (ty2, rest2, annot2)) -> + merge_types ~legacy ctxt loc ty1 ty2 + |> record_trace (Bad_stack_item lvl) + >>? fun (Eq, ty, ctxt) -> + help ctxt (lvl + 1) rest1 rest2 + >|? fun (Eq, rest, ctxt) -> + let annot = merge_var_annot annot1 annot2 in + ((Eq : (a stack_ty, b stack_ty) eq), Item_t (ty, rest, annot), ctxt) + | (_, _) -> + error Bad_stack_length + in + help + +(* ---- Type checker results -------------------------------------------------*) + +type 'bef judgement = + | Typed : ('bef, 'aft) descr -> 'bef judgement + | Failed : { + descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr; + } + -> 'bef judgement + +(* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*) + +type ('t, 'f, 'b) branch = { + branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr; +} +[@@unboxed] + +let merge_branches : + type bef a b. + legacy:bool -> + context -> + int -> + a judgement -> + b judgement -> + (a, b, bef) branch -> + (bef judgement * context) tzresult = + fun ~legacy ctxt loc btr bfr {branch} -> + match (btr, bfr) with + | (Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf)) -> + let unmatched_branches () = + serialize_stack_for_error ctxt aftbt + >>? fun (aftbt, ctxt) -> + serialize_stack_for_error ctxt aftbf + >|? fun (aftbf, _ctxt) -> Unmatched_branches (loc, aftbt, aftbf) + in + record_trace_eval + unmatched_branches + ( merge_stacks ~legacy loc ctxt 1 aftbt aftbf + >|? fun (Eq, merged_stack, ctxt) -> + ( Typed + (branch {dbt with aft = merged_stack} {dbf with aft = merged_stack}), + ctxt ) ) + | (Failed {descr = descrt}, Failed {descr = descrf}) -> + let descr ret = branch (descrt ret) (descrf ret) in + ok (Failed {descr}, ctxt) + | (Typed dbt, Failed {descr = descrf}) -> + ok (Typed (branch dbt (descrf dbt.aft)), ctxt) + | (Failed {descr = descrt}, Typed dbf) -> + ok (Typed (branch (descrt dbf.aft) dbf), ctxt) + +let parse_memo_size (n : (location, _) Micheline.node) : + Sapling.Memo_size.t tzresult = + match n with + | Int (_, z) -> ( + match Sapling.Memo_size.parse_z z with + | Ok _ as ok_memo_size -> + ok_memo_size + | Error msg -> + error @@ Invalid_syntactic_constant (location n, strip_locations n, msg) + ) + | _ -> + error @@ Invalid_kind (location n, [Int_kind], kind n) + +let rec parse_comparable_ty : + context -> Script.node -> (ex_comparable_ty * context) tzresult = + fun ctxt ty -> + Gas.consume ctxt Typecheck_costs.parse_type_cycle + >>? fun ctxt -> + match ty with + | Prim (loc, T_unit, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Unit_key tname), ctxt) + | Prim (loc, T_never, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Never_key tname), ctxt) + | Prim (loc, T_int, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Int_key tname), ctxt) + | Prim (loc, T_nat, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Nat_key tname), ctxt) + | Prim (loc, T_signature, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Signature_key tname), ctxt) + | Prim (loc, T_string, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (String_key tname), ctxt) + | Prim (loc, T_bytes, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Bytes_key tname), ctxt) + | Prim (loc, T_mutez, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Mutez_key tname), ctxt) + | Prim (loc, T_bool, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Bool_key tname), ctxt) + | Prim (loc, T_key_hash, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Key_hash_key tname), ctxt) + | Prim (loc, T_key, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Key_key tname), ctxt) + | Prim (loc, T_timestamp, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Timestamp_key tname), ctxt) + | Prim (loc, T_chain_id, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Chain_id_key tname), ctxt) + | Prim (loc, T_address, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Address_key tname), ctxt) + | Prim + ( loc, + ( ( T_unit + | T_never + | T_int + | T_nat + | T_string + | T_bytes + | T_mutez + | T_bool + | T_key_hash + | T_timestamp + | T_address + | T_chain_id + | T_signature + | T_key ) as prim ), + l, + _ ) -> + error (Invalid_arity (loc, prim, 0, List.length l)) + | Prim (loc, T_pair, left :: right, annot) -> + parse_type_annot loc annot + >>? fun pname -> + extract_field_annot left + >>? fun (left, left_annot) -> + ( match right with + | [right] -> + extract_field_annot right + | right -> + (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) + ok (Prim (loc, T_pair, right, []), None) ) + >>? fun (right, right_annot) -> + parse_comparable_ty ctxt right + >>? fun (Ex_comparable_ty right, ctxt) -> + parse_comparable_ty ctxt left + >|? fun (Ex_comparable_ty left, ctxt) -> + ( Ex_comparable_ty + (Pair_key ((left, left_annot), (right, right_annot), pname)), + ctxt ) + | Prim (loc, T_or, [left; right], annot) -> + parse_type_annot loc annot + >>? fun pname -> + extract_field_annot left + >>? fun (left, left_annot) -> + extract_field_annot right + >>? fun (right, right_annot) -> + parse_comparable_ty ctxt right + >>? fun (Ex_comparable_ty right, ctxt) -> + parse_comparable_ty ctxt left + >|? fun (Ex_comparable_ty left, ctxt) -> + ( Ex_comparable_ty + (Union_key ((left, left_annot), (right, right_annot), pname)), + ctxt ) + | Prim (loc, ((T_pair | T_or) as prim), l, _) -> + error (Invalid_arity (loc, prim, 2, List.length l)) + | Prim (loc, T_option, [t], annot) -> + parse_type_annot loc annot + >>? fun tname -> + parse_comparable_ty ctxt t + >|? fun (Ex_comparable_ty t, ctxt) -> + (Ex_comparable_ty (Option_key (t, tname)), ctxt) + | Prim (loc, T_option, l, _) -> + error (Invalid_arity (loc, T_option, 1, List.length l)) + | Prim + ( loc, + (T_set | T_map | T_list | T_lambda | T_contract | T_operation), + _, + _ ) -> + error (Comparable_type_expected (loc, Micheline.strip_locations ty)) + | expr -> + error + @@ unexpected + expr + [] + Type_namespace + [ T_unit; + T_never; + T_int; + T_nat; + T_string; + T_bytes; + T_mutez; + T_bool; + T_key_hash; + T_timestamp; + T_address; + T_pair; + T_or; + T_option; + T_chain_id; + T_signature; + T_key ] + +and parse_packable_ty : + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = + fun ctxt ~legacy -> + parse_ty + ctxt + ~legacy + ~allow_lazy_storage:false + ~allow_operation:false + ~allow_contract:legacy + ~allow_ticket:false + +and parse_parameter_ty : + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = + fun ctxt ~legacy -> + parse_ty + ctxt + ~legacy + ~allow_lazy_storage:true + ~allow_operation:false + ~allow_contract:true + ~allow_ticket:true + +and parse_normal_storage_ty : + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = + fun ctxt ~legacy -> + parse_ty + ctxt + ~legacy + ~allow_lazy_storage:true + ~allow_operation:false + ~allow_contract:legacy + ~allow_ticket:true + +and parse_any_ty : + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = + fun ctxt ~legacy -> + parse_ty + ctxt + ~legacy + ~allow_lazy_storage:true + ~allow_operation:true + ~allow_contract:true + ~allow_ticket:true + +and parse_ty : + context -> + legacy:bool -> + allow_lazy_storage:bool -> + allow_operation:bool -> + allow_contract:bool -> + allow_ticket:bool -> + Script.node -> + (ex_ty * context) tzresult = + fun ctxt + ~legacy + ~allow_lazy_storage + ~allow_operation + ~allow_contract + ~allow_ticket + node -> + Gas.consume ctxt Typecheck_costs.parse_type_cycle + >>? fun ctxt -> + match node with + | Prim (loc, T_unit, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Unit_t ty_name), ctxt) + | Prim (loc, T_int, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Int_t ty_name), ctxt) + | Prim (loc, T_nat, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Nat_t ty_name), ctxt) + | Prim (loc, T_string, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (String_t ty_name), ctxt) + | Prim (loc, T_bytes, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Bytes_t ty_name), ctxt) + | Prim (loc, T_mutez, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Mutez_t ty_name), ctxt) + | Prim (loc, T_bool, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Bool_t ty_name), ctxt) + | Prim (loc, T_key, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Key_t ty_name), ctxt) + | Prim (loc, T_key_hash, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Key_hash_t ty_name), ctxt) + | Prim (loc, T_timestamp, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Timestamp_t ty_name), ctxt) + | Prim (loc, T_address, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Address_t ty_name), ctxt) + | Prim (loc, T_signature, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Signature_t ty_name), ctxt) + | Prim (loc, T_operation, [], annot) -> + if allow_operation then + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Operation_t ty_name), ctxt) + else error (Unexpected_operation loc) + | Prim (loc, T_chain_id, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Chain_id_t ty_name), ctxt) + | Prim (loc, T_never, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Never_t ty_name), ctxt) + | Prim (loc, T_bls12_381_g1, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Bls12_381_g1_t ty_name), ctxt) + | Prim (loc, T_bls12_381_g2, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Bls12_381_g2_t ty_name), ctxt) + | Prim (loc, T_bls12_381_fr, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Bls12_381_fr_t ty_name), ctxt) + | Prim (loc, T_contract, [utl], annot) -> + if allow_contract then + parse_parameter_ty ctxt ~legacy utl + >>? fun (Ex_ty tl, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Contract_t (tl, ty_name)), ctxt) + else error (Unexpected_contract loc) + | Prim (loc, T_pair, utl :: utr, annot) -> + extract_field_annot utl + >>? fun (utl, left_field) -> + parse_ty + ctxt + ~legacy + ~allow_lazy_storage + ~allow_operation + ~allow_contract + ~allow_ticket + utl + >>? fun (Ex_ty tl, ctxt) -> + ( match utr with + | [utr] -> + extract_field_annot utr + | utr -> + (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) + ok (Prim (loc, T_pair, utr, []), None) ) + >>? fun (utr, right_field) -> + parse_ty + ctxt + ~legacy + ~allow_lazy_storage + ~allow_operation + ~allow_contract + ~allow_ticket + utr + >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> + ok + ( Ex_ty + (Pair_t ((tl, left_field, None), (tr, right_field, None), ty_name)), + ctxt ) + | Prim (loc, T_or, [utl; utr], annot) -> + extract_field_annot utl + >>? fun (utl, left_constr) -> + extract_field_annot utr + >>? fun (utr, right_constr) -> + parse_ty + ctxt + ~legacy + ~allow_lazy_storage + ~allow_operation + ~allow_contract + ~allow_ticket + utl + >>? fun (Ex_ty tl, ctxt) -> + parse_ty + ctxt + ~legacy + ~allow_lazy_storage + ~allow_operation + ~allow_contract + ~allow_ticket + utr + >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> + ok + (Ex_ty (Union_t ((tl, left_constr), (tr, right_constr), ty_name)), ctxt) + | Prim (loc, T_lambda, [uta; utr], annot) -> + parse_any_ty ctxt ~legacy uta + >>? fun (Ex_ty ta, ctxt) -> + parse_any_ty ctxt ~legacy utr + >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Lambda_t (ta, tr, ty_name)), ctxt) + | Prim (loc, T_option, [ut], annot) -> + ( if legacy then + (* legacy semantics with (broken) field annotations *) + extract_field_annot ut + >>? fun (ut, _some_constr) -> + parse_composed_type_annot loc annot + >>? fun (ty_name, _none_constr, _) -> ok (ut, ty_name) + else parse_type_annot loc annot >>? fun ty_name -> ok (ut, ty_name) ) + >>? fun (ut, ty_name) -> + parse_ty + ctxt + ~legacy + ~allow_lazy_storage + ~allow_operation + ~allow_contract + ~allow_ticket + ut + >>? fun (Ex_ty t, ctxt) -> ok (Ex_ty (Option_t (t, ty_name)), ctxt) + | Prim (loc, T_list, [ut], annot) -> + parse_ty + ctxt + ~legacy + ~allow_lazy_storage + ~allow_operation + ~allow_contract + ~allow_ticket + ut + >>? fun (Ex_ty t, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (List_t (t, ty_name)), ctxt) + | Prim (loc, T_ticket, [ut], annot) -> + if allow_ticket then + parse_comparable_ty ctxt ut + >>? fun (Ex_comparable_ty t, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Ticket_t (t, ty_name)), ctxt) + else error (Unexpected_ticket loc) + | Prim (loc, T_set, [ut], annot) -> + parse_comparable_ty ctxt ut + >>? fun (Ex_comparable_ty t, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Set_t (t, ty_name)), ctxt) + | Prim (loc, T_map, [uta; utr], annot) -> + parse_comparable_ty ctxt uta + >>? fun (Ex_comparable_ty ta, ctxt) -> + parse_ty + ctxt + ~legacy + ~allow_lazy_storage + ~allow_operation + ~allow_contract + ~allow_ticket + utr + >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> ok (Ex_ty (Map_t (ta, tr, ty_name)), ctxt) + | Prim (loc, T_sapling_transaction, [memo_size], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + parse_memo_size memo_size + >|? fun memo_size -> + (Ex_ty (Sapling_transaction_t (memo_size, ty_name)), ctxt) + (* + /!\ When adding new lazy storage kinds, be careful to use + [when allow_lazy_storage] /!\ + Lazy storage should not be packable to avoid stealing a lazy storage + from another contract with `PUSH t id` or `UNPACK`. + *) + | Prim (loc, T_big_map, args, annot) when allow_lazy_storage -> + parse_big_map_ty ctxt ~legacy loc args annot + >>? fun (big_map_ty, ctxt) -> ok (big_map_ty, ctxt) + | Prim (loc, T_sapling_state, [memo_size], annot) when allow_lazy_storage -> + parse_type_annot loc annot + >>? fun ty_name -> + parse_memo_size memo_size + >|? fun memo_size -> (Ex_ty (Sapling_state_t (memo_size, ty_name)), ctxt) + | Prim (loc, (T_big_map | T_sapling_state), _, _) -> + error (Unexpected_lazy_storage loc) + | Prim + ( loc, + ( ( T_unit + | T_signature + | T_int + | T_nat + | T_string + | T_bytes + | T_mutez + | T_bool + | T_key + | T_key_hash + | T_timestamp + | T_address + | T_chain_id + | T_operation + | T_never ) as prim ), + l, + _ ) -> + error (Invalid_arity (loc, prim, 0, List.length l)) + | Prim + (loc, ((T_set | T_list | T_option | T_contract | T_ticket) as prim), l, _) + -> + error (Invalid_arity (loc, prim, 1, List.length l)) + | Prim (loc, ((T_pair | T_or | T_map | T_lambda) as prim), l, _) -> + error (Invalid_arity (loc, prim, 2, List.length l)) + | expr -> + error + @@ unexpected + expr + [] + Type_namespace + [ T_pair; + T_or; + T_set; + T_map; + T_list; + T_option; + T_lambda; + T_unit; + T_signature; + T_contract; + T_int; + T_nat; + T_operation; + T_string; + T_bytes; + T_mutez; + T_bool; + T_key; + T_key_hash; + T_timestamp; + T_chain_id; + T_never; + T_bls12_381_g1; + T_bls12_381_g2; + T_bls12_381_fr; + T_ticket ] + +and parse_big_map_ty ctxt ~legacy big_map_loc args map_annot = + Gas.consume ctxt Typecheck_costs.parse_type_cycle + >>? fun ctxt -> + match args with + | [key_ty; value_ty] -> + parse_comparable_ty ctxt key_ty + >>? fun (Ex_comparable_ty key_ty, ctxt) -> + parse_big_map_value_ty ctxt ~legacy value_ty + >>? fun (Ex_ty value_ty, ctxt) -> + parse_type_annot big_map_loc map_annot + >|? fun map_name -> + let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in + (Ex_ty big_map_ty, ctxt) + | args -> + error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) + +and parse_big_map_value_ty ctxt ~legacy value_ty = + parse_ty + ctxt + ~legacy + ~allow_lazy_storage:false + ~allow_operation:false + ~allow_contract:legacy + ~allow_ticket:true + value_ty + +and parse_storage_ty : + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = + fun ctxt ~legacy node -> + match node with + | Prim + ( loc, + T_pair, + [Prim (big_map_loc, T_big_map, args, map_annot); remaining_storage], + storage_annot ) + when legacy -> ( + match storage_annot with + | [] -> + parse_normal_storage_ty ctxt ~legacy node + | [single] + when Compare.Int.(String.length single > 0) + && Compare.Char.(single.[0] = '%') -> + parse_normal_storage_ty ctxt ~legacy node + | _ -> + (* legacy semantics of big maps used the wrong annotation parser *) + Gas.consume ctxt Typecheck_costs.parse_type_cycle + >>? fun ctxt -> + parse_big_map_ty ctxt ~legacy big_map_loc args map_annot + >>? fun (Ex_ty big_map_ty, ctxt) -> + parse_normal_storage_ty ctxt ~legacy remaining_storage + >>? fun (Ex_ty remaining_storage, ctxt) -> + parse_composed_type_annot loc storage_annot + >>? fun (ty_name, map_field, storage_field) -> + ok + ( Ex_ty + (Pair_t + ( (big_map_ty, map_field, None), + (remaining_storage, storage_field, None), + ty_name )), + ctxt ) ) + | _ -> + parse_normal_storage_ty ctxt ~legacy node + +let check_packable ~legacy loc root = + let rec check : type t. t ty -> unit tzresult = function + (* /!\ When adding new lazy storage kinds, be sure to return an error. /!\ + Lazy storage should not be packable. *) + | Big_map_t _ -> + error (Unexpected_lazy_storage loc) + | Sapling_state_t _ -> + error (Unexpected_lazy_storage loc) + | Operation_t _ -> + error (Unexpected_operation loc) + | Unit_t _ -> + ok_unit + | Int_t _ -> + ok_unit + | Nat_t _ -> + ok_unit + | Signature_t _ -> + ok_unit + | String_t _ -> + ok_unit + | Bytes_t _ -> + ok_unit + | Mutez_t _ -> + ok_unit + | Key_hash_t _ -> + ok_unit + | Key_t _ -> + ok_unit + | Timestamp_t _ -> + ok_unit + | Address_t _ -> + ok_unit + | Bool_t _ -> + ok_unit + | Chain_id_t _ -> + ok_unit + | Never_t _ -> + ok_unit + | Set_t (_, _) -> + ok_unit + | Ticket_t _ -> + error (Unexpected_ticket loc) + | Lambda_t (_, _, _) -> + ok_unit + | Bls12_381_g1_t _ -> + ok_unit + | Bls12_381_g2_t _ -> + ok_unit + | Bls12_381_fr_t _ -> + ok_unit + | Pair_t ((l_ty, _, _), (r_ty, _, _), _) -> + check l_ty >>? fun () -> check r_ty + | Union_t ((l_ty, _), (r_ty, _), _) -> + check l_ty >>? fun () -> check r_ty + | Option_t (v_ty, _) -> + check v_ty + | List_t (elt_ty, _) -> + check elt_ty + | Map_t (_, elt_ty, _) -> + check elt_ty + | Contract_t (_, _) when legacy -> + ok_unit + | Contract_t (_, _) -> + error (Unexpected_contract loc) + | Sapling_transaction_t _ -> + ok () + in + check root + +type ('arg, 'storage) code = { + code : (('arg, 'storage) pair, (operation boxed_list, 'storage) pair) lambda; + arg_type : 'arg ty; + storage_type : 'storage ty; + root_name : field_annot option; +} + +type ex_script = Ex_script : ('a, 'c) script -> ex_script + +type ex_code = Ex_code : ('a, 'c) code -> ex_code + +type _ dig_proof_argument = + | Dig_proof_argument : + ( ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness + * ('x ty * var_annot option) + * 'aft stack_ty ) + -> 'bef dig_proof_argument + +type (_, _) dug_proof_argument = + | Dug_proof_argument : + ( ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness + * unit + * 'aft stack_ty ) + -> ('bef, 'x) dug_proof_argument + +type _ dipn_proof_argument = + | Dipn_proof_argument : + ( ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness + * (context * ('fbef, 'faft) descr) + * 'aft stack_ty ) + -> 'bef dipn_proof_argument + +type _ dropn_proof_argument = + | Dropn_proof_argument : + ( ('rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness + * 'rest stack_ty + * 'aft stack_ty ) + -> 'bef dropn_proof_argument + +type 'before comb_proof_argument = + | Comb_proof_argument : + ('before, 'after) comb_gadt_witness * 'after stack_ty + -> 'before comb_proof_argument + +type 'before uncomb_proof_argument = + | Uncomb_proof_argument : + ('before, 'after) uncomb_gadt_witness * 'after stack_ty + -> 'before uncomb_proof_argument + +type 'before comb_get_proof_argument = + | Comb_get_proof_argument : + ('before, 'after) comb_get_gadt_witness * 'after ty + -> 'before comb_get_proof_argument + +type ('rest, 'before) comb_set_proof_argument = + | Comb_set_proof_argument : + ('rest, 'before, 'after) comb_set_gadt_witness * 'after ty + -> ('rest, 'before) comb_set_proof_argument + +type 'before dup_n_proof_argument = + | Dup_n_proof_argument : + ('before, 'a) dup_n_gadt_witness * 'a ty + -> 'before dup_n_proof_argument + +let find_entrypoint (type full) (full : full ty) ~root_name entrypoint = + let rec find_entrypoint : + type t. t ty -> string -> (Script.node -> Script.node) * ex_ty = + fun t entrypoint -> + match t with + | Union_t ((tl, al), (tr, ar), _) -> ( + if + match al with + | None -> + false + | Some (Field_annot l) -> + Compare.String.(l = entrypoint) + then ((fun e -> Prim (0, D_Left, [e], [])), Ex_ty tl) + else if + match ar with + | None -> + false + | Some (Field_annot r) -> + Compare.String.(r = entrypoint) + then ((fun e -> Prim (0, D_Right, [e], [])), Ex_ty tr) + else + try + let (f, t) = find_entrypoint tl entrypoint in + ((fun e -> Prim (0, D_Left, [f e], [])), t) + with Not_found -> + let (f, t) = find_entrypoint tr entrypoint in + ((fun e -> Prim (0, D_Right, [f e], [])), t) ) + | _ -> + raise Not_found + in + let entrypoint = + if Compare.String.(entrypoint = "") then "default" else entrypoint + in + if Compare.Int.(String.length entrypoint > 31) then + error (Entrypoint_name_too_long entrypoint) + else + match root_name with + | Some (Field_annot root_name) when Compare.String.(entrypoint = root_name) + -> + ok ((fun e -> e), Ex_ty full) + | _ -> ( + try ok (find_entrypoint full entrypoint) + with Not_found -> ( + match entrypoint with + | "default" -> + ok ((fun e -> e), Ex_ty full) + | _ -> + error (No_such_entrypoint entrypoint) ) ) + +let find_entrypoint_for_type (type full exp) ~legacy ~(full : full ty) + ~(expected : exp ty) ~root_name entrypoint ctxt loc : + (context * string * exp ty) tzresult = + match (entrypoint, root_name) with + | ("default", Some (Field_annot "root")) -> ( + match find_entrypoint full ~root_name entrypoint with + | Error _ as err -> + err + | Ok (_, Ex_ty ty) -> ( + match merge_types ~legacy ctxt loc ty expected with + | Ok (Eq, ty, ctxt) -> + ok (ctxt, "default", ty) + | Error _ -> + merge_types ~legacy ctxt loc full expected + >>? fun (Eq, full, ctxt) -> ok (ctxt, "root", (full : exp ty)) ) ) + | _ -> + find_entrypoint full ~root_name entrypoint + >>? fun (_, Ex_ty ty) -> + merge_types ~legacy ctxt loc ty expected + >>? fun (Eq, ty, ctxt) -> ok (ctxt, entrypoint, (ty : exp ty)) + +module Entrypoints = Set.Make (String) + +exception Duplicate of string + +exception Too_long of string + +let well_formed_entrypoints (type full) (full : full ty) ~root_name = + let merge path annot (type t) (ty : t ty) reachable + ((first_unreachable, all) as acc) = + match annot with + | None | Some (Field_annot "") -> ( + if reachable then acc + else + match ty with + | Union_t _ -> + acc + | _ -> ( + match first_unreachable with + | None -> + (Some (List.rev path), all) + | Some _ -> + acc ) ) + | Some (Field_annot name) -> + if Compare.Int.(String.length name > 31) then raise (Too_long name) + else if Entrypoints.mem name all then raise (Duplicate name) + else (first_unreachable, Entrypoints.add name all) + in + let rec check : + type t. + t ty -> + prim list -> + bool -> + prim list option * Entrypoints.t -> + prim list option * Entrypoints.t = + fun t path reachable acc -> + match t with + | Union_t ((tl, al), (tr, ar), _) -> + let acc = merge (D_Left :: path) al tl reachable acc in + let acc = merge (D_Right :: path) ar tr reachable acc in + let acc = + check + tl + (D_Left :: path) + (match al with Some _ -> true | None -> reachable) + acc + in + check + tr + (D_Right :: path) + (match ar with Some _ -> true | None -> reachable) + acc + | _ -> + acc + in + try + let (init, reachable) = + match root_name with + | None | Some (Field_annot "") -> + (Entrypoints.empty, false) + | Some (Field_annot name) -> + (Entrypoints.singleton name, true) + in + let (first_unreachable, all) = check full [] reachable (None, init) in + if not (Entrypoints.mem "default" all) then ok_unit + else + match first_unreachable with + | None -> + ok_unit + | Some path -> + error (Unreachable_entrypoint path) + with + | Duplicate name -> + error (Duplicate_entrypoint name) + | Too_long name -> + error (Entrypoint_name_too_long name) + +let parse_uint ~nb_bits = + assert (Compare.Int.(nb_bits >= 0 && nb_bits <= 30)) ; + let max_int = (1 lsl nb_bits) - 1 in + let max_z = Z.of_int max_int in + function + | Micheline.Int (_, n) when Compare.Z.(Z.zero <= n) && Compare.Z.(n <= max_z) + -> + ok (Z.to_int n) + | node -> + error + @@ Invalid_syntactic_constant + ( location node, + strip_locations node, + "a positive " ^ string_of_int nb_bits + ^ "-bit integer (between 0 and " ^ string_of_int max_int ^ ")" ) + +let parse_uint10 = parse_uint ~nb_bits:10 + +let parse_uint11 = parse_uint ~nb_bits:11 + +(* This type is used to: + - serialize and deserialize tickets when they are stored or transferred, + - type the READ_TICKET instruction. *) +let opened_ticket_type ty = + Pair_key + ( (Address_key None, None), + (Pair_key ((ty, None), (Nat_key None, None), None), None), + None ) + +(* -- parse data of primitive types -- *) + +let parse_unit ctxt ~legacy = function + | Prim (loc, D_Unit, [], annot) -> + (if legacy then ok_unit else error_unexpected_annot loc annot) + >>? fun () -> + Gas.consume ctxt Typecheck_costs.unit >|? fun ctxt -> ((), ctxt) + | Prim (loc, D_Unit, l, _) -> + error @@ Invalid_arity (loc, D_Unit, 0, List.length l) + | expr -> + error @@ unexpected expr [] Constant_namespace [D_Unit] + +let parse_bool ctxt ~legacy = function + | Prim (loc, D_True, [], annot) -> + (if legacy then ok_unit else error_unexpected_annot loc annot) + >>? fun () -> + Gas.consume ctxt Typecheck_costs.bool >|? fun ctxt -> (true, ctxt) + | Prim (loc, D_False, [], annot) -> + (if legacy then ok_unit else error_unexpected_annot loc annot) + >>? fun () -> + Gas.consume ctxt Typecheck_costs.bool >|? fun ctxt -> (false, ctxt) + | Prim (loc, ((D_True | D_False) as c), l, _) -> + error @@ Invalid_arity (loc, c, 0, List.length l) + | expr -> + error @@ unexpected expr [] Constant_namespace [D_True; D_False] + +let parse_string ctxt = function + | String (loc, v) as expr -> + Gas.consume ctxt (Typecheck_costs.check_printable v) + >>? fun ctxt -> + let rec check_printable_ascii i = + if Compare.Int.(i < 0) then true + else + match v.[i] with + | '\n' | '\x20' .. '\x7E' -> + check_printable_ascii (i - 1) + | _ -> + false + in + if check_printable_ascii (String.length v - 1) then ok (v, ctxt) + else + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a printable ascii string") + | expr -> + error @@ Invalid_kind (location expr, [String_kind], kind expr) + +let parse_bytes ctxt = function + | Bytes (_, v) -> + ok (v, ctxt) + | expr -> + error @@ Invalid_kind (location expr, [Bytes_kind], kind expr) + +let parse_int ctxt = function + | Int (_, v) -> + ok (Script_int.of_zint v, ctxt) + | expr -> + error @@ Invalid_kind (location expr, [Int_kind], kind expr) + +let parse_nat ctxt = function + | Int (loc, v) as expr -> ( + let v = Script_int.of_zint v in + match Script_int.is_nat v with + | Some nat -> + ok (nat, ctxt) + | None -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a non-negative integer") ) + | expr -> + error @@ Invalid_kind (location expr, [Int_kind], kind expr) + +let parse_mutez ctxt = function + | Int (loc, v) as expr -> ( + try + match Tez.of_mutez (Z.to_int64 v) with + | None -> + raise Exit + | Some tez -> + ok (tez, ctxt) + with _ -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a valid mutez amount") ) + | expr -> + error @@ Invalid_kind (location expr, [Int_kind], kind expr) + +let parse_timestamp ctxt = function + | Int (_, v) (* As unparsed with [Optimized] or out of bounds [Readable]. *) + -> + ok (Script_timestamp.of_zint v, ctxt) + | String (loc, s) as expr (* As unparsed with [Readable]. *) -> ( + Gas.consume ctxt Typecheck_costs.timestamp_readable + >>? fun ctxt -> + match Script_timestamp.of_string s with + | Some v -> + ok (v, ctxt) + | None -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a valid timestamp") ) + | expr -> + error @@ Invalid_kind (location expr, [String_kind; Int_kind], kind expr) + +let parse_key ctxt = function + | Bytes (loc, bytes) as expr -> ( + (* As unparsed with [Optimized]. *) + Gas.consume ctxt Typecheck_costs.public_key_optimized + >>? fun ctxt -> + match + Data_encoding.Binary.of_bytes Signature.Public_key.encoding bytes + with + | Some k -> + ok (k, ctxt) + | None -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a valid public key") ) + | String (loc, s) as expr -> ( + (* As unparsed with [Readable]. *) + Gas.consume ctxt Typecheck_costs.public_key_readable + >>? fun ctxt -> + match Signature.Public_key.of_b58check_opt s with + | Some k -> + ok (k, ctxt) + | None -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a valid public key") ) + | expr -> + error + @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr) + +let parse_key_hash ctxt = function + | Bytes (loc, bytes) as expr -> ( + (* As unparsed with [Optimized]. *) + Gas.consume ctxt Typecheck_costs.key_hash_optimized + >>? fun ctxt -> + match + Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes + with + | Some k -> + ok (k, ctxt) + | None -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a valid key hash") ) + | String (loc, s) as expr (* As unparsed with [Readable]. *) -> ( + Gas.consume ctxt Typecheck_costs.key_hash_readable + >>? fun ctxt -> + match Signature.Public_key_hash.of_b58check_opt s with + | Some k -> + ok (k, ctxt) + | None -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a valid key hash") ) + | expr -> + error + @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr) + +let parse_signature ctxt = function + | Bytes (loc, bytes) as expr (* As unparsed with [Optimized]. *) -> ( + Gas.consume ctxt Typecheck_costs.signature_optimized + >>? fun ctxt -> + match Data_encoding.Binary.of_bytes Signature.encoding bytes with + | Some k -> + ok (k, ctxt) + | None -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a valid signature") ) + | String (loc, s) as expr (* As unparsed with [Readable]. *) -> ( + Gas.consume ctxt Typecheck_costs.signature_readable + >>? fun ctxt -> + match Signature.of_b58check_opt s with + | Some s -> + ok (s, ctxt) + | None -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a valid signature") ) + | expr -> + error + @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr) + +let parse_chain_id ctxt = function + | Bytes (loc, bytes) as expr -> ( + Gas.consume ctxt Typecheck_costs.chain_id_optimized + >>? fun ctxt -> + match Data_encoding.Binary.of_bytes Chain_id.encoding bytes with + | Some k -> + ok (k, ctxt) + | None -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a valid chain id") ) + | String (loc, s) as expr -> ( + Gas.consume ctxt Typecheck_costs.chain_id_readable + >>? fun ctxt -> + match Chain_id.of_b58check_opt s with + | Some s -> + ok (s, ctxt) + | None -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a valid chain id") ) + | expr -> + error + @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr) + +let parse_address ctxt = function + | Bytes (loc, bytes) as expr (* As unparsed with [Optimized]. *) -> ( + Gas.consume ctxt Typecheck_costs.contract + >>? fun ctxt -> + match + Data_encoding.Binary.of_bytes + Data_encoding.(tup2 Contract.encoding Variable.string) + bytes + with + | Some (c, entrypoint) -> ( + if Compare.Int.(String.length entrypoint > 31) then + error (Entrypoint_name_too_long entrypoint) + else + match entrypoint with + | "" -> + ok ((c, "default"), ctxt) + | "default" -> + error (Unexpected_annotation loc) + | name -> + ok ((c, name), ctxt) ) + | None -> + error + @@ Invalid_syntactic_constant + (loc, strip_locations expr, "a valid address") ) + | String (loc, s) (* As unparsed with [Readable]. *) -> + Gas.consume ctxt Typecheck_costs.contract + >>? fun ctxt -> + ( match String.index_opt s '%' with + | None -> + ok (s, "default") + | Some pos -> ( + let len = String.length s - pos - 1 in + let name = String.sub s (pos + 1) len in + if Compare.Int.(len > 31) then error (Entrypoint_name_too_long name) + else + match (String.sub s 0 pos, name) with + | (addr, "") -> + ok (addr, "default") + | (_, "default") -> + error @@ Unexpected_annotation loc + | addr_and_name -> + ok addr_and_name ) ) + >>? fun (addr, entrypoint) -> + Contract.of_b58check addr >|? fun c -> ((c, entrypoint), ctxt) + | expr -> + error + @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr) + +let parse_never expr = error @@ Invalid_never_expr (location expr) + +(* -- parse data of complex types -- *) + +type ('ty, 'depth) comb_witness = + | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness + | Comb_Any : (_, _) comb_witness + +let parse_pair (type r) parse_l parse_r ctxt ~legacy + (r_comb_witness : (r, unit -> _) comb_witness) expr = + let parse_comb loc l rs = + parse_l ctxt l + >>=? fun (l, ctxt) -> + ( match (rs, r_comb_witness) with + | ([r], _) -> + ok r + | ([], _) -> + error @@ Invalid_arity (loc, D_Pair, 2, 1) + | (_ :: _, Comb_Pair _) -> + (* Unfold [Pair x1 ... xn] as [Pair x1 (Pair x2 ... xn-1 xn))] + for type [pair ta (pair tb1 tb2)] and n >= 3 only *) + ok (Prim (loc, D_Pair, rs, [])) + | _ -> + error @@ Invalid_arity (loc, D_Pair, 2, 1 + List.length rs) ) + >>?= fun r -> parse_r ctxt r >|=? fun (r, ctxt) -> ((l, r), ctxt) + in + match expr with + | Prim (loc, D_Pair, l :: rs, annot) -> + (if legacy then ok_unit else error_unexpected_annot loc annot) + >>?= fun () -> parse_comb loc l rs + | Prim (loc, D_Pair, l, _) -> + fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) + (* Unfold [{x1; ...; xn}] as [Pair x1 x2 ... xn-1 xn] for n >= 2 *) + | Seq (loc, l :: (_ :: _ as rs)) -> + parse_comb loc l rs + | Seq (loc, l) -> + fail @@ Invalid_seq_arity (loc, 2, List.length l) + | expr -> + fail @@ unexpected expr [] Constant_namespace [D_Pair] + +let parse_union parse_l parse_r ctxt ~legacy = function + | Prim (loc, D_Left, [v], annot) -> + (if legacy then ok_unit else error_unexpected_annot loc annot) + >>?= fun () -> parse_l ctxt v >|=? fun (v, ctxt) -> (L v, ctxt) + | Prim (loc, D_Left, l, _) -> + fail @@ Invalid_arity (loc, D_Left, 1, List.length l) + | Prim (loc, D_Right, [v], annot) -> + (if legacy then ok_unit else error_unexpected_annot loc annot) + >>?= fun () -> parse_r ctxt v >|=? fun (v, ctxt) -> (R v, ctxt) + | Prim (loc, D_Right, l, _) -> + fail @@ Invalid_arity (loc, D_Right, 1, List.length l) + | expr -> + fail @@ unexpected expr [] Constant_namespace [D_Left; D_Right] + +let parse_option parse_v ctxt ~legacy = function + | Prim (loc, D_Some, [v], annot) -> + (if legacy then ok_unit else error_unexpected_annot loc annot) + >>?= fun () -> parse_v ctxt v >|=? fun (v, ctxt) -> (Some v, ctxt) + | Prim (loc, D_Some, l, _) -> + fail @@ Invalid_arity (loc, D_Some, 1, List.length l) + | Prim (loc, D_None, [], annot) -> + Lwt.return + ( (if legacy then ok_unit else error_unexpected_annot loc annot) + >|? fun () -> (None, ctxt) ) + | Prim (loc, D_None, l, _) -> + fail @@ Invalid_arity (loc, D_None, 0, List.length l) + | expr -> + fail @@ unexpected expr [] Constant_namespace [D_Some; D_None] + +(* -- parse data of comparable types -- *) + +let comparable_comb_witness1 : + type t. t comparable_ty -> (t, unit -> unit) comb_witness = function + | Pair_key _ -> + Comb_Pair Comb_Any + | _ -> + Comb_Any + +let rec parse_comparable_data : + type a. + ?type_logger:type_logger -> + context -> + a comparable_ty -> + Script.node -> + (a * context) tzresult Lwt.t = + fun ?type_logger ctxt ty script_data -> + (* No need for stack_depth here. Unlike [parse_data], + [parse_comparable_data] doesn't call [parse_returning]. + The stack depth is bounded by the type depth, bounded by 1024. *) + let parse_data_error () = + serialize_ty_for_error ctxt (ty_of_comparable_ty ty) + >|? fun (ty, _ctxt) -> + Invalid_constant (location script_data, strip_locations script_data, ty) + in + let traced_no_lwt body = record_trace_eval parse_data_error body in + let traced body = + trace_eval (fun () -> Lwt.return @@ parse_data_error ()) body + in + Gas.consume ctxt Typecheck_costs.parse_data_cycle + (* We could have a smaller cost but let's keep it consistent with + [parse_data] for now. *) + >>?= fun ctxt -> + let legacy = false in + match (ty, script_data) with + | (Unit_key _, expr) -> + Lwt.return @@ traced_no_lwt + @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) + | (Bool_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_bool ctxt ~legacy expr + | (String_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_string ctxt expr + | (Bytes_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_bytes ctxt expr + | (Int_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_int ctxt expr + | (Nat_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_nat ctxt expr + | (Mutez_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_mutez ctxt expr + | (Timestamp_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_timestamp ctxt expr + | (Key_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_key ctxt expr + | (Key_hash_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_key_hash ctxt expr + | (Signature_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_signature ctxt expr + | (Chain_id_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_chain_id ctxt expr + | (Address_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_address ctxt expr + | (Pair_key ((tl, _), (tr, _), _), expr) -> + let r_witness = comparable_comb_witness1 tr in + let parse_l ctxt v = parse_comparable_data ?type_logger ctxt tl v in + let parse_r ctxt v = parse_comparable_data ?type_logger ctxt tr v in + traced @@ parse_pair parse_l parse_r ctxt ~legacy r_witness expr + | (Union_key ((tl, _), (tr, _), _), expr) -> + let parse_l ctxt v = parse_comparable_data ?type_logger ctxt tl v in + let parse_r ctxt v = parse_comparable_data ?type_logger ctxt tr v in + traced @@ parse_union parse_l parse_r ctxt ~legacy expr + | (Option_key (t, _), expr) -> + let parse_v ctxt v = parse_comparable_data ?type_logger ctxt t v in + traced @@ parse_option parse_v ctxt ~legacy expr + | (Never_key _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_never expr + +(* -- parse data of any type -- *) + +let comb_witness1 : type t. t ty -> (t, unit -> unit) comb_witness = function + | Pair_t _ -> + Comb_Pair Comb_Any + | _ -> + Comb_Any + +(* + Some values, such as operations, tickets, or big map ids, are used only + internally and are not allowed to be forged by users. + In [parse_data], [allow_forged] should be [false] for: + - PUSH + - UNPACK + - user-provided script parameters + - storage on origination + And [true] for: + - internal calls parameters + - storage after origination +*) + +let rec parse_data : + type a. + ?type_logger:type_logger -> + stack_depth:int -> + context -> + legacy:bool -> + allow_forged:bool -> + a ty -> + Script.node -> + (a * context) tzresult Lwt.t = + fun ?type_logger ~stack_depth ctxt ~legacy ~allow_forged ty script_data -> + Gas.consume ctxt Typecheck_costs.parse_data_cycle + >>?= fun ctxt -> + let non_terminal_recursion ?type_logger ctxt ~legacy ty script_data = + if Compare.Int.(stack_depth > 10_000) then + fail Typechecking_too_many_recursive_calls + else + parse_data + ?type_logger + ~stack_depth:(stack_depth + 1) + ctxt + ~legacy + ~allow_forged + ty + script_data + in + let parse_data_error () = + serialize_ty_for_error ctxt ty + >|? fun (ty, _ctxt) -> + Invalid_constant (location script_data, strip_locations script_data, ty) + in + let fail_parse_data () = parse_data_error () >>?= fail in + let traced_no_lwt body = record_trace_eval parse_data_error body in + let traced body = + trace_eval (fun () -> Lwt.return @@ parse_data_error ()) body + in + let traced_fail err = Lwt.return @@ traced_no_lwt (error err) in + let parse_items ?type_logger ctxt expr key_type value_type items item_wrapper + = + fold_left_s + (fun (last_value, map, ctxt) item -> + match item with + | Prim (loc, D_Elt, [k; v], annot) -> + (if legacy then ok_unit else error_unexpected_annot loc annot) + >>?= fun () -> + parse_comparable_data ?type_logger ctxt key_type k + >>=? fun (k, ctxt) -> + non_terminal_recursion ?type_logger ctxt ~legacy value_type v + >>=? fun (v, ctxt) -> + Lwt.return + ( ( match last_value with + | Some value -> + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.compare + key_type + value + k) + >>? fun ctxt -> + let c = compare_comparable key_type value k in + if Compare.Int.(0 <= c) then + if Compare.Int.(0 = c) then + error (Duplicate_map_keys (loc, strip_locations expr)) + else + error (Unordered_map_keys (loc, strip_locations expr)) + else ok ctxt + | None -> + ok ctxt ) + >>? fun ctxt -> + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.map_update k map) + >|? fun ctxt -> + (Some k, map_update k (Some (item_wrapper v)) map, ctxt) ) + | Prim (loc, D_Elt, l, _) -> + fail @@ Invalid_arity (loc, D_Elt, 2, List.length l) + | Prim (loc, name, _, _) -> + fail @@ Invalid_primitive (loc, [D_Elt], name) + | Int _ | String _ | Bytes _ | Seq _ -> + fail_parse_data ()) + (None, empty_map key_type, ctxt) + items + |> traced + >|=? fun (_, items, ctxt) -> (items, ctxt) + in + match (ty, script_data) with + | (Unit_t _, expr) -> + Lwt.return @@ traced_no_lwt + @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) + | (Bool_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_bool ctxt ~legacy expr + | (String_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_string ctxt expr + | (Bytes_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_bytes ctxt expr + | (Int_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_int ctxt expr + | (Nat_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_nat ctxt expr + | (Mutez_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_mutez ctxt expr + | (Timestamp_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_timestamp ctxt expr + | (Key_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_key ctxt expr + | (Key_hash_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_key_hash ctxt expr + | (Signature_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_signature ctxt expr + | (Operation_t _, _) -> + (* operations cannot appear in parameters or storage, + the protocol should never parse the bytes of an operation *) + assert false + | (Chain_id_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_chain_id ctxt expr + | (Address_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_address ctxt expr + | (Contract_t (ty, _), expr) -> + traced + ( parse_address ctxt expr + >>?= fun ((c, entrypoint), ctxt) -> + let loc = location expr in + parse_contract ~legacy ctxt loc ty c ~entrypoint + >|=? fun (ctxt, _) -> ((ty, (c, entrypoint)), ctxt) ) + (* Pairs *) + | (Pair_t ((tl, _, _), (tr, _, _), _), expr) -> + let r_witness = comb_witness1 tr in + let parse_l ctxt v = + non_terminal_recursion ?type_logger ctxt ~legacy tl v + in + let parse_r ctxt v = + non_terminal_recursion ?type_logger ctxt ~legacy tr v + in + traced @@ parse_pair parse_l parse_r ctxt ~legacy r_witness expr + (* Unions *) + | (Union_t ((tl, _), (tr, _), _), expr) -> + let parse_l ctxt v = + non_terminal_recursion ?type_logger ctxt ~legacy tl v + in + let parse_r ctxt v = + non_terminal_recursion ?type_logger ctxt ~legacy tr v + in + traced @@ parse_union parse_l parse_r ctxt ~legacy expr + (* Lambdas *) + | (Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr)) -> + traced + @@ parse_returning + Lambda + ?type_logger + ~stack_depth + ctxt + ~legacy + (ta, Some (Var_annot "@arg")) + tr + script_instr + | (Lambda_t _, expr) -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (* Options *) + | (Option_t (t, _), expr) -> + let parse_v ctxt v = + non_terminal_recursion ?type_logger ctxt ~legacy t v + in + traced @@ parse_option parse_v ctxt ~legacy expr + (* Lists *) + | (List_t (t, _ty_name), Seq (_loc, items)) -> + traced + @@ fold_right_s + (fun v (rest, ctxt) -> + non_terminal_recursion ?type_logger ctxt ~legacy t v + >|=? fun (v, ctxt) -> (list_cons v rest, ctxt)) + items + (list_empty, ctxt) + | (List_t _, expr) -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (* Tickets *) + | (Ticket_t (t, _ty_name), expr) -> + if allow_forged then + parse_comparable_data ?type_logger ctxt (opened_ticket_type t) expr + >|=? fun ((ticketer, (contents, amount)), ctxt) -> + ({ticketer; contents; amount}, ctxt) + else traced_fail (Unexpected_forged_value (location expr)) + (* Sets *) + | (Set_t (t, _ty_name), (Seq (loc, vs) as expr)) -> + traced + @@ fold_left_s + (fun (last_value, set, ctxt) v -> + parse_comparable_data ?type_logger ctxt t v + >>=? fun (v, ctxt) -> + Lwt.return + ( ( match last_value with + | Some value -> + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.compare t value v) + >>? fun ctxt -> + let c = compare_comparable t value v in + if Compare.Int.(0 <= c) then + if Compare.Int.(0 = c) then + error + (Duplicate_set_values (loc, strip_locations expr)) + else + error + (Unordered_set_values (loc, strip_locations expr)) + else ok ctxt + | None -> + ok ctxt ) + >>? fun ctxt -> + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.set_update v set) + >|? fun ctxt -> (Some v, set_update v true set, ctxt) )) + (None, empty_set t, ctxt) + vs + >|=? fun (_, set, ctxt) -> (set, ctxt) + | (Set_t _, expr) -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (* Maps *) + | (Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr)) -> + parse_items ?type_logger ctxt expr tk tv vs (fun x -> x) + | (Map_t _, expr) -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + | (Big_map_t (tk, tv, _ty_name), expr) -> + ( match expr with + | Int (loc, id) -> + return (Some (id, loc), empty_map tk, ctxt) + | Seq (_, vs) -> + parse_items ?type_logger ctxt expr tk tv vs (fun x -> Some x) + >|=? fun (diff, ctxt) -> (None, diff, ctxt) + | Prim (loc, D_Pair, [Int (loc_id, id); Seq (_, vs)], annot) -> + error_unexpected_annot loc annot + >>?= fun () -> + let tv_opt = Option_t (tv, None) in + parse_items ?type_logger ctxt expr tk tv_opt vs (fun x -> x) + >|=? fun (diff, ctxt) -> (Some (id, loc_id), diff, ctxt) + | Prim (_, D_Pair, [Int _; expr], _) -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + | Prim (_, D_Pair, [expr; _], _) -> + traced_fail (Invalid_kind (location expr, [Int_kind], kind expr)) + | Prim (loc, D_Pair, l, _) -> + traced_fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) + | _ -> + traced_fail + (unexpected expr [Seq_kind; Int_kind] Constant_namespace [D_Pair]) + ) + >>=? fun (id_opt, diff, ctxt) -> + ( match id_opt with + | None -> + return @@ (None, ctxt) + | Some (id, loc) -> + if allow_forged then + let id = Big_map.Id.parse_z id in + Big_map.exists ctxt id + >>=? function + | (_, None) -> + traced_fail (Invalid_big_map (loc, id)) + | (ctxt, Some (btk, btv)) -> + Lwt.return + ( parse_comparable_ty ctxt (Micheline.root btk) + >>? fun (Ex_comparable_ty btk, ctxt) -> + parse_big_map_value_ty ctxt ~legacy (Micheline.root btv) + >>? fun (Ex_ty btv, ctxt) -> + comparable_ty_eq ctxt tk btk + >>? fun (Eq, ctxt) -> + ty_eq ctxt loc tv btv >>? fun (Eq, ctxt) -> ok (Some id, ctxt) + ) + else traced_fail (Unexpected_forged_value loc) ) + >|=? fun (id, ctxt) -> ({id; diff; key_type = tk; value_type = tv}, ctxt) + | (Never_t _, expr) -> + Lwt.return @@ traced_no_lwt @@ parse_never expr + (* Bls12_381 types *) + | (Bls12_381_g1_t _, Bytes (_, bs)) -> ( + Gas.consume ctxt Typecheck_costs.bls12_381_g1 + >>?= fun ctxt -> + match Bls12_381.G1.of_bytes_opt bs with + | Some pt -> + return (pt, ctxt) + | None -> + fail_parse_data () ) + | (Bls12_381_g1_t _, expr) -> + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + | (Bls12_381_g2_t _, Bytes (_, bs)) -> ( + Gas.consume ctxt Typecheck_costs.bls12_381_g2 + >>?= fun ctxt -> + match Bls12_381.G2.of_bytes_opt bs with + | Some pt -> + return (pt, ctxt) + | None -> + fail_parse_data () ) + | (Bls12_381_g2_t _, expr) -> + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + | (Bls12_381_fr_t _, Bytes (_, bs)) -> ( + Gas.consume ctxt Typecheck_costs.bls12_381_fr + >>?= fun ctxt -> + match Bls12_381.Fr.of_bytes_opt bs with + | Some pt -> + return (pt, ctxt) + | None -> + fail_parse_data () ) + | (Bls12_381_fr_t _, Int (_, v)) -> + Gas.consume ctxt Typecheck_costs.bls12_381_fr + >>?= fun ctxt -> return (Bls12_381.Fr.of_z v, ctxt) + | (Bls12_381_fr_t _, expr) -> + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (* + /!\ When adding new lazy storage kinds, you may want to guard the parsing + of identifiers with [allow_forged]. + *) + (* Sapling *) + | (Sapling_transaction_t (memo_size, _), Bytes (_, bytes)) -> ( + match Data_encoding.Binary.of_bytes Sapling.transaction_encoding bytes with + | Some transaction -> ( + match Sapling.transaction_get_memo_size transaction with + | None -> + return (transaction, ctxt) + | Some transac_memo_size -> + Lwt.return + ( merge_memo_sizes memo_size transac_memo_size + >|? fun _ms -> (transaction, ctxt) ) ) + | None -> + fail_parse_data () ) + | (Sapling_transaction_t _, expr) -> + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + | (Sapling_state_t (memo_size, _), Int (loc, id)) -> + if allow_forged then + let id = Sapling.Id.parse_z id in + Sapling.state_from_id ctxt id + >>=? fun (state, ctxt) -> + Lwt.return + ( traced_no_lwt @@ merge_memo_sizes memo_size state.Sapling.memo_size + >|? fun _memo_size -> (state, ctxt) ) + else traced_fail (Unexpected_forged_value loc) + | (Sapling_state_t (memo_size, _), Seq (_, [])) -> + return (Sapling.empty_state ~memo_size (), ctxt) + | (Sapling_state_t _, expr) -> + (* Do not allow to input diffs as they are untrusted and may not be the + result of a verify_update. *) + traced_fail + (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) + +and parse_returning : + type arg ret. + ?type_logger:type_logger -> + stack_depth:int -> + tc_context -> + context -> + legacy:bool -> + arg ty * var_annot option -> + ret ty -> + Script.node -> + ((arg, ret) lambda * context) tzresult Lwt.t = + fun ?type_logger + ~stack_depth + tc_context + ctxt + ~legacy + (arg, arg_annot) + ret + script_instr -> + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + ~stack_depth:(stack_depth + 1) + script_instr + (Item_t (arg, Empty_t, arg_annot)) + >>=? function + | (Typed ({loc; aft = Item_t (ty, Empty_t, _) as stack_ty; _} as descr), ctxt) + -> + Lwt.return + @@ record_trace_eval + (fun () -> + serialize_ty_for_error ctxt ret + >>? fun (ret, ctxt) -> + serialize_stack_for_error ctxt stack_ty + >|? fun (stack_ty, _ctxt) -> Bad_return (loc, stack_ty, ret)) + ( merge_types ~legacy ctxt loc ty ret + >|? fun (Eq, _ret, ctxt) -> + ((Lam (descr, script_instr) : (arg, ret) lambda), ctxt) ) + | (Typed {loc; aft = stack_ty; _}, ctxt) -> + Lwt.return + ( serialize_ty_for_error ctxt ret + >>? fun (ret, ctxt) -> + serialize_stack_for_error ctxt stack_ty + >>? fun (stack_ty, _ctxt) -> error (Bad_return (loc, stack_ty, ret)) ) + | (Failed {descr}, ctxt) -> + return + ( ( Lam (descr (Item_t (ret, Empty_t, None)), script_instr) + : (arg, ret) lambda ), + ctxt ) + +and parse_instr : + type bef. + ?type_logger:type_logger -> + stack_depth:int -> + tc_context -> + context -> + legacy:bool -> + Script.node -> + bef stack_ty -> + (bef judgement * context) tzresult Lwt.t = + fun ?type_logger ~stack_depth tc_context ctxt ~legacy script_instr stack_ty -> + let check_item_ty (type a b) ctxt (exp : a ty) (got : b ty) loc name n m : + ((a, b) eq * a ty * context) tzresult = + record_trace_eval (fun () -> + serialize_stack_for_error ctxt stack_ty + >|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty)) + @@ record_trace + (Bad_stack_item n) + ( merge_types ~legacy ctxt loc exp got + >>? fun (Eq, ty, ctxt) -> ok ((Eq : (a, b) eq), (ty : a ty), ctxt) ) + in + let log_stack ctxt loc stack_ty aft = + match (type_logger, script_instr) with + | (None, _) | (Some _, (Seq (-1, _) | Int _ | String _ | Bytes _)) -> + ok_unit + | (Some log, (Prim _ | Seq _)) -> + (* Unparsing for logging done in an unlimited context as this + is used only by the client and not the protocol *) + let ctxt = Gas.set_unlimited ctxt in + unparse_stack ctxt stack_ty + >>? fun (stack_ty, _) -> + unparse_stack ctxt aft >|? fun (aft, _) -> log loc stack_ty aft ; () + in + let return_no_lwt : + type bef. context -> bef judgement -> (bef judgement * context) tzresult + = + fun ctxt judgement -> + match judgement with + | Typed {instr; loc; aft; _} -> + let maximum_type_size = Constants.michelson_maximum_type_size ctxt in + let type_size = + type_size_of_stack_head + aft + ~up_to:(number_of_generated_growing_types instr) + in + if Compare.Int.(type_size > maximum_type_size) then + error (Type_too_large (loc, type_size, maximum_type_size)) + else ok (judgement, ctxt) + | Failed _ -> + ok (judgement, ctxt) + in + let return : + type bef. + context -> bef judgement -> (bef judgement * context) tzresult Lwt.t = + fun ctxt judgement -> Lwt.return @@ return_no_lwt ctxt judgement + in + let typed_no_lwt ctxt loc instr aft = + log_stack ctxt loc stack_ty aft + >>? fun () -> return_no_lwt ctxt (Typed {loc; instr; bef = stack_ty; aft}) + in + let typed ctxt loc instr aft = + Lwt.return @@ typed_no_lwt ctxt loc instr aft + in + Gas.consume ctxt Typecheck_costs.parse_instr_cycle + >>?= fun ctxt -> + let non_terminal_recursion ?type_logger tc_context ctxt ~legacy script_instr + stack_ty = + if Compare.Int.(stack_depth > 10000) then + fail Typechecking_too_many_recursive_calls + else + parse_instr + ?type_logger + tc_context + ctxt + ~stack_depth:(stack_depth + 1) + ~legacy + script_instr + stack_ty + in + match (script_instr, stack_ty) with + (* stack ops *) + | (Prim (loc, I_DROP, [], annot), Item_t (_, rest, _)) -> + ( error_unexpected_annot loc annot >>?= fun () -> typed ctxt loc Drop rest + : (bef judgement * context) tzresult Lwt.t ) + | (Prim (loc, I_DROP, [n], result_annot), whole_stack) -> + parse_uint10 n + >>?= fun whole_n -> + Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) + >>?= fun ctxt -> + let rec make_proof_argument : + type tstk. int -> tstk stack_ty -> tstk dropn_proof_argument tzresult + = + fun n stk -> + match (Compare.Int.(n = 0), stk) with + | (true, rest) -> + ok @@ Dropn_proof_argument (Rest, rest, rest) + | (false, Item_t (v, rest, annot)) -> + make_proof_argument (n - 1) rest + >|? fun (Dropn_proof_argument (n', stack_after_drops, aft')) -> + Dropn_proof_argument + (Prefix n', stack_after_drops, Item_t (v, aft', annot)) + | (_, _) -> + serialize_stack_for_error ctxt whole_stack + >>? fun (whole_stack, _ctxt) -> + error (Bad_stack (loc, I_DROP, whole_n, whole_stack)) + in + error_unexpected_annot loc result_annot + >>?= fun () -> + make_proof_argument whole_n whole_stack + >>?= fun (Dropn_proof_argument (n', stack_after_drops, _aft)) -> + typed ctxt loc (Dropn (whole_n, n')) stack_after_drops + | (Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _) -> + (* Technically, the arities 0 and 1 are allowed but the error only mentions 1. + However, DROP is equivalent to DROP 1 so hinting at an arity of 1 makes sense. *) + fail (Invalid_arity (loc, I_DROP, 1, List.length l)) + | (Prim (loc, I_DUP, [], annot), Item_t (v, rest, stack_annot)) -> + parse_var_annot loc annot ~default:stack_annot + >>?= fun annot -> + record_trace_eval + (fun () -> + serialize_ty_for_error ctxt v + >|? fun (t, _ctxt) -> Non_dupable_type (loc, t)) + (check_dupable_ty ctxt loc v) + >>?= fun ctxt -> + typed ctxt loc Dup (Item_t (v, Item_t (v, rest, stack_annot), annot)) + | (Prim (loc, I_DUP, [n], v_annot), stack_ty) -> + parse_var_annot loc v_annot + >>?= fun annot -> + let rec make_proof_argument : + type before. + int -> before stack_ty -> before dup_n_proof_argument tzresult = + fun n (stack_ty : before stack_ty) -> + match (n, stack_ty) with + | (1, Item_t (hd_ty, _, _)) -> + ok @@ Dup_n_proof_argument (Dup_n_zero, hd_ty) + | (n, Item_t (_, tl_ty, _)) -> + make_proof_argument (n - 1) tl_ty + >|? fun (Dup_n_proof_argument (dup_n_witness, b_ty)) -> + Dup_n_proof_argument (Dup_n_succ dup_n_witness, b_ty) + | _ -> + serialize_stack_for_error ctxt stack_ty + >>? fun (whole_stack, _ctxt) -> + error (Bad_stack (loc, I_DUP, 1, whole_stack)) + in + parse_uint10 n + >>?= fun n -> + Gas.consume ctxt (Typecheck_costs.proof_argument n) + >>?= fun ctxt -> + error_unless (Compare.Int.( > ) n 0) (Dup_n_bad_argument loc) + >>?= fun () -> + record_trace (Dup_n_bad_stack loc) (make_proof_argument n stack_ty) + >>?= fun (Dup_n_proof_argument (witness, after_ty)) -> + record_trace_eval + (fun () -> + serialize_ty_for_error ctxt after_ty + >|? fun (t, _ctxt) -> Non_dupable_type (loc, t)) + (check_dupable_ty ctxt loc after_ty) + >>?= fun ctxt -> + typed ctxt loc (Dup_n (n, witness)) (Item_t (after_ty, stack_ty, annot)) + | (Prim (loc, I_DIG, [n], result_annot), stack) -> + let rec make_proof_argument : + type tstk. int -> tstk stack_ty -> tstk dig_proof_argument tzresult = + fun n stk -> + match (Compare.Int.(n = 0), stk) with + | (true, Item_t (v, rest, annot)) -> + ok @@ Dig_proof_argument (Rest, (v, annot), rest) + | (false, Item_t (v, rest, annot)) -> + make_proof_argument (n - 1) rest + >|? fun (Dig_proof_argument (n', (x, xv), aft')) -> + Dig_proof_argument (Prefix n', (x, xv), Item_t (v, aft', annot)) + | (_, _) -> + serialize_stack_for_error ctxt stack + >>? fun (whole_stack, _ctxt) -> + error (Bad_stack (loc, I_DIG, 1, whole_stack)) + in + parse_uint10 n + >>?= fun n -> + Gas.consume ctxt (Typecheck_costs.proof_argument n) + >>?= fun ctxt -> + error_unexpected_annot loc result_annot + >>?= fun () -> + make_proof_argument n stack + >>?= fun (Dig_proof_argument (n', (x, stack_annot), aft)) -> + typed ctxt loc (Dig (n, n')) (Item_t (x, aft, stack_annot)) + | (Prim (loc, I_DIG, (([] | _ :: _ :: _) as l), _), _) -> + fail (Invalid_arity (loc, I_DIG, 1, List.length l)) + | (Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack, stack_annot)) + -> + parse_uint10 n + >>?= fun whole_n -> + Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) + >>?= fun ctxt -> + let rec make_proof_argument : + type tstk x. + int -> + x ty -> + var_annot option -> + tstk stack_ty -> + (tstk, x) dug_proof_argument tzresult = + fun n x stack_annot stk -> + match (Compare.Int.(n = 0), stk) with + | (true, rest) -> + ok @@ Dug_proof_argument (Rest, (), Item_t (x, rest, stack_annot)) + | (false, Item_t (v, rest, annot)) -> + make_proof_argument (n - 1) x stack_annot rest + >|? fun (Dug_proof_argument (n', (), aft')) -> + Dug_proof_argument (Prefix n', (), Item_t (v, aft', annot)) + | (_, _) -> + serialize_stack_for_error ctxt whole_stack + >>? fun (whole_stack, _ctxt) -> + error (Bad_stack (loc, I_DUG, whole_n, whole_stack)) + in + error_unexpected_annot loc result_annot + >>?= fun () -> + make_proof_argument whole_n x stack_annot whole_stack + >>?= fun (Dug_proof_argument (n', (), aft)) -> + typed ctxt loc (Dug (whole_n, n')) aft + | (Prim (loc, I_DUG, [_], result_annot), (Empty_t as stack)) -> + Lwt.return + ( error_unexpected_annot loc result_annot + >>? fun () -> + serialize_stack_for_error ctxt stack + >>? fun (stack, _ctxt) -> error (Bad_stack (loc, I_DUG, 1, stack)) ) + | (Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _) -> + fail (Invalid_arity (loc, I_DUG, 1, List.length l)) + | ( Prim (loc, I_SWAP, [], annot), + Item_t (v, Item_t (w, rest, stack_annot), cur_top_annot) ) -> + error_unexpected_annot loc annot + >>?= fun () -> + typed + ctxt + loc + Swap + (Item_t (w, Item_t (v, rest, cur_top_annot), stack_annot)) + | (Prim (loc, I_PUSH, [t; d], annot), stack) -> + parse_var_annot loc annot + >>?= fun annot -> + parse_packable_ty ctxt ~legacy t + >>?= fun (Ex_ty t, ctxt) -> + parse_data + ?type_logger + ~stack_depth:(stack_depth + 1) + ctxt + ~legacy + ~allow_forged:false + t + d + >>=? fun (v, ctxt) -> typed ctxt loc (Const v) (Item_t (t, stack, annot)) + | (Prim (loc, I_UNIT, [], annot), stack) -> + parse_var_type_annot loc annot + >>?= fun (annot, ty_name) -> + typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot)) + (* options *) + | (Prim (loc, I_SOME, [], annot), Item_t (t, rest, _)) -> + parse_var_type_annot loc annot + >>?= fun (annot, ty_name) -> + typed ctxt loc Cons_some (Item_t (Option_t (t, ty_name), rest, annot)) + | (Prim (loc, I_NONE, [t], annot), stack) -> + parse_any_ty ctxt ~legacy t + >>?= fun (Ex_ty t, ctxt) -> + parse_var_type_annot loc annot + >>?= fun (annot, ty_name) -> + typed + ctxt + loc + (Cons_none t) + (Item_t (Option_t (t, ty_name), stack, annot)) + | ( Prim (loc, I_IF_NONE, [bt; bf], annot), + (Item_t (Option_t (t, _), rest, option_annot) as bef) ) -> + check_kind [Seq_kind] bt + >>?= fun () -> + check_kind [Seq_kind] bf + >>?= fun () -> + error_unexpected_annot loc annot + >>?= fun () -> + let annot = gen_access_annot option_annot default_some_annot in + non_terminal_recursion ?type_logger tc_context ctxt ~legacy bt rest + >>=? fun (btr, ctxt) -> + non_terminal_recursion + ?type_logger + tc_context + ctxt + ~legacy + bf + (Item_t (t, rest, annot)) + >>=? fun (bfr, ctxt) -> + let branch ibt ibf = + {loc; instr = If_none (ibt, ibf); bef; aft = ibt.aft} + in + merge_branches ~legacy ctxt loc btr bfr {branch} + >>?= fun (judgement, ctxt) -> return ctxt judgement + (* pairs *) + | ( Prim (loc, I_PAIR, [], annot), + Item_t (a, Item_t (b, rest, snd_annot), fst_annot) ) -> + parse_constr_annot + loc + annot + ~if_special_first:(var_to_field_annot fst_annot) + ~if_special_second:(var_to_field_annot snd_annot) + >>?= fun (annot, ty_name, l_field, r_field) -> + typed + ctxt + loc + Cons_pair + (Item_t + ( Pair_t ((a, l_field, fst_annot), (b, r_field, snd_annot), ty_name), + rest, + annot )) + | (Prim (loc, I_PAIR, [n], annot), stack_ty) -> + parse_var_annot loc annot + >>?= fun annot -> + let rec make_proof_argument : + type before. + int -> + before stack_ty -> + (before comb_proof_argument * var_annot option) tzresult = + fun n stack_ty -> + match (n, stack_ty) with + | (1, Item_t (a_ty, tl_ty, a_annot_opt)) -> + ok + ( Comb_proof_argument (Comb_one, Item_t (a_ty, tl_ty, annot)), + a_annot_opt ) + | (n, Item_t (a_ty, tl_ty, prop_annot_opt)) -> + make_proof_argument (n - 1) tl_ty + >|? fun ( Comb_proof_argument + (comb_witness, Item_t (b_ty, tl_ty', annot)), + b_annot_opt ) -> + let prop_annot_opt' = var_to_field_annot prop_annot_opt in + let b_prop_annot_opt = var_to_field_annot b_annot_opt in + let pair_t = + Pair_t + ( (a_ty, prop_annot_opt', None), + (b_ty, b_prop_annot_opt, None), + None ) + in + ( Comb_proof_argument + (Comb_succ comb_witness, Item_t (pair_t, tl_ty', annot)), + None ) + | _ -> + serialize_stack_for_error ctxt stack_ty + >>? fun (whole_stack, _ctxt) -> + error (Bad_stack (loc, I_PAIR, 1, whole_stack)) + in + parse_uint10 n + >>?= fun n -> + Gas.consume ctxt (Typecheck_costs.proof_argument n) + >>?= fun ctxt -> + error_unless (Compare.Int.( > ) n 1) (Pair_bad_argument loc) + >>?= fun () -> + make_proof_argument n stack_ty + >>?= fun (Comb_proof_argument (witness, after_ty), _none) -> + typed ctxt loc (Comb (n, witness)) after_ty + | (Prim (loc, I_UNPAIR, [n], annot), stack_ty) -> + error_unexpected_annot loc annot + >>?= fun () -> + let rec make_proof_argument : + type before. + int -> before stack_ty -> before uncomb_proof_argument tzresult = + fun n stack_ty -> + match (n, stack_ty) with + | (1, Item_t (a_ty, tl_ty, annot)) -> + ok + @@ Uncomb_proof_argument (Uncomb_one, Item_t (a_ty, tl_ty, annot)) + | ( n, + Item_t + ( Pair_t ((a_ty, field_opt, _), (b_ty, b_field_opt, _), _), + tl_ty, + _ ) ) -> + let b_annot = Script_ir_annot.field_to_var_annot b_field_opt in + make_proof_argument (n - 1) (Item_t (b_ty, tl_ty, b_annot)) + >|? fun (Uncomb_proof_argument (uncomb_witness, after_ty)) -> + Uncomb_proof_argument + ( Uncomb_succ uncomb_witness, + Item_t + (a_ty, after_ty, Script_ir_annot.field_to_var_annot field_opt) + ) + | _ -> + serialize_stack_for_error ctxt stack_ty + >>? fun (whole_stack, _ctxt) -> + error (Bad_stack (loc, I_UNPAIR, 1, whole_stack)) + in + parse_uint10 n + >>?= fun n -> + Gas.consume ctxt (Typecheck_costs.proof_argument n) + >>?= fun ctxt -> + error_unless (Compare.Int.( > ) n 1) (Unpair_bad_argument loc) + >>?= fun () -> + make_proof_argument n stack_ty + >>?= fun (Uncomb_proof_argument (witness, after_ty)) -> + typed ctxt loc (Uncomb (n, witness)) after_ty + | (Prim (loc, I_GET, [n], annot), Item_t (comb_ty, rest_ty, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + let rec make_proof_argument : + type before. + int -> before ty -> before comb_get_proof_argument tzresult = + fun n ty -> + match (n, ty) with + | (0, value_ty) -> + ok @@ Comb_get_proof_argument (Comb_get_zero, value_ty) + | (1, Pair_t ((hd_ty, _at1, _at2), _, _annot)) -> + ok @@ Comb_get_proof_argument (Comb_get_one, hd_ty) + | (n, Pair_t (_, (tl_ty, _bt1, _bt2), _annot)) -> + make_proof_argument (n - 2) tl_ty + >|? fun (Comb_get_proof_argument (comb_get_left_witness, ty')) -> + Comb_get_proof_argument + (Comb_get_plus_two comb_get_left_witness, ty') + | _ -> + serialize_stack_for_error ctxt stack_ty + >>? fun (whole_stack, _ctxt) -> + error (Bad_stack (loc, I_GET, 1, whole_stack)) + in + parse_uint11 n + >>?= fun n -> + Gas.consume ctxt (Typecheck_costs.proof_argument n) + >>?= fun ctxt -> + make_proof_argument n comb_ty + >>?= fun (Comb_get_proof_argument (witness, ty')) -> + let after_stack_ty = Item_t (ty', rest_ty, annot) in + typed ctxt loc (Comb_get (n, witness)) after_stack_ty + | ( Prim (loc, I_UPDATE, [n], annot), + Item_t (value_ty, Item_t (comb_ty, rest_ty, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + let rec make_proof_argument : + type value before. + int -> + value ty -> + before ty -> + (value, before) comb_set_proof_argument tzresult = + fun n value_ty ty -> + match (n, ty) with + | (0, _) -> + ok @@ Comb_set_proof_argument (Comb_set_zero, value_ty) + | (1, Pair_t ((_hd_ty, at1, at2), (tl_ty, bt1, bt2), annot)) -> + let after_ty = + Pair_t ((value_ty, at1, at2), (tl_ty, bt1, bt2), annot) + in + ok @@ Comb_set_proof_argument (Comb_set_one, after_ty) + | (n, Pair_t ((hd_ty, at1, at2), (tl_ty, bt1, bt2), annot)) -> + make_proof_argument (n - 2) value_ty tl_ty + >|? fun (Comb_set_proof_argument (comb_set_left_witness, tl_ty')) -> + let after_ty = + Pair_t ((hd_ty, at1, at2), (tl_ty', bt1, bt2), annot) + in + Comb_set_proof_argument + (Comb_set_plus_two comb_set_left_witness, after_ty) + | _ -> + serialize_stack_for_error ctxt stack_ty + >>? fun (whole_stack, _ctxt) -> + error (Bad_stack (loc, I_UPDATE, 2, whole_stack)) + in + parse_uint11 n + >>?= fun n -> + Gas.consume ctxt (Typecheck_costs.proof_argument n) + >>?= fun ctxt -> + make_proof_argument n value_ty comb_ty + >>?= fun (Comb_set_proof_argument (witness, after_ty)) -> + let after_stack_ty = Item_t (after_ty, rest_ty, annot) in + typed ctxt loc (Comb_set (n, witness)) after_stack_ty + | ( Prim (loc, I_UNPAIR, [], annot), + Item_t + ( Pair_t + ( (a, expected_field_annot_a, a_annot), + (b, expected_field_annot_b, b_annot), + _ ), + rest, + pair_annot ) ) -> + parse_unpair_annot + loc + annot + ~pair_annot + ~value_annot_car:a_annot + ~value_annot_cdr:b_annot + ~field_name_car:expected_field_annot_a + ~field_name_cdr:expected_field_annot_b + >>?= fun (annot_a, annot_b, field_a, field_b) -> + check_correct_field field_a expected_field_annot_a + >>?= fun () -> + check_correct_field field_b expected_field_annot_b + >>?= fun () -> + typed ctxt loc Unpair (Item_t (a, Item_t (b, rest, annot_b), annot_a)) + | ( Prim (loc, I_CAR, [], annot), + Item_t + (Pair_t ((a, expected_field_annot, a_annot), _, _), rest, pair_annot) + ) -> + parse_destr_annot + loc + annot + ~pair_annot + ~value_annot:a_annot + ~field_name:expected_field_annot + ~default_accessor:default_car_annot + >>?= fun (annot, field_annot) -> + check_correct_field field_annot expected_field_annot + >>?= fun () -> typed ctxt loc Car (Item_t (a, rest, annot)) + | ( Prim (loc, I_CDR, [], annot), + Item_t + (Pair_t (_, (b, expected_field_annot, b_annot), _), rest, pair_annot) + ) -> + parse_destr_annot + loc + annot + ~pair_annot + ~value_annot:b_annot + ~field_name:expected_field_annot + ~default_accessor:default_cdr_annot + >>?= fun (annot, field_annot) -> + check_correct_field field_annot expected_field_annot + >>?= fun () -> typed ctxt loc Cdr (Item_t (b, rest, annot)) + (* unions *) + | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest, stack_annot)) -> + parse_any_ty ctxt ~legacy tr + >>?= fun (Ex_ty tr, ctxt) -> + parse_constr_annot + loc + annot + ~if_special_first:(var_to_field_annot stack_annot) + >>?= fun (annot, tname, l_field, r_field) -> + typed + ctxt + loc + Cons_left + (Item_t (Union_t ((tl, l_field), (tr, r_field), tname), rest, annot)) + | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest, stack_annot)) -> + parse_any_ty ctxt ~legacy tl + >>?= fun (Ex_ty tl, ctxt) -> + parse_constr_annot + loc + annot + ~if_special_second:(var_to_field_annot stack_annot) + >>?= fun (annot, tname, l_field, r_field) -> + typed + ctxt + loc + Cons_right + (Item_t (Union_t ((tl, l_field), (tr, r_field), tname), rest, annot)) + | ( Prim (loc, I_IF_LEFT, [bt; bf], annot), + ( Item_t (Union_t ((tl, l_field), (tr, r_field), _), rest, union_annot) + as bef ) ) -> + check_kind [Seq_kind] bt + >>?= fun () -> + check_kind [Seq_kind] bf + >>?= fun () -> + error_unexpected_annot loc annot + >>?= fun () -> + let left_annot = + gen_access_annot union_annot l_field ~default:default_left_annot + in + let right_annot = + gen_access_annot union_annot r_field ~default:default_right_annot + in + non_terminal_recursion + ?type_logger + tc_context + ctxt + ~legacy + bt + (Item_t (tl, rest, left_annot)) + >>=? fun (btr, ctxt) -> + non_terminal_recursion + ?type_logger + tc_context + ctxt + ~legacy + bf + (Item_t (tr, rest, right_annot)) + >>=? fun (bfr, ctxt) -> + let branch ibt ibf = + {loc; instr = If_left (ibt, ibf); bef; aft = ibt.aft} + in + merge_branches ~legacy ctxt loc btr bfr {branch} + >>?= fun (judgement, ctxt) -> return ctxt judgement + (* lists *) + | (Prim (loc, I_NIL, [t], annot), stack) -> + parse_any_ty ctxt ~legacy t + >>?= fun (Ex_ty t, ctxt) -> + parse_var_type_annot loc annot + >>?= fun (annot, ty_name) -> + typed ctxt loc Nil (Item_t (List_t (t, ty_name), stack, annot)) + | ( Prim (loc, I_CONS, [], annot), + Item_t (tv, Item_t (List_t (t, ty_name), rest, _), _) ) -> + check_item_ty ctxt tv t loc I_CONS 1 2 + >>?= fun (Eq, t, ctxt) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Cons_list (Item_t (List_t (t, ty_name), rest, annot)) + | ( Prim (loc, I_IF_CONS, [bt; bf], annot), + (Item_t (List_t (t, ty_name), rest, list_annot) as bef) ) -> + check_kind [Seq_kind] bt + >>?= fun () -> + check_kind [Seq_kind] bf + >>?= fun () -> + error_unexpected_annot loc annot + >>?= fun () -> + let hd_annot = gen_access_annot list_annot default_hd_annot in + let tl_annot = gen_access_annot list_annot default_tl_annot in + non_terminal_recursion + ?type_logger + tc_context + ctxt + ~legacy + bt + (Item_t (t, Item_t (List_t (t, ty_name), rest, tl_annot), hd_annot)) + >>=? fun (btr, ctxt) -> + non_terminal_recursion ?type_logger tc_context ctxt ~legacy bf rest + >>=? fun (bfr, ctxt) -> + let branch ibt ibf = + {loc; instr = If_cons (ibt, ibf); bef; aft = ibt.aft} + in + merge_branches ~legacy ctxt loc btr bfr {branch} + >>?= fun (judgement, ctxt) -> return ctxt judgement + | (Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest, _)) -> + parse_var_type_annot loc annot + >>?= fun (annot, tname) -> + typed ctxt loc List_size (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_MAP, [body], annot), + Item_t (List_t (elt, _), starting_rest, list_annot) ) -> ( + check_kind [Seq_kind] body + >>?= fun () -> + parse_var_type_annot loc annot + >>?= fun (ret_annot, list_ty_name) -> + let elt_annot = gen_access_annot list_annot default_elt_annot in + non_terminal_recursion + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t (elt, starting_rest, elt_annot)) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft = Item_t (ret, rest, _); _} as ibody) -> + let invalid_map_body () = + serialize_stack_for_error ctxt ibody.aft + >|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft) + in + Lwt.return + @@ record_trace_eval + invalid_map_body + ( merge_stacks ~legacy loc ctxt 1 rest starting_rest + >>? fun (Eq, rest, ctxt) -> + typed_no_lwt + ctxt + loc + (List_map ibody) + (Item_t (List_t (ret, list_ty_name), rest, ret_annot)) ) + | Typed {aft; _} -> + Lwt.return + ( serialize_stack_for_error ctxt aft + >>? fun (aft, _ctxt) -> error (Invalid_map_body (loc, aft)) ) + | Failed _ -> + fail (Invalid_map_block_fail loc) ) + | ( Prim (loc, I_ITER, [body], annot), + Item_t (List_t (elt, _), rest, list_annot) ) -> ( + check_kind [Seq_kind] body + >>?= fun () -> + error_unexpected_annot loc annot + >>?= fun () -> + let elt_annot = gen_access_annot list_annot default_elt_annot in + non_terminal_recursion + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t (elt, rest, elt_annot)) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft; _} as ibody) -> + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft + >>? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest + >|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft) + in + Lwt.return + @@ record_trace_eval + invalid_iter_body + ( merge_stacks ~legacy loc ctxt 1 aft rest + >>? fun (Eq, rest, ctxt) -> + typed_no_lwt ctxt loc (List_iter ibody) rest ) + | Failed {descr} -> + typed ctxt loc (List_iter (descr rest)) rest ) + (* sets *) + | (Prim (loc, I_EMPTY_SET, [t], annot), rest) -> + parse_comparable_ty ctxt t + >>?= fun (Ex_comparable_ty t, ctxt) -> + parse_var_type_annot loc annot + >>?= fun (annot, tname) -> + typed ctxt loc (Empty_set t) (Item_t (Set_t (t, tname), rest, annot)) + | ( Prim (loc, I_ITER, [body], annot), + Item_t (Set_t (comp_elt, _), rest, set_annot) ) -> ( + check_kind [Seq_kind] body + >>?= fun () -> + error_unexpected_annot loc annot + >>?= fun () -> + let elt_annot = gen_access_annot set_annot default_elt_annot in + let elt = ty_of_comparable_ty comp_elt in + non_terminal_recursion + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t (elt, rest, elt_annot)) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft; _} as ibody) -> + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft + >>? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest + >|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft) + in + Lwt.return + @@ record_trace_eval + invalid_iter_body + ( merge_stacks ~legacy loc ctxt 1 aft rest + >>? fun (Eq, rest, ctxt) -> + typed_no_lwt ctxt loc (Set_iter ibody) rest ) + | Failed {descr} -> + typed ctxt loc (Set_iter (descr rest)) rest ) + | ( Prim (loc, I_MEM, [], annot), + Item_t (v, Item_t (Set_t (elt, _), rest, _), _) ) -> + let elt = ty_of_comparable_ty elt in + parse_var_type_annot loc annot + >>?= fun (annot, tname) -> + check_item_ty ctxt elt v loc I_MEM 1 2 + >>?= fun (Eq, _, ctxt) -> + typed ctxt loc Set_mem (Item_t (Bool_t tname, rest, annot)) + | ( Prim (loc, I_UPDATE, [], annot), + Item_t + ( v, + Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest, set_annot), _), + _ ) ) -> + check_item_ty ctxt (ty_of_comparable_ty elt) v loc I_UPDATE 1 3 + >>?= fun (Eq, _, ctxt) -> + parse_var_annot loc annot ~default:set_annot + >>?= fun annot -> + typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) + | (Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Set_size (Item_t (Nat_t None, rest, annot)) + (* maps *) + | (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) -> + parse_comparable_ty ctxt tk + >>?= fun (Ex_comparable_ty tk, ctxt) -> + parse_any_ty ctxt ~legacy tv + >>?= fun (Ex_ty tv, ctxt) -> + parse_var_type_annot loc annot + >>?= fun (annot, ty_name) -> + typed + ctxt + loc + (Empty_map (tk, tv)) + (Item_t (Map_t (tk, tv, ty_name), stack, annot)) + | ( Prim (loc, I_MAP, [body], annot), + Item_t (Map_t (ck, elt, _), starting_rest, _map_annot) ) -> ( + let k = ty_of_comparable_ty ck in + check_kind [Seq_kind] body + >>?= fun () -> + parse_var_type_annot loc annot + >>?= fun (ret_annot, ty_name) -> + let k_name = field_to_var_annot default_key_annot in + let e_name = field_to_var_annot default_elt_annot in + non_terminal_recursion + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t + ( Pair_t ((k, None, k_name), (elt, None, e_name), None), + starting_rest, + None )) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft = Item_t (ret, rest, _); _} as ibody) -> + let invalid_map_body () = + serialize_stack_for_error ctxt ibody.aft + >|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft) + in + Lwt.return + @@ record_trace_eval + invalid_map_body + ( merge_stacks ~legacy loc ctxt 1 rest starting_rest + >>? fun (Eq, rest, ctxt) -> + typed_no_lwt + ctxt + loc + (Map_map ibody) + (Item_t (Map_t (ck, ret, ty_name), rest, ret_annot)) ) + | Typed {aft; _} -> + Lwt.return + ( serialize_stack_for_error ctxt aft + >>? fun (aft, _ctxt) -> error (Invalid_map_body (loc, aft)) ) + | Failed _ -> + fail (Invalid_map_block_fail loc) ) + | ( Prim (loc, I_ITER, [body], annot), + Item_t (Map_t (comp_elt, element_ty, _), rest, _map_annot) ) -> ( + check_kind [Seq_kind] body + >>?= fun () -> + error_unexpected_annot loc annot + >>?= fun () -> + let k_name = field_to_var_annot default_key_annot in + let e_name = field_to_var_annot default_elt_annot in + let key = ty_of_comparable_ty comp_elt in + non_terminal_recursion + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t + ( Pair_t ((key, None, k_name), (element_ty, None, e_name), None), + rest, + None )) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft; _} as ibody) -> + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft + >>? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest + >|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft) + in + Lwt.return + @@ record_trace_eval + invalid_iter_body + ( merge_stacks ~legacy loc ctxt 1 aft rest + >>? fun (Eq, rest, ctxt) -> + typed_no_lwt ctxt loc (Map_iter ibody) rest ) + | Failed {descr} -> + typed ctxt loc (Map_iter (descr rest)) rest ) + | ( Prim (loc, I_MEM, [], annot), + Item_t (vk, Item_t (Map_t (ck, _, _), rest, _), _) ) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_MEM 1 2 + >>?= fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Map_mem (Item_t (Bool_t None, rest, annot)) + | ( Prim (loc, I_GET, [], annot), + Item_t (vk, Item_t (Map_t (ck, elt, _), rest, _), _) ) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_GET 1 2 + >>?= fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Map_get (Item_t (Option_t (elt, None), rest, annot)) + | ( Prim (loc, I_UPDATE, [], annot), + Item_t + ( vk, + Item_t + ( Option_t (vv, _), + Item_t (Map_t (ck, v, map_name), rest, map_annot), + _ ), + _ ) ) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_UPDATE 1 3 + >>?= fun (Eq, _, ctxt) -> + check_item_ty ctxt vv v loc I_UPDATE 2 3 + >>?= fun (Eq, v, ctxt) -> + parse_var_annot loc annot ~default:map_annot + >>?= fun annot -> + typed ctxt loc Map_update (Item_t (Map_t (ck, v, map_name), rest, annot)) + | ( Prim (loc, I_GET_AND_UPDATE, [], annot), + Item_t + ( vk, + Item_t + ( Option_t (vv, vname), + Item_t (Map_t (ck, v, map_name), rest, map_annot), + v_annot ), + _ ) ) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_GET_AND_UPDATE 1 3 + >>?= fun (Eq, _, ctxt) -> + check_item_ty ctxt vv v loc I_GET_AND_UPDATE 2 3 + >>?= fun (Eq, v, ctxt) -> + parse_var_annot loc annot ~default:map_annot + >>?= fun annot -> + typed + ctxt + loc + Map_get_and_update + (Item_t + ( Option_t (vv, vname), + Item_t (Map_t (ck, v, map_name), rest, annot), + v_annot )) + | (Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _), rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Map_size (Item_t (Nat_t None, rest, annot)) + (* big_map *) + | (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) -> + parse_comparable_ty ctxt tk + >>?= fun (Ex_comparable_ty tk, ctxt) -> + parse_big_map_value_ty ctxt ~legacy tv + >>?= fun (Ex_ty tv, ctxt) -> + parse_var_type_annot loc annot + >>?= fun (annot, ty_name) -> + typed + ctxt + loc + (Empty_big_map (tk, tv)) + (Item_t (Big_map_t (tk, tv, ty_name), stack, annot)) + | ( Prim (loc, I_MEM, [], annot), + Item_t (set_key, Item_t (Big_map_t (map_key, _, _), rest, _), _) ) -> + let k = ty_of_comparable_ty map_key in + check_item_ty ctxt set_key k loc I_MEM 1 2 + >>?= fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Big_map_mem (Item_t (Bool_t None, rest, annot)) + | ( Prim (loc, I_GET, [], annot), + Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest, _), _) ) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_GET 1 2 + >>?= fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Big_map_get (Item_t (Option_t (elt, None), rest, annot)) + | ( Prim (loc, I_UPDATE, [], annot), + Item_t + ( set_key, + Item_t + ( Option_t (set_value, _), + Item_t (Big_map_t (map_key, map_value, map_name), rest, map_annot), + _ ), + _ ) ) -> + let k = ty_of_comparable_ty map_key in + check_item_ty ctxt set_key k loc I_UPDATE 1 3 + >>?= fun (Eq, _, ctxt) -> + check_item_ty ctxt set_value map_value loc I_UPDATE 2 3 + >>?= fun (Eq, map_value, ctxt) -> + parse_var_annot loc annot ~default:map_annot + >>?= fun annot -> + typed + ctxt + loc + Big_map_update + (Item_t (Big_map_t (map_key, map_value, map_name), rest, annot)) + | ( Prim (loc, I_GET_AND_UPDATE, [], annot), + Item_t + ( vk, + Item_t + ( Option_t (vv, vname), + Item_t (Big_map_t (ck, v, map_name), rest, map_annot), + v_annot ), + _ ) ) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_GET_AND_UPDATE 1 3 + >>?= fun (Eq, _, ctxt) -> + check_item_ty ctxt vv v loc I_GET_AND_UPDATE 2 3 + >>?= fun (Eq, v, ctxt) -> + parse_var_annot loc annot ~default:map_annot + >>?= fun annot -> + typed + ctxt + loc + Big_map_get_and_update + (Item_t + ( Option_t (vv, vname), + Item_t (Big_map_t (ck, v, map_name), rest, annot), + v_annot )) + (* Sapling *) + | (Prim (loc, I_SAPLING_EMPTY_STATE, [memo_size], annot), rest) -> + parse_memo_size memo_size + >>?= fun memo_size -> + parse_var_annot loc annot ~default:default_sapling_state_annot + >>?= fun annot -> + typed + ctxt + loc + (Sapling_empty_state {memo_size}) + (Item_t (Sapling_state_t (memo_size, None), rest, annot)) + | ( Prim (loc, I_SAPLING_VERIFY_UPDATE, [], _), + Item_t + ( Sapling_transaction_t (transaction_memo_size, _), + Item_t + ( (Sapling_state_t (state_memo_size, _) as state_ty), + rest, + stack_annot ), + _ ) ) -> + merge_memo_sizes state_memo_size transaction_memo_size + >>?= fun _memo_size -> + typed + ctxt + loc + Sapling_verify_update + (Item_t + ( Option_t + ( Pair_t + ( (Int_t None, None, default_sapling_balance_annot), + (state_ty, None, None), + None ), + None ), + rest, + stack_annot )) + (* control *) + | (Seq (loc, []), stack) -> + typed ctxt loc Nop stack + | (Seq (loc, [single]), stack) -> ( + non_terminal_recursion ?type_logger tc_context ctxt ~legacy single stack + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft; _} as instr) -> + let nop = {bef = aft; loc; aft; instr = Nop} in + typed ctxt loc (Seq (instr, nop)) aft + | Failed {descr; _} -> + let descr aft = + let nop = {bef = aft; loc; aft; instr = Nop} in + let descr = descr aft in + {descr with instr = Seq (descr, nop)} + in + return ctxt (Failed {descr}) ) + | (Seq (loc, hd :: tl), stack) -> ( + non_terminal_recursion ?type_logger tc_context ctxt ~legacy hd stack + >>=? fun (judgement, ctxt) -> + match judgement with + | Failed _ -> + fail (Fail_not_in_tail_position (Micheline.location hd)) + | Typed ({aft = middle; _} as ihd) -> ( + non_terminal_recursion + ?type_logger + tc_context + ctxt + ~legacy + (Seq (-1, tl)) + middle + >>=? fun (judgement, ctxt) -> + match judgement with + | Failed {descr} -> + let descr ret = + {loc; instr = Seq (ihd, descr ret); bef = stack; aft = ret} + in + return ctxt (Failed {descr}) + | Typed itl -> + typed ctxt loc (Seq (ihd, itl)) itl.aft ) ) + | (Prim (loc, I_IF, [bt; bf], annot), (Item_t (Bool_t _, rest, _) as bef)) -> + check_kind [Seq_kind] bt + >>?= fun () -> + check_kind [Seq_kind] bf + >>?= fun () -> + error_unexpected_annot loc annot + >>?= fun () -> + non_terminal_recursion ?type_logger tc_context ctxt ~legacy bt rest + >>=? fun (btr, ctxt) -> + non_terminal_recursion ?type_logger tc_context ctxt ~legacy bf rest + >>=? fun (bfr, ctxt) -> + let branch ibt ibf = {loc; instr = If (ibt, ibf); bef; aft = ibt.aft} in + merge_branches ~legacy ctxt loc btr bfr {branch} + >>?= fun (judgement, ctxt) -> return ctxt judgement + | ( Prim (loc, I_LOOP, [body], annot), + (Item_t (Bool_t _, rest, _stack_annot) as stack) ) -> ( + check_kind [Seq_kind] body + >>?= fun () -> + error_unexpected_annot loc annot + >>?= fun () -> + non_terminal_recursion ?type_logger tc_context ctxt ~legacy body rest + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ibody -> + let unmatched_branches () = + serialize_stack_for_error ctxt ibody.aft + >>? fun (aft, ctxt) -> + serialize_stack_for_error ctxt stack + >|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack) + in + Lwt.return + @@ record_trace_eval + unmatched_branches + ( merge_stacks ~legacy loc ctxt 1 ibody.aft stack + >>? fun (Eq, _stack, ctxt) -> + typed_no_lwt ctxt loc (Loop ibody) rest ) + | Failed {descr} -> + let ibody = descr stack in + typed ctxt loc (Loop ibody) rest ) + | ( Prim (loc, I_LOOP_LEFT, [body], annot), + (Item_t (Union_t ((tl, l_field), (tr, _), _), rest, union_annot) as stack) + ) -> ( + check_kind [Seq_kind] body + >>?= fun () -> + parse_var_annot loc annot + >>?= fun annot -> + let l_annot = + gen_access_annot union_annot l_field ~default:default_left_annot + in + non_terminal_recursion + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t (tl, rest, l_annot)) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ibody -> + let unmatched_branches () = + serialize_stack_for_error ctxt ibody.aft + >>? fun (aft, ctxt) -> + serialize_stack_for_error ctxt stack + >|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack) + in + Lwt.return + @@ record_trace_eval + unmatched_branches + ( merge_stacks ~legacy loc ctxt 1 ibody.aft stack + >>? fun (Eq, _stack, ctxt) -> + typed_no_lwt + ctxt + loc + (Loop_left ibody) + (Item_t (tr, rest, annot)) ) + | Failed {descr} -> + let ibody = descr stack in + typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) ) + | (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) -> + parse_any_ty ctxt ~legacy arg + >>?= fun (Ex_ty arg, ctxt) -> + parse_any_ty ctxt ~legacy ret + >>?= fun (Ex_ty ret, ctxt) -> + check_kind [Seq_kind] code + >>?= fun () -> + parse_var_annot loc annot + >>?= fun annot -> + parse_returning + Lambda + ?type_logger + ~stack_depth + ctxt + ~legacy + (arg, default_arg_annot) + ret + code + >>=? fun (lambda, ctxt) -> + typed + ctxt + loc + (Lambda lambda) + (Item_t (Lambda_t (arg, ret, None), stack, annot)) + | ( Prim (loc, I_EXEC, [], annot), + Item_t (arg, Item_t (Lambda_t (param, ret, _), rest, _), _) ) -> + check_item_ty ctxt arg param loc I_EXEC 1 2 + >>?= fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>?= fun annot -> typed ctxt loc Exec (Item_t (ret, rest, annot)) + | ( Prim (loc, I_APPLY, [], annot), + Item_t + ( capture, + Item_t + ( Lambda_t + (Pair_t ((capture_ty, _, _), (arg_ty, _, _), lam_annot), ret, _), + rest, + _ ), + _ ) ) -> + check_packable ~legacy:false loc capture_ty + >>?= fun () -> + check_item_ty ctxt capture capture_ty loc I_APPLY 1 2 + >>?= fun (Eq, capture_ty, ctxt) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + (Apply capture_ty) + (Item_t (Lambda_t (arg_ty, ret, lam_annot), rest, annot)) + | (Prim (loc, I_DIP, [code], annot), Item_t (v, rest, stack_annot)) -> ( + error_unexpected_annot loc annot + >>?= fun () -> + check_kind [Seq_kind] code + >>?= fun () -> + non_terminal_recursion + ?type_logger + (add_dip v stack_annot tc_context) + ctxt + ~legacy + code + rest + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed descr -> + typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot)) + | Failed _ -> + fail (Fail_not_in_tail_position loc) ) + | (Prim (loc, I_DIP, [n; code], result_annot), stack) -> + parse_uint10 n + >>?= fun n -> + Gas.consume ctxt (Typecheck_costs.proof_argument n) + >>?= fun ctxt -> + let rec make_proof_argument : + type tstk. + int + (* -> (fbef stack_ty -> (fbef judgement * context) tzresult Lwt.t) *) -> + tc_context -> + tstk stack_ty -> + tstk dipn_proof_argument tzresult Lwt.t = + fun n inner_tc_context stk -> + match (Compare.Int.(n = 0), stk) with + | (true, rest) -> ( + non_terminal_recursion + ?type_logger + inner_tc_context + ctxt + ~legacy + code + rest + >>=? fun (judgement, ctxt) -> + Lwt.return + @@ + match judgement with + | Typed descr -> + ok @@ Dipn_proof_argument (Rest, (ctxt, descr), descr.aft) + | Failed _ -> + error (Fail_not_in_tail_position loc) ) + | (false, Item_t (v, rest, annot)) -> + make_proof_argument (n - 1) (add_dip v annot tc_context) rest + >|=? fun (Dipn_proof_argument (n', descr, aft')) -> + Dipn_proof_argument (Prefix n', descr, Item_t (v, aft', annot)) + | (_, _) -> + Lwt.return + ( serialize_stack_for_error ctxt stack + >>? fun (whole_stack, _ctxt) -> + error (Bad_stack (loc, I_DIP, 1, whole_stack)) ) + in + error_unexpected_annot loc result_annot + >>?= fun () -> + make_proof_argument n tc_context stack + >>=? fun (Dipn_proof_argument (n', (new_ctxt, descr), aft)) -> + (* TODO: which context should be used in the next line? new_ctxt or the old ctxt? *) + typed new_ctxt loc (Dipn (n, n', descr)) aft + | (Prim (loc, I_DIP, (([] | _ :: _ :: _ :: _) as l), _), _) -> + (* Technically, the arities 1 and 2 are allowed but the error only mentions 2. + However, DIP {code} is equivalent to DIP 1 {code} so hinting at an arity of 2 makes sense. *) + fail (Invalid_arity (loc, I_DIP, 2, List.length l)) + | (Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest, _)) -> + error_unexpected_annot loc annot + >>?= fun () -> + (if legacy then ok_unit else check_packable ~legacy:false loc v) + >>?= fun () -> + let descr aft = {loc; instr = Failwith v; bef = stack_ty; aft} in + log_stack ctxt loc stack_ty Empty_t + >>?= fun () -> return ctxt (Failed {descr}) + | (Prim (loc, I_NEVER, [], annot), Item_t (Never_t _, _rest, _)) -> + error_unexpected_annot loc annot + >>?= fun () -> + let descr aft = {loc; instr = Never; bef = stack_ty; aft} in + log_stack ctxt loc stack_ty Empty_t + >>?= fun () -> return ctxt (Failed {descr}) + (* timestamp operations *) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Add_timestamp_to_seconds + (Item_t (Timestamp_t tname, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Int_t _, Item_t (Timestamp_t tname, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Add_seconds_to_timestamp + (Item_t (Timestamp_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Sub_timestamp_seconds + (Item_t (Timestamp_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Diff_timestamps (Item_t (Int_t tname, rest, annot)) + (* string operations *) + | ( Prim (loc, I_CONCAT, [], annot), + Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Concat_string_pair (Item_t (String_t tname, rest, annot)) + | ( Prim (loc, I_CONCAT, [], annot), + Item_t (List_t (String_t tname, _), rest, list_annot) ) -> + parse_var_annot ~default:list_annot loc annot + >>?= fun annot -> + typed ctxt loc Concat_string (Item_t (String_t tname, rest, annot)) + | ( Prim (loc, I_SLICE, [], annot), + Item_t + ( Nat_t _, + Item_t (Nat_t _, Item_t (String_t tname, rest, string_annot), _), + _ ) ) -> + parse_var_annot + ~default:(gen_access_annot string_annot default_slice_annot) + loc + annot + >>?= fun annot -> + typed + ctxt + loc + Slice_string + (Item_t (Option_t (String_t tname, None), rest, annot)) + | (Prim (loc, I_SIZE, [], annot), Item_t (String_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc String_size (Item_t (Nat_t None, rest, annot)) + (* bytes operations *) + | ( Prim (loc, I_CONCAT, [], annot), + Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Concat_bytes_pair (Item_t (Bytes_t tname, rest, annot)) + | ( Prim (loc, I_CONCAT, [], annot), + Item_t (List_t (Bytes_t tname, _), rest, list_annot) ) -> + parse_var_annot ~default:list_annot loc annot + >>?= fun annot -> + typed ctxt loc Concat_bytes (Item_t (Bytes_t tname, rest, annot)) + | ( Prim (loc, I_SLICE, [], annot), + Item_t + ( Nat_t _, + Item_t (Nat_t _, Item_t (Bytes_t tname, rest, bytes_annot), _), + _ ) ) -> + parse_var_annot + ~default:(gen_access_annot bytes_annot default_slice_annot) + loc + annot + >>?= fun annot -> + typed + ctxt + loc + Slice_bytes + (Item_t (Option_t (Bytes_t tname, None), rest, annot)) + | (Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Bytes_size (Item_t (Nat_t None, rest, annot)) + (* currency operations *) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Add_tez (Item_t (Mutez_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Sub_tez (Item_t (Mutez_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) -> + (* no type name check *) + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Mul_teznat (Item_t (Mutez_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Nat_t _, Item_t (Mutez_t tname, rest, _), _) ) -> + (* no type name check *) + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Mul_nattez (Item_t (Mutez_t tname, rest, annot)) + (* boolean operations *) + | ( Prim (loc, I_OR, [], annot), + Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> typed ctxt loc Or (Item_t (Bool_t tname, rest, annot)) + | ( Prim (loc, I_AND, [], annot), + Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> typed ctxt loc And (Item_t (Bool_t tname, rest, annot)) + | ( Prim (loc, I_XOR, [], annot), + Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> typed ctxt loc Xor (Item_t (Bool_t tname, rest, annot)) + | (Prim (loc, I_NOT, [], annot), Item_t (Bool_t tname, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> typed ctxt loc Not (Item_t (Bool_t tname, rest, annot)) + (* integer operations *) + | (Prim (loc, I_ABS, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Abs_int (Item_t (Nat_t None, rest, annot)) + | (Prim (loc, I_ISNAT, [], annot), Item_t (Int_t _, rest, int_annot)) -> + parse_var_annot loc annot ~default:int_annot + >>?= fun annot -> + typed ctxt loc Is_nat (Item_t (Option_t (Nat_t None, None), rest, annot)) + | (Prim (loc, I_INT, [], annot), Item_t (Nat_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Int_nat (Item_t (Int_t None, rest, annot)) + | (Prim (loc, I_NEG, [], annot), Item_t (Int_t tname, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Neg_int (Item_t (Int_t tname, rest, annot)) + | (Prim (loc, I_NEG, [], annot), Item_t (Nat_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Neg_nat (Item_t (Int_t None, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Add_intint (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Add_intnat (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Add_natint (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Add_natnat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun _tname -> + typed ctxt loc Sub_int (Item_t (Int_t None, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Mul_intint (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Mul_intnat (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Mul_natint (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Mul_natnat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Ediv_teznat + (Item_t + ( Option_t + ( Pair_t + ( (Mutez_t tname, None, None), + (Mutez_t tname, None, None), + None ), + None ), + rest, + annot )) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed + ctxt + loc + Ediv_tez + (Item_t + ( Option_t + ( Pair_t + ((Nat_t None, None, None), (Mutez_t tname, None, None), None), + None ), + rest, + annot )) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed + ctxt + loc + Ediv_intint + (Item_t + ( Option_t + ( Pair_t + ((Int_t tname, None, None), (Nat_t None, None, None), None), + None ), + rest, + annot )) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Ediv_intnat + (Item_t + ( Option_t + ( Pair_t + ((Int_t tname, None, None), (Nat_t None, None, None), None), + None ), + rest, + annot )) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Ediv_natint + (Item_t + ( Option_t + ( Pair_t + ((Int_t None, None, None), (Nat_t tname, None, None), None), + None ), + rest, + annot )) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed + ctxt + loc + Ediv_natnat + (Item_t + ( Option_t + ( Pair_t + ((Nat_t tname, None, None), (Nat_t tname, None, None), None), + None ), + rest, + annot )) + | ( Prim (loc, I_LSL, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Lsl_nat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_LSR, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Lsr_nat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_OR, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Or_nat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_AND, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc And_nat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_AND, [], annot), + Item_t (Int_t _, Item_t (Nat_t tname, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc And_int_nat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_XOR, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed ctxt loc Xor_nat (Item_t (Nat_t tname, rest, annot)) + | (Prim (loc, I_NOT, [], annot), Item_t (Int_t tname, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Not_int (Item_t (Int_t tname, rest, annot)) + | (Prim (loc, I_NOT, [], annot), Item_t (Nat_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Not_nat (Item_t (Int_t None, rest, annot)) + (* comparison *) + | (Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest, _), _)) -> + parse_var_annot loc annot + >>?= fun annot -> + check_item_ty ctxt t1 t2 loc I_COMPARE 1 2 + >>?= fun (Eq, t, ctxt) -> + comparable_ty_of_ty ctxt loc t + >>?= fun (key, ctxt) -> + typed ctxt loc (Compare key) (Item_t (Int_t None, rest, annot)) + (* comparators *) + | (Prim (loc, I_EQ, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> typed ctxt loc Eq (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_NEQ, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> typed ctxt loc Neq (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_LT, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> typed ctxt loc Lt (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_GT, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> typed ctxt loc Gt (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_LE, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> typed ctxt loc Le (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_GE, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> typed ctxt loc Ge (Item_t (Bool_t None, rest, annot)) + (* annotations *) + | (Prim (loc, I_CAST, [cast_t], annot), Item_t (t, stack, item_annot)) -> + parse_var_annot loc annot ~default:item_annot + >>?= fun annot -> + parse_any_ty ctxt ~legacy cast_t + >>?= fun (Ex_ty cast_t, ctxt) -> + merge_types ~legacy ctxt loc cast_t t + >>?= fun (Eq, _, ctxt) -> + typed ctxt loc Nop (Item_t (cast_t, stack, annot)) + | (Prim (loc, I_RENAME, [], annot), Item_t (t, stack, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + (* can erase annot *) + typed ctxt loc Nop (Item_t (t, stack, annot)) + (* packing *) + | (Prim (loc, I_PACK, [], annot), Item_t (t, rest, unpacked_annot)) -> + check_packable + ~legacy:true + (* allow to pack contracts for hash/signature checks *) loc + t + >>?= fun () -> + parse_var_annot + loc + annot + ~default:(gen_access_annot unpacked_annot default_pack_annot) + >>?= fun annot -> + typed ctxt loc (Pack t) (Item_t (Bytes_t None, rest, annot)) + | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t _, rest, packed_annot)) + -> + parse_packable_ty ctxt ~legacy ty + >>?= fun (Ex_ty t, ctxt) -> + parse_var_type_annot loc annot + >>?= fun (annot, ty_name) -> + let annot = + default_annot + annot + ~default:(gen_access_annot packed_annot default_unpack_annot) + in + typed ctxt loc (Unpack t) (Item_t (Option_t (t, ty_name), rest, annot)) + (* protocol *) + | ( Prim (loc, I_ADDRESS, [], annot), + Item_t (Contract_t _, rest, contract_annot) ) -> + parse_var_annot + loc + annot + ~default:(gen_access_annot contract_annot default_addr_annot) + >>?= fun annot -> + typed ctxt loc Address (Item_t (Address_t None, rest, annot)) + | ( Prim (loc, I_CONTRACT, [ty], annot), + Item_t (Address_t _, rest, addr_annot) ) -> + parse_parameter_ty ctxt ~legacy ty + >>?= fun (Ex_ty t, ctxt) -> + parse_entrypoint_annot + loc + annot + ~default:(gen_access_annot addr_annot default_contract_annot) + >>?= fun (annot, entrypoint) -> + ( match entrypoint with + | None -> + Ok "default" + | Some (Field_annot "default") -> + error (Unexpected_annotation loc) + | Some (Field_annot entrypoint) -> + if Compare.Int.(String.length entrypoint > 31) then + error (Entrypoint_name_too_long entrypoint) + else Ok entrypoint ) + >>?= fun entrypoint -> + typed + ctxt + loc + (Contract (t, entrypoint)) + (Item_t (Option_t (Contract_t (t, None), None), rest, annot)) + | ( Prim (loc, I_TRANSFER_TOKENS, [], annot), + Item_t (p, Item_t (Mutez_t _, Item_t (Contract_t (cp, _), rest, _), _), _) + ) -> + check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4 + >>?= fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Transfer_tokens (Item_t (Operation_t None, rest, annot)) + | ( Prim (loc, I_SET_DELEGATE, [], annot), + Item_t (Option_t (Key_hash_t _, _), rest, _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot)) + | (Prim (_, I_CREATE_ACCOUNT, _, _), _) -> + fail (Deprecated_instruction I_CREATE_ACCOUNT) + | (Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t _, rest, _)) + -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Implicit_account + (Item_t (Contract_t (Unit_t None, None), rest, annot)) + | ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot), + Item_t + ( Option_t (Key_hash_t _, _), + Item_t (Mutez_t _, Item_t (ginit, rest, _), _), + _ ) ) -> + parse_two_var_annot loc annot + >>?= fun (op_annot, addr_annot) -> + let canonical_code = fst @@ Micheline.extract_locations code in + parse_toplevel ~legacy canonical_code + >>?= fun (arg_type, storage_type, code_field, root_name) -> + record_trace + (Ill_formed_type (Some "parameter", canonical_code, location arg_type)) + (parse_parameter_ty ctxt ~legacy arg_type) + >>?= fun (Ex_ty arg_type, ctxt) -> + (if legacy then ok_unit else well_formed_entrypoints ~root_name arg_type) + >>?= fun () -> + record_trace + (Ill_formed_type (Some "storage", canonical_code, location storage_type)) + (parse_storage_ty ctxt ~legacy storage_type) + >>?= fun (Ex_ty storage_type, ctxt) -> + let arg_annot = + default_annot + (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot + in + let storage_annot = + default_annot + (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot + in + let arg_type_full = + Pair_t + ( (arg_type, None, arg_annot), + (storage_type, None, storage_annot), + None ) + in + let ret_type_full = + Pair_t + ( (List_t (Operation_t None, None), None, None), + (storage_type, None, None), + None ) + in + trace + (Ill_typed_contract (canonical_code, [])) + (parse_returning + (Toplevel + { + storage_type; + param_type = arg_type; + root_name; + legacy_create_contract_literal = false; + }) + ctxt + ~legacy + ?type_logger + ~stack_depth + (arg_type_full, None) + ret_type_full + code_field) + >>=? fun ( ( Lam + ( { bef = Item_t (arg, Empty_t, _); + aft = Item_t (ret, Empty_t, _); + _ }, + _ ) as lambda ), + ctxt ) -> + merge_types ~legacy ctxt loc arg arg_type_full + >>?= fun (Eq, _, ctxt) -> + merge_types ~legacy ctxt loc ret ret_type_full + >>?= fun (Eq, _, ctxt) -> + merge_types ~legacy ctxt loc storage_type ginit + >>?= fun (Eq, _, ctxt) -> + typed + ctxt + loc + (Create_contract (storage_type, arg_type, lambda, root_name)) + (Item_t + ( Operation_t None, + Item_t (Address_t None, rest, addr_annot), + op_annot )) + | (Prim (loc, I_NOW, [], annot), stack) -> + parse_var_annot loc annot ~default:default_now_annot + >>?= fun annot -> + typed ctxt loc Now (Item_t (Timestamp_t None, stack, annot)) + | (Prim (loc, I_AMOUNT, [], annot), stack) -> + parse_var_annot loc annot ~default:default_amount_annot + >>?= fun annot -> + typed ctxt loc Amount (Item_t (Mutez_t None, stack, annot)) + | (Prim (loc, I_CHAIN_ID, [], annot), stack) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc ChainId (Item_t (Chain_id_t None, stack, annot)) + | (Prim (loc, I_BALANCE, [], annot), stack) -> + parse_var_annot loc annot ~default:default_balance_annot + >>?= fun annot -> + typed ctxt loc Balance (Item_t (Mutez_t None, stack, annot)) + | (Prim (loc, I_LEVEL, [], annot), stack) -> + parse_var_annot loc annot ~default:default_level_annot + >>?= fun annot -> + typed ctxt loc Level (Item_t (Nat_t None, stack, annot)) + | (Prim (loc, I_VOTING_POWER, [], annot), Item_t (Key_hash_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Voting_power (Item_t (Nat_t None, rest, annot)) + | (Prim (loc, I_TOTAL_VOTING_POWER, [], annot), stack) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Total_voting_power (Item_t (Nat_t None, stack, annot)) + | (Prim (_, I_STEPS_TO_QUOTA, _, _), _) -> + fail (Deprecated_instruction I_STEPS_TO_QUOTA) + | (Prim (loc, I_SOURCE, [], annot), stack) -> + parse_var_annot loc annot ~default:default_source_annot + >>?= fun annot -> + typed ctxt loc Source (Item_t (Address_t None, stack, annot)) + | (Prim (loc, I_SENDER, [], annot), stack) -> + parse_var_annot loc annot ~default:default_sender_annot + >>?= fun annot -> + typed ctxt loc Sender (Item_t (Address_t None, stack, annot)) + | (Prim (loc, I_SELF, [], annot), stack) -> + Lwt.return + ( parse_entrypoint_annot loc annot ~default:default_self_annot + >>? fun (annot, entrypoint) -> + let entrypoint = + Option.fold + ~some:(fun (Field_annot annot) -> annot) + ~none:"default" + entrypoint + in + let rec get_toplevel_type : + tc_context -> (bef judgement * context) tzresult = function + | Lambda -> + error (Self_in_lambda loc) + | Dip (_, prev) -> + get_toplevel_type prev + | Toplevel + {param_type; root_name; legacy_create_contract_literal = false} + -> + find_entrypoint param_type ~root_name entrypoint + >>? fun (_, Ex_ty param_type) -> + typed_no_lwt + ctxt + loc + (Self (param_type, entrypoint)) + (Item_t (Contract_t (param_type, None), stack, annot)) + | Toplevel + {param_type; root_name = _; legacy_create_contract_literal = true} + -> + typed_no_lwt + ctxt + loc + (Self (param_type, "default")) + (Item_t (Contract_t (param_type, None), stack, annot)) + in + get_toplevel_type tc_context ) + | (Prim (loc, I_SELF_ADDRESS, [], annot), stack) -> + parse_var_annot loc annot ~default:default_self_annot + >>?= fun annot -> + typed ctxt loc Self_address (Item_t (Address_t None, stack, annot)) + (* cryptography *) + | (Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Hash_key (Item_t (Key_hash_t None, rest, annot)) + | ( Prim (loc, I_CHECK_SIGNATURE, [], annot), + Item_t + (Key_t _, Item_t (Signature_t _, Item_t (Bytes_t _, rest, _), _), _) ) + -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Check_signature (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_BLAKE2B, [], annot), Item_t (Bytes_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Blake2b (Item_t (Bytes_t None, rest, annot)) + | (Prim (loc, I_SHA256, [], annot), Item_t (Bytes_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Sha256 (Item_t (Bytes_t None, rest, annot)) + | (Prim (loc, I_SHA512, [], annot), Item_t (Bytes_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Sha512 (Item_t (Bytes_t None, rest, annot)) + | (Prim (loc, I_KECCAK, [], annot), Item_t (Bytes_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Keccak (Item_t (Bytes_t None, rest, annot)) + | (Prim (loc, I_SHA3, [], annot), Item_t (Bytes_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Sha3 (Item_t (Bytes_t None, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Bls12_381_g1_t tn1, Item_t (Bls12_381_g1_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed + ctxt + loc + Add_bls12_381_g1 + (Item_t (Bls12_381_g1_t tname, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Bls12_381_g2_t tn1, Item_t (Bls12_381_g2_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed + ctxt + loc + Add_bls12_381_g2 + (Item_t (Bls12_381_g2_t tname, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Bls12_381_fr_t tn1, Item_t (Bls12_381_fr_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + merge_type_annot ~legacy tn1 tn2 + >>?= fun tname -> + typed + ctxt + loc + Add_bls12_381_fr + (Item_t (Bls12_381_fr_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Bls12_381_g1_t tname, Item_t (Bls12_381_fr_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Mul_bls12_381_g1 + (Item_t (Bls12_381_g1_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Bls12_381_g2_t tname, Item_t (Bls12_381_fr_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Mul_bls12_381_g2 + (Item_t (Bls12_381_g2_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Bls12_381_fr_t tname, Item_t (Bls12_381_fr_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Mul_bls12_381_fr + (Item_t (Bls12_381_fr_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Nat_t tname, Item_t (Bls12_381_fr_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Mul_bls12_381_fr_z + (Item_t (Bls12_381_fr_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Int_t tname, Item_t (Bls12_381_fr_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Mul_bls12_381_fr_z + (Item_t (Bls12_381_fr_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Bls12_381_fr_t tname, Item_t (Int_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Mul_bls12_381_z_fr + (Item_t (Bls12_381_fr_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Bls12_381_fr_t tname, Item_t (Nat_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Mul_bls12_381_z_fr + (Item_t (Bls12_381_fr_t tname, rest, annot)) + | (Prim (loc, I_INT, [], annot), Item_t (Bls12_381_fr_t _, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed ctxt loc Int_bls12_381_fr (Item_t (Int_t None, rest, annot)) + | (Prim (loc, I_NEG, [], annot), Item_t (Bls12_381_g1_t tname, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Neg_bls12_381_g1 + (Item_t (Bls12_381_g1_t tname, rest, annot)) + | (Prim (loc, I_NEG, [], annot), Item_t (Bls12_381_g2_t tname, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Neg_bls12_381_g2 + (Item_t (Bls12_381_g2_t tname, rest, annot)) + | (Prim (loc, I_NEG, [], annot), Item_t (Bls12_381_fr_t tname, rest, _)) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Neg_bls12_381_fr + (Item_t (Bls12_381_fr_t tname, rest, annot)) + | ( Prim (loc, I_PAIRING_CHECK, [], annot), + Item_t + ( List_t + (Pair_t ((Bls12_381_g1_t _, _, _), (Bls12_381_g2_t _, _, _), _), _), + rest, + _ ) ) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Pairing_check_bls12_381 + (Item_t (Bool_t None, rest, annot)) + (* Tickets *) + | (Prim (loc, I_TICKET, [], annot), Item_t (t, Item_t (Nat_t _, rest, _), _)) + -> + parse_var_annot loc annot + >>?= fun annot -> + comparable_ty_of_ty ctxt loc t + >>?= fun (ty, ctxt) -> + typed ctxt loc Ticket (Item_t (Ticket_t (ty, None), rest, annot)) + | ( Prim (loc, I_READ_TICKET, [], annot), + (Item_t (Ticket_t (t, _), _, _) as full_stack) ) -> + parse_var_annot loc annot + >>?= fun annot -> + let () = check_dupable_comparable_ty t in + let result = ty_of_comparable_ty @@ opened_ticket_type t in + typed ctxt loc Read_ticket (Item_t (result, full_stack, annot)) + | ( Prim (loc, I_SPLIT_TICKET, [], annot), + Item_t + ( (Ticket_t (t, _) as ticket_t), + Item_t + (Pair_t ((Nat_t _, fa_a, a_a), (Nat_t _, fa_b, a_b), _), rest, _), + _ ) ) -> + parse_var_annot loc annot + >>?= fun annot -> + let () = check_dupable_comparable_ty t in + let result = + Option_t + (Pair_t ((ticket_t, fa_a, a_a), (ticket_t, fa_b, a_b), None), None) + in + typed ctxt loc Split_ticket (Item_t (result, rest, annot)) + | ( Prim (loc, I_JOIN_TICKETS, [], annot), + Item_t + ( Pair_t (((Ticket_t _ as ty_a), _, _), ((Ticket_t _ as ty_b), _, _), _), + rest, + _ ) ) -> ( + parse_var_annot loc annot + >>?= fun annot -> + merge_types ~legacy ctxt loc ty_a ty_b + >>?= fun (Eq, ty, ctxt) -> + match ty with + | Ticket_t (contents_ty, _) -> + typed + ctxt + loc + (Join_tickets contents_ty) + (Item_t (Option_t (ty, None), rest, annot)) + | _ -> + (* TODO: fix injectivity of types *) assert false ) + (* Primitive parsing errors *) + | ( Prim + ( loc, + ( ( I_DUP + | I_SWAP + | I_SOME + | I_UNIT + | I_PAIR + | I_UNPAIR + | I_CAR + | I_CDR + | I_CONS + | I_CONCAT + | I_SLICE + | I_MEM + | I_UPDATE + | I_GET + | I_EXEC + | I_FAILWITH + | I_SIZE + | I_ADD + | I_SUB + | I_MUL + | I_EDIV + | I_OR + | I_AND + | I_XOR + | I_NOT + | I_ABS + | I_NEG + | I_LSL + | I_LSR + | I_COMPARE + | I_EQ + | I_NEQ + | I_LT + | I_GT + | I_LE + | I_GE + | I_TRANSFER_TOKENS + | I_SET_DELEGATE + | I_NOW + | I_IMPLICIT_ACCOUNT + | I_AMOUNT + | I_BALANCE + | I_LEVEL + | I_CHECK_SIGNATURE + | I_HASH_KEY + | I_SOURCE + | I_SENDER + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_ADDRESS + | I_RENAME + | I_PACK + | I_ISNAT + | I_INT + | I_SELF + | I_CHAIN_ID + | I_NEVER + | I_VOTING_POWER + | I_TOTAL_VOTING_POWER + | I_KECCAK + | I_SHA3 + | I_PAIRING_CHECK + | I_TICKET + | I_READ_TICKET + | I_SPLIT_TICKET + | I_JOIN_TICKETS ) as name ), + (_ :: _ as l), + _ ), + _ ) -> + fail (Invalid_arity (loc, name, 0, List.length l)) + | ( Prim + ( loc, + ( ( I_NONE + | I_LEFT + | I_RIGHT + | I_NIL + | I_MAP + | I_ITER + | I_EMPTY_SET + | I_LOOP + | I_LOOP_LEFT + | I_CONTRACT + | I_CAST + | I_UNPACK + | I_CREATE_CONTRACT ) as name ), + (([] | _ :: _ :: _) as l), + _ ), + _ ) -> + fail (Invalid_arity (loc, name, 1, List.length l)) + | ( Prim + ( loc, + ( ( I_PUSH + | I_IF_NONE + | I_IF_LEFT + | I_IF_CONS + | I_EMPTY_MAP + | I_EMPTY_BIG_MAP + | I_IF ) as name ), + (([] | [_] | _ :: _ :: _ :: _) as l), + _ ), + _ ) -> + fail (Invalid_arity (loc, name, 2, List.length l)) + | ( Prim + (loc, I_LAMBDA, (([] | [_] | [_; _] | _ :: _ :: _ :: _ :: _) as l), _), + _ ) -> + fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l)) + (* Stack errors *) + | ( Prim + ( loc, + ( ( I_ADD + | I_SUB + | I_MUL + | I_EDIV + | I_AND + | I_OR + | I_XOR + | I_LSL + | I_LSR + | I_CONCAT + | I_PAIRING_CHECK ) as name ), + [], + _ ), + Item_t (ta, Item_t (tb, _, _), _) ) -> + serialize_ty_for_error ctxt ta + >>?= fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb + >>?= fun (tb, _ctxt) -> fail (Undefined_binop (loc, name, ta, tb)) + | ( Prim + ( loc, + ( ( I_NEG + | I_ABS + | I_NOT + | I_SIZE + | I_EQ + | I_NEQ + | I_LT + | I_GT + | I_LE + | I_GE + (* CONCAT is both unary and binary; this case can only be triggered + on a singleton stack *) + | I_CONCAT ) as name ), + [], + _ ), + Item_t (t, _, _) ) -> + serialize_ty_for_error ctxt t + >>?= fun (t, _ctxt) -> fail (Undefined_unop (loc, name, t)) + | (Prim (loc, ((I_UPDATE | I_SLICE) as name), [], _), stack) -> + Lwt.return + ( serialize_stack_for_error ctxt stack + >>? fun (stack, _ctxt) -> error (Bad_stack (loc, name, 3, stack)) ) + | (Prim (loc, I_CREATE_CONTRACT, _, _), stack) -> + serialize_stack_for_error ctxt stack + >>?= fun (stack, _ctxt) -> + fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack)) + | (Prim (loc, I_TRANSFER_TOKENS, [], _), stack) -> + Lwt.return + ( serialize_stack_for_error ctxt stack + >>? fun (stack, _ctxt) -> + error (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack)) ) + | ( Prim + ( loc, + ( ( I_DROP + | I_DUP + | I_CAR + | I_CDR + | I_UNPAIR + | I_SOME + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_DIP + | I_IF_NONE + | I_LEFT + | I_RIGHT + | I_IF_LEFT + | I_IF + | I_LOOP + | I_IF_CONS + | I_IMPLICIT_ACCOUNT + | I_NEG + | I_ABS + | I_INT + | I_NOT + | I_HASH_KEY + | I_EQ + | I_NEQ + | I_LT + | I_GT + | I_LE + | I_GE + | I_SIZE + | I_FAILWITH + | I_RENAME + | I_PACK + | I_ISNAT + | I_ADDRESS + | I_SET_DELEGATE + | I_CAST + | I_MAP + | I_ITER + | I_LOOP_LEFT + | I_UNPACK + | I_CONTRACT + | I_NEVER + | I_KECCAK + | I_SHA3 + | I_READ_TICKET + | I_JOIN_TICKETS ) as name ), + _, + _ ), + stack ) -> + Lwt.return + ( serialize_stack_for_error ctxt stack + >>? fun (stack, _ctxt) -> error (Bad_stack (loc, name, 1, stack)) ) + | ( Prim + ( loc, + ( ( I_SWAP + | I_PAIR + | I_CONS + | I_GET + | I_MEM + | I_EXEC + | I_CHECK_SIGNATURE + | I_ADD + | I_SUB + | I_MUL + | I_EDIV + | I_AND + | I_OR + | I_XOR + | I_LSL + | I_LSR + | I_COMPARE + | I_PAIRING_CHECK + | I_TICKET + | I_SPLIT_TICKET ) as name ), + _, + _ ), + stack ) -> + Lwt.return + ( serialize_stack_for_error ctxt stack + >>? fun (stack, _ctxt) -> error (Bad_stack (loc, name, 2, stack)) ) + (* Generic parsing errors *) + | (expr, _) -> + fail + @@ unexpected + expr + [Seq_kind] + Instr_namespace + [ I_DROP; + I_DUP; + I_DIG; + I_DUG; + I_SWAP; + I_SOME; + I_UNIT; + I_PAIR; + I_UNPAIR; + I_CAR; + I_CDR; + I_CONS; + I_MEM; + I_UPDATE; + I_MAP; + I_ITER; + I_GET; + I_GET_AND_UPDATE; + I_EXEC; + I_FAILWITH; + I_SIZE; + I_CONCAT; + I_ADD; + I_SUB; + I_MUL; + I_EDIV; + I_OR; + I_AND; + I_XOR; + I_NOT; + I_ABS; + I_INT; + I_NEG; + I_LSL; + I_LSR; + I_COMPARE; + I_EQ; + I_NEQ; + I_LT; + I_GT; + I_LE; + I_GE; + I_TRANSFER_TOKENS; + I_CREATE_CONTRACT; + I_NOW; + I_AMOUNT; + I_BALANCE; + I_LEVEL; + I_IMPLICIT_ACCOUNT; + I_CHECK_SIGNATURE; + I_BLAKE2B; + I_SHA256; + I_SHA512; + I_HASH_KEY; + I_PUSH; + I_NONE; + I_LEFT; + I_RIGHT; + I_NIL; + I_EMPTY_SET; + I_DIP; + I_LOOP; + I_IF_NONE; + I_IF_LEFT; + I_IF_CONS; + I_EMPTY_MAP; + I_EMPTY_BIG_MAP; + I_IF; + I_SOURCE; + I_SENDER; + I_SELF; + I_SELF_ADDRESS; + I_LAMBDA; + I_NEVER; + I_VOTING_POWER; + I_TOTAL_VOTING_POWER; + I_KECCAK; + I_SHA3; + I_PAIRING_CHECK; + I_SAPLING_EMPTY_STATE; + I_SAPLING_VERIFY_UPDATE; + I_TICKET; + I_READ_TICKET; + I_SPLIT_TICKET; + I_JOIN_TICKETS ] + +and parse_contract : + type arg. + legacy:bool -> + context -> + Script.location -> + arg ty -> + Contract.t -> + entrypoint:string -> + (context * arg typed_contract) tzresult Lwt.t = + fun ~legacy ctxt loc arg contract ~entrypoint -> + Gas.consume ctxt Typecheck_costs.contract_exists + >>?= fun ctxt -> + Contract.exists ctxt contract + >>=? function + | false -> + fail (Invalid_contract (loc, contract)) + | true -> ( + trace (Invalid_contract (loc, contract)) + @@ Contract.get_script_code ctxt contract + >>=? fun (ctxt, code) -> + Lwt.return + @@ + match code with + | None -> ( + ty_eq ctxt loc arg (Unit_t None) + >>? fun (Eq, ctxt) -> + match entrypoint with + | "default" -> + let contract : arg typed_contract = + (arg, (contract, entrypoint)) + in + ok (ctxt, contract) + | entrypoint -> + error (No_such_entrypoint entrypoint) ) + | Some code -> + Script.force_decode_in_context ctxt code + >>? fun (code, ctxt) -> + parse_toplevel ~legacy:true code + >>? fun (arg_type, _, _, root_name) -> + parse_parameter_ty ctxt ~legacy:true arg_type + >>? fun (Ex_ty targ, ctxt) -> + find_entrypoint_for_type + ~legacy + ~full:targ + ~expected:arg + ~root_name + entrypoint + ctxt + loc + >|? fun (ctxt, entrypoint, arg) -> + let contract : arg typed_contract = (arg, (contract, entrypoint)) in + (ctxt, contract) ) + +(* Same as the one above, but does not fail when the contact is missing or + if the expected type doesn't match the actual one. In that case None is + returned and some overapproximation of the typechecking gas is consumed. + This can still fail on gas exhaustion. *) +and parse_contract_for_script : + type arg. + legacy:bool -> + context -> + Script.location -> + arg ty -> + Contract.t -> + entrypoint:string -> + (context * arg typed_contract option) tzresult Lwt.t = + fun ~legacy ctxt loc arg contract ~entrypoint -> + Gas.consume ctxt Typecheck_costs.contract_exists + >>?= fun ctxt -> + match (Contract.is_implicit contract, entrypoint) with + | (Some _, "default") -> + (* An implicit account on the "default" entrypoint always exists and has type unit. *) + Lwt.return + ( match ty_eq ctxt loc arg (Unit_t None) with + | Ok (Eq, ctxt) -> + let contract : arg typed_contract = + (arg, (contract, entrypoint)) + in + ok (ctxt, Some contract) + | Error _ -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle + >>? fun ctxt -> ok (ctxt, None) ) + | (Some _, _) -> + Lwt.return + ( Gas.consume ctxt Typecheck_costs.parse_instr_cycle + >|? fun ctxt -> + (* An implicit account on any other entrypoint is not a valid contract. *) + (ctxt, None) ) + | (None, _) -> ( + (* Originated account *) + Contract.exists ctxt contract + >>=? function + | false -> + return (ctxt, None) + | true -> ( + trace (Invalid_contract (loc, contract)) + @@ Contract.get_script_code ctxt contract + >>=? fun (ctxt, code) -> + match code with + | None -> + (* Since protocol 005, we have the invariant that all originated accounts have code *) + assert false + | Some code -> + Lwt.return + ( Script.force_decode_in_context ctxt code + >>? fun (code, ctxt) -> + (* can only fail because of gas *) + match parse_toplevel ~legacy:true code with + | Error _ -> + error (Invalid_contract (loc, contract)) + | Ok (arg_type, _, _, root_name) -> ( + match parse_parameter_ty ctxt ~legacy:true arg_type with + | Error _ -> + error (Invalid_contract (loc, contract)) + | Ok (Ex_ty targ, ctxt) -> ( + match + find_entrypoint_for_type + ~legacy + ~full:targ + ~expected:arg + ~root_name + entrypoint + ctxt + loc + >|? fun (ctxt, entrypoint, arg) -> + let contract : arg typed_contract = + (arg, (contract, entrypoint)) + in + (ctxt, Some contract) + with + | Ok res -> + ok res + | Error _ -> + (* overapproximation by checking if targ = targ, + can only fail because of gas *) + merge_types ~legacy ctxt loc targ targ + >|? fun (Eq, _, ctxt) -> (ctxt, None) ) ) ) ) ) + +and parse_toplevel : + legacy:bool -> + Script.expr -> + (Script.node * Script.node * Script.node * field_annot option) tzresult = + fun ~legacy toplevel -> + record_trace (Ill_typed_contract (toplevel, [])) + @@ + match root toplevel with + | Int (loc, _) -> + error (Invalid_kind (loc, [Seq_kind], Int_kind)) + | String (loc, _) -> + error (Invalid_kind (loc, [Seq_kind], String_kind)) + | Bytes (loc, _) -> + error (Invalid_kind (loc, [Seq_kind], Bytes_kind)) + | Prim (loc, _, _, _) -> + error (Invalid_kind (loc, [Seq_kind], Prim_kind)) + | Seq (_, fields) -> ( + let rec find_fields p s c fields = + match fields with + | [] -> + ok (p, s, c) + | Int (loc, _) :: _ -> + error (Invalid_kind (loc, [Prim_kind], Int_kind)) + | String (loc, _) :: _ -> + error (Invalid_kind (loc, [Prim_kind], String_kind)) + | Bytes (loc, _) :: _ -> + error (Invalid_kind (loc, [Prim_kind], Bytes_kind)) + | Seq (loc, _) :: _ -> + error (Invalid_kind (loc, [Prim_kind], Seq_kind)) + | Prim (loc, K_parameter, [arg], annot) :: rest -> ( + match p with + | None -> + find_fields (Some (arg, loc, annot)) s c rest + | Some _ -> + error (Duplicate_field (loc, K_parameter)) ) + | Prim (loc, K_storage, [arg], annot) :: rest -> ( + match s with + | None -> + find_fields p (Some (arg, loc, annot)) c rest + | Some _ -> + error (Duplicate_field (loc, K_storage)) ) + | Prim (loc, K_code, [arg], annot) :: rest -> ( + match c with + | None -> + find_fields p s (Some (arg, loc, annot)) rest + | Some _ -> + error (Duplicate_field (loc, K_code)) ) + | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _) + :: _ -> + error (Invalid_arity (loc, name, 1, List.length args)) + | Prim (loc, name, _, _) :: _ -> + let allowed = [K_parameter; K_storage; K_code] in + error (Invalid_primitive (loc, allowed, name)) + in + find_fields None None None fields + >>? function + | (None, _, _) -> + error (Missing_field K_parameter) + | (Some _, None, _) -> + error (Missing_field K_storage) + | (Some _, Some _, None) -> + error (Missing_field K_code) + | (Some (p, ploc, pannot), Some (s, sloc, sannot), Some (c, cloc, carrot)) + -> + let maybe_root_name = + (* root name can be attached to either the parameter + primitive or the toplevel constructor *) + Script_ir_annot.extract_field_annot p + >>? fun (p, root_name) -> + match root_name with + | Some _ -> + ok (p, pannot, root_name) + | None -> ( + match pannot with + | [single] + when Compare.Int.(String.length single > 0) + && Compare.Char.(single.[0] = '%') -> + parse_field_annot ploc [single] + >>? fun pannot -> ok (p, [], pannot) + | _ -> + ok (p, pannot, None) ) + in + if legacy then + (* legacy semantics ignores spurious annotations *) + let (p, root_name) = + match maybe_root_name with + | Ok (p, _, root_name) -> + (p, root_name) + | Error _ -> + (p, None) + in + ok (p, s, c, root_name) + else + (* only one field annot is allowed to set the root entrypoint name *) + maybe_root_name + >>? fun (p, pannot, root_name) -> + Script_ir_annot.error_unexpected_annot ploc pannot + >>? fun () -> + Script_ir_annot.error_unexpected_annot cloc carrot + >>? fun () -> + Script_ir_annot.error_unexpected_annot sloc sannot + >>? fun () -> ok (p, s, c, root_name) ) + +let parse_code : + ?type_logger:type_logger -> + context -> + legacy:bool -> + code:lazy_expr -> + (ex_code * context) tzresult Lwt.t = + fun ?type_logger ctxt ~legacy ~code -> + Script.force_decode_in_context ctxt code + >>?= fun (code, ctxt) -> + parse_toplevel ~legacy code + >>?= fun (arg_type, storage_type, code_field, root_name) -> + record_trace + (Ill_formed_type (Some "parameter", code, location arg_type)) + (parse_parameter_ty ctxt ~legacy arg_type) + >>?= fun (Ex_ty arg_type, ctxt) -> + (if legacy then ok_unit else well_formed_entrypoints ~root_name arg_type) + >>?= fun () -> + record_trace + (Ill_formed_type (Some "storage", code, location storage_type)) + (parse_storage_ty ctxt ~legacy storage_type) + >>?= fun (Ex_ty storage_type, ctxt) -> + let arg_annot = + default_annot + (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot + in + let storage_annot = + default_annot + (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot + in + let arg_type_full = + Pair_t + ((arg_type, None, arg_annot), (storage_type, None, storage_annot), None) + in + let ret_type_full = + Pair_t + ( (List_t (Operation_t None, None), None, None), + (storage_type, None, None), + None ) + in + trace + (Ill_typed_contract (code, [])) + (parse_returning + (Toplevel + { + storage_type; + param_type = arg_type; + root_name; + legacy_create_contract_literal = false; + }) + ctxt + ~legacy + ~stack_depth:0 + ?type_logger + (arg_type_full, None) + ret_type_full + code_field) + >|=? fun (code, ctxt) -> + (Ex_code {code; arg_type; storage_type; root_name}, ctxt) + +let parse_storage : + ?type_logger:type_logger -> + context -> + legacy:bool -> + allow_forged:bool -> + 'storage ty -> + storage:lazy_expr -> + ('storage * context) tzresult Lwt.t = + fun ?type_logger ctxt ~legacy ~allow_forged storage_type ~storage -> + Script.force_decode_in_context ctxt storage + >>?= fun (storage, ctxt) -> + trace_eval + (fun () -> + Lwt.return + ( serialize_ty_for_error ctxt storage_type + >|? fun (storage_type, _ctxt) -> + Ill_typed_data (None, storage, storage_type) )) + (parse_data + ?type_logger + ~stack_depth:0 + ctxt + ~legacy + ~allow_forged + storage_type + (root storage)) + +let parse_script : + ?type_logger:type_logger -> + context -> + legacy:bool -> + allow_forged_in_storage:bool -> + Script.t -> + (ex_script * context) tzresult Lwt.t = + fun ?type_logger ctxt ~legacy ~allow_forged_in_storage {code; storage} -> + parse_code ~legacy ctxt ?type_logger ~code + >>=? fun (Ex_code {code; arg_type; storage_type; root_name}, ctxt) -> + parse_storage + ?type_logger + ctxt + ~legacy + ~allow_forged:allow_forged_in_storage + storage_type + ~storage + >|=? fun (storage, ctxt) -> + (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt) + +let typecheck_code : + legacy:bool -> + context -> + Script.expr -> + (type_map * context) tzresult Lwt.t = + fun ~legacy ctxt code -> + parse_toplevel ~legacy code + >>?= fun (arg_type, storage_type, code_field, root_name) -> + let type_map = ref [] in + record_trace + (Ill_formed_type (Some "parameter", code, location arg_type)) + (parse_parameter_ty ctxt ~legacy arg_type) + >>?= fun (Ex_ty arg_type, ctxt) -> + (if legacy then ok_unit else well_formed_entrypoints ~root_name arg_type) + >>?= fun () -> + record_trace + (Ill_formed_type (Some "storage", code, location storage_type)) + (parse_storage_ty ctxt ~legacy storage_type) + >>?= fun (Ex_ty storage_type, ctxt) -> + let arg_annot = + default_annot + (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot + in + let storage_annot = + default_annot + (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot + in + let arg_type_full = + Pair_t + ((arg_type, None, arg_annot), (storage_type, None, storage_annot), None) + in + let ret_type_full = + Pair_t + ( (List_t (Operation_t None, None), None, None), + (storage_type, None, None), + None ) + in + let result = + parse_returning + (Toplevel + { + storage_type; + param_type = arg_type; + root_name; + legacy_create_contract_literal = false; + }) + ctxt + ~legacy + ~stack_depth:0 + ~type_logger:(fun loc bef aft -> + type_map := (loc, (bef, aft)) :: !type_map) + (arg_type_full, None) + ret_type_full + code_field + in + trace (Ill_typed_contract (code, !type_map)) result + >|=? fun (Lam _, ctxt) -> (!type_map, ctxt) + +module Entrypoints_map = Map.Make (String) + +let list_entrypoints (type full) (full : full ty) ctxt ~root_name = + let merge path annot (type t) (ty : t ty) reachable + ((unreachables, all) as acc) = + match annot with + | None | Some (Field_annot "") -> ( + ok + @@ + if reachable then acc + else + match ty with + | Union_t _ -> + acc + | _ -> + (List.rev path :: unreachables, all) ) + | Some (Field_annot name) -> + if Compare.Int.(String.length name > 31) then + ok (List.rev path :: unreachables, all) + else if Entrypoints_map.mem name all then + ok (List.rev path :: unreachables, all) + else + unparse_ty ctxt ty + >>? fun (unparsed_ty, _) -> + ok + ( unreachables, + Entrypoints_map.add name (List.rev path, unparsed_ty) all ) + in + let rec fold_tree : + type t. + t ty -> + prim list -> + bool -> + prim list list * (prim list * Script.node) Entrypoints_map.t -> + (prim list list * (prim list * Script.node) Entrypoints_map.t) tzresult = + fun t path reachable acc -> + match t with + | Union_t ((tl, al), (tr, ar), _) -> + merge (D_Left :: path) al tl reachable acc + >>? fun acc -> + merge (D_Right :: path) ar tr reachable acc + >>? fun acc -> + fold_tree + tl + (D_Left :: path) + (match al with Some _ -> true | None -> reachable) + acc + >>? fun acc -> + fold_tree + tr + (D_Right :: path) + (match ar with Some _ -> true | None -> reachable) + acc + | _ -> + ok acc + in + unparse_ty ctxt full + >>? fun (unparsed_full, _) -> + let (init, reachable) = + match root_name with + | None | Some (Field_annot "") -> + (Entrypoints_map.empty, false) + | Some (Field_annot name) -> + (Entrypoints_map.singleton name ([], unparsed_full), true) + in + fold_tree full [] reachable ([], init) + +(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) + +(* -- Unparsing data of primitive types -- *) + +let unparse_unit ctxt () = ok (Prim (-1, D_Unit, [], []), ctxt) + +let unparse_int ctxt v = ok (Int (-1, Script_int.to_zint v), ctxt) + +let unparse_nat ctxt v = ok (Int (-1, Script_int.to_zint v), ctxt) + +let unparse_string ctxt s = ok (String (-1, s), ctxt) + +let unparse_bytes ctxt s = ok (Bytes (-1, s), ctxt) + +let unparse_bool ctxt b = + ok (Prim (-1, (if b then D_True else D_False), [], []), ctxt) + +let unparse_timestamp ctxt mode t = + match mode with + | Optimized | Optimized_legacy -> + ok (Int (-1, Script_timestamp.to_zint t), ctxt) + | Readable -> ( + Gas.consume ctxt Unparse_costs.timestamp_readable + >>? fun ctxt -> + match Script_timestamp.to_notation t with + | None -> + ok (Int (-1, Script_timestamp.to_zint t), ctxt) + | Some s -> + ok (String (-1, s), ctxt) ) + +let unparse_address ctxt mode (c, entrypoint) = + Gas.consume ctxt Unparse_costs.contract + >>? fun ctxt -> + ( match entrypoint with + (* given parse_address, this should not happen *) + | "" -> + error Unparsing_invariant_violated + | _ -> + ok () ) + >|? fun () -> + match mode with + | Optimized | Optimized_legacy -> + let entrypoint = + match entrypoint with "default" -> "" | name -> name + in + let bytes = + Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Contract.encoding Variable.string) + (c, entrypoint) + in + (Bytes (-1, bytes), ctxt) + | Readable -> + let notation = + match entrypoint with + | "default" -> + Contract.to_b58check c + | entrypoint -> + Contract.to_b58check c ^ "%" ^ entrypoint + in + (String (-1, notation), ctxt) + +let unparse_contract ctxt mode (_, address) = unparse_address ctxt mode address + +let unparse_signature ctxt mode s = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.signature_optimized + >|? fun ctxt -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in + (Bytes (-1, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.signature_readable + >|? fun ctxt -> (String (-1, Signature.to_b58check s), ctxt) + +let unparse_mutez ctxt v = ok (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) + +let unparse_key ctxt mode k = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.public_key_optimized + >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k + in + (Bytes (-1, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.public_key_readable + >|? fun ctxt -> (String (-1, Signature.Public_key.to_b58check k), ctxt) + +let unparse_key_hash ctxt mode k = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.key_hash_optimized + >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k + in + (Bytes (-1, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.key_hash_readable + >|? fun ctxt -> + (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) + +let unparse_operation ctxt (op, _big_map_diff) = + let bytes = + Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op + in + Gas.consume ctxt (Unparse_costs.operation bytes) + >|? fun ctxt -> (Bytes (-1, bytes), ctxt) + +let unparse_chain_id ctxt mode chain_id = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.chain_id_optimized + >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id + in + (Bytes (-1, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.chain_id_readable + >|? fun ctxt -> (String (-1, Chain_id.to_b58check chain_id), ctxt) + +let unparse_bls12_381_g1 ctxt x = + Gas.consume ctxt Unparse_costs.bls12_381_g1 + >|? fun ctxt -> + let bytes = Bls12_381.G1.to_bytes x in + (Bytes (-1, bytes), ctxt) + +let unparse_bls12_381_g2 ctxt x = + Gas.consume ctxt Unparse_costs.bls12_381_g2 + >|? fun ctxt -> + let bytes = Bls12_381.G2.to_bytes x in + (Bytes (-1, bytes), ctxt) + +let unparse_bls12_381_fr ctxt x = + Gas.consume ctxt Unparse_costs.bls12_381_fr + >|? fun ctxt -> + let bytes = Bls12_381.Fr.to_bytes x in + (Bytes (-1, bytes), ctxt) + +(* -- Unparsing data of complex types -- *) + +let unparse_pair (type r) unparse_l unparse_r ctxt mode + (r_comb_witness : (r, unit -> unit -> _) comb_witness) (l, (r : r)) = + unparse_l ctxt l + >>=? fun (l, ctxt) -> + unparse_r ctxt r + >|=? fun (r, ctxt) -> + (* Fold combs. + For combs, three notations are supported: + - a) [Pair x1 (Pair x2 ... (Pair xn-1 xn) ...)], + - b) [Pair x1 x2 ... xn-1 xn], and + - c) [{x1; x2; ...; xn-1; xn}]. + In readable mode, we always use b), + in optimized mode we use the shortest to serialize: + - for n=2, [Pair x1 x2], + - for n=3, [Pair x1 (Pair x2 x3)], + - for n>=4, [{x1; x2; ...; xn}]. + *) + let res = + match (mode, r_comb_witness, r) with + | (Optimized, Comb_Pair _, Micheline.Seq (_, r)) -> + (* Optimized case n > 4 *) + Micheline.Seq (-1, l :: r) + | ( Optimized, + Comb_Pair (Comb_Pair _), + Prim (_, D_Pair, [x2; Prim (_, D_Pair, [x3; x4], [])], []) ) -> + (* Optimized case n = 4 *) + Micheline.Seq (-1, [l; x2; x3; x4]) + | (Readable, Comb_Pair _, Prim (_, D_Pair, xs, [])) -> + (* Readable case n > 2 *) + Prim (-1, D_Pair, l :: xs, []) + | _ -> + (* The remaining cases are: + - Optimized n = 2, + - Optimized n = 3, and + - Readable n = 2, + - Optimized_legacy, any n *) + Prim (-1, D_Pair, [l; r], []) + in + (res, ctxt) + +let unparse_union unparse_l unparse_r ctxt = function + | L l -> + unparse_l ctxt l >|=? fun (l, ctxt) -> (Prim (-1, D_Left, [l], []), ctxt) + | R r -> + unparse_r ctxt r >|=? fun (r, ctxt) -> (Prim (-1, D_Right, [r], []), ctxt) + +let unparse_option unparse_v ctxt = function + | Some v -> + unparse_v ctxt v >|=? fun (v, ctxt) -> (Prim (-1, D_Some, [v], []), ctxt) + | None -> + return (Prim (-1, D_None, [], []), ctxt) + +(* -- Unparsing data of comparable types -- *) + +let comparable_comb_witness2 : + type t. t comparable_ty -> (t, unit -> unit -> unit) comb_witness = + function + | Pair_key (_, (Pair_key _, _), _) -> + Comb_Pair (Comb_Pair Comb_Any) + | Pair_key _ -> + Comb_Pair Comb_Any + | _ -> + Comb_Any + +let rec unparse_comparable_data : + type a. + context -> + unparsing_mode -> + a comparable_ty -> + a -> + (Script.node * context) tzresult Lwt.t = + fun ctxt mode ty a -> + (* No need for stack_depth here. Unlike [unparse_data], + [unparse_comparable_data] doesn't call [unparse_code]. + The stack depth is bounded by the type depth, currently bounded + by 1000 (michelson_maximum_type_size). *) + Gas.consume ctxt Unparse_costs.unparse_data_cycle + (* We could have a smaller cost but let's keep it consistent with + [unparse_data] for now. *) + >>?= fun ctxt -> + match (ty, a) with + | (Unit_key _, v) -> + Lwt.return @@ unparse_unit ctxt v + | (Int_key _, v) -> + Lwt.return @@ unparse_int ctxt v + | (Nat_key _, v) -> + Lwt.return @@ unparse_nat ctxt v + | (String_key _, s) -> + Lwt.return @@ unparse_string ctxt s + | (Bytes_key _, s) -> + Lwt.return @@ unparse_bytes ctxt s + | (Bool_key _, b) -> + Lwt.return @@ unparse_bool ctxt b + | (Timestamp_key _, t) -> + Lwt.return @@ unparse_timestamp ctxt mode t + | (Address_key _, address) -> + Lwt.return @@ unparse_address ctxt mode address + | (Signature_key _, s) -> + Lwt.return @@ unparse_signature ctxt mode s + | (Mutez_key _, v) -> + Lwt.return @@ unparse_mutez ctxt v + | (Key_key _, k) -> + Lwt.return @@ unparse_key ctxt mode k + | (Key_hash_key _, k) -> + Lwt.return @@ unparse_key_hash ctxt mode k + | (Chain_id_key _, chain_id) -> + Lwt.return @@ unparse_chain_id ctxt mode chain_id + | (Pair_key ((tl, _), (tr, _), _), pair) -> + let r_witness = comparable_comb_witness2 tr in + let unparse_l ctxt v = unparse_comparable_data ctxt mode tl v in + let unparse_r ctxt v = unparse_comparable_data ctxt mode tr v in + unparse_pair unparse_l unparse_r ctxt mode r_witness pair + | (Union_key ((tl, _), (tr, _), _), v) -> + let unparse_l ctxt v = unparse_comparable_data ctxt mode tl v in + let unparse_r ctxt v = unparse_comparable_data ctxt mode tr v in + unparse_union unparse_l unparse_r ctxt v + | (Option_key (t, _), v) -> + let unparse_v ctxt v = unparse_comparable_data ctxt mode t v in + unparse_option unparse_v ctxt v + | (Never_key _, _) -> + . + +(* -- Unparsing data of any type -- *) + +let comb_witness2 : type t. t ty -> (t, unit -> unit -> unit) comb_witness = + function + | Pair_t (_, (Pair_t _, _, _), _) -> + Comb_Pair (Comb_Pair Comb_Any) + | Pair_t _ -> + Comb_Pair Comb_Any + | _ -> + Comb_Any + +let rec unparse_data : + type a. + context -> + stack_depth:int -> + unparsing_mode -> + a ty -> + a -> + (Script.node * context) tzresult Lwt.t = + fun ctxt ~stack_depth mode ty a -> + Gas.consume ctxt Unparse_costs.unparse_data_cycle + >>?= fun ctxt -> + let non_terminal_recursion ctxt mode ty a = + if Compare.Int.(stack_depth > 10_000) then + fail Unparsing_too_many_recursive_calls + else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a + in + match (ty, a) with + | (Unit_t _, v) -> + Lwt.return @@ unparse_unit ctxt v + | (Int_t _, v) -> + Lwt.return @@ unparse_int ctxt v + | (Nat_t _, v) -> + Lwt.return @@ unparse_nat ctxt v + | (String_t _, s) -> + Lwt.return @@ unparse_string ctxt s + | (Bytes_t _, s) -> + Lwt.return @@ unparse_bytes ctxt s + | (Bool_t _, b) -> + Lwt.return @@ unparse_bool ctxt b + | (Timestamp_t _, t) -> + Lwt.return @@ unparse_timestamp ctxt mode t + | (Address_t _, address) -> + Lwt.return @@ unparse_address ctxt mode address + | (Contract_t _, contract) -> + Lwt.return @@ unparse_contract ctxt mode contract + | (Signature_t _, s) -> + Lwt.return @@ unparse_signature ctxt mode s + | (Mutez_t _, v) -> + Lwt.return @@ unparse_mutez ctxt v + | (Key_t _, k) -> + Lwt.return @@ unparse_key ctxt mode k + | (Key_hash_t _, k) -> + Lwt.return @@ unparse_key_hash ctxt mode k + | (Operation_t _, operation) -> + Lwt.return @@ unparse_operation ctxt operation + | (Chain_id_t _, chain_id) -> + Lwt.return @@ unparse_chain_id ctxt mode chain_id + | (Bls12_381_g1_t _, x) -> + Lwt.return @@ unparse_bls12_381_g1 ctxt x + | (Bls12_381_g2_t _, x) -> + Lwt.return @@ unparse_bls12_381_g2 ctxt x + | (Bls12_381_fr_t _, x) -> + Lwt.return @@ unparse_bls12_381_fr ctxt x + | (Pair_t ((tl, _, _), (tr, _, _), _), pair) -> + let r_witness = comb_witness2 tr in + let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in + let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in + unparse_pair unparse_l unparse_r ctxt mode r_witness pair + | (Union_t ((tl, _), (tr, _), _), v) -> + let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in + let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in + unparse_union unparse_l unparse_r ctxt v + | (Option_t (t, _), v) -> + let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in + unparse_option unparse_v ctxt v + | (List_t (t, _), items) -> + fold_left_s + (fun (l, ctxt) element -> + non_terminal_recursion ctxt mode t element + >|=? fun (unparsed, ctxt) -> (unparsed :: l, ctxt)) + ([], ctxt) + items.elements + >|=? fun (items, ctxt) -> (Micheline.Seq (-1, List.rev items), ctxt) + | (Ticket_t (t, _), {ticketer; contents; amount}) -> + let t = ty_of_comparable_ty @@ opened_ticket_type t in + unparse_data ctxt ~stack_depth mode t (ticketer, (contents, amount)) + | (Set_t (t, _), set) -> + fold_left_s + (fun (l, ctxt) item -> + unparse_comparable_data ctxt mode t item + >|=? fun (item, ctxt) -> (item :: l, ctxt)) + ([], ctxt) + (set_fold (fun e acc -> e :: acc) set []) + >|=? fun (items, ctxt) -> (Micheline.Seq (-1, items), ctxt) + | (Map_t (kt, vt, _), map) -> + let items = map_fold (fun k v acc -> (k, v) :: acc) map [] in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (-1, items), ctxt) + | (Big_map_t (_kt, _vt, _), {id = Some id; diff = (module Diff); _}) + when Diff.OPS.is_empty (fst Diff.boxed) -> + return (Micheline.Int (-1, Big_map.Id.unparse_to_z id), ctxt) + | (Big_map_t (kt, vt, _), {id = Some id; diff = (module Diff); _}) -> + let items = + Diff.OPS.fold (fun k v acc -> (k, v) :: acc) (fst Diff.boxed) [] + in + let vt = Option_t (vt, None) in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> + ( Micheline.Prim + ( -1, + D_Pair, + [Int (-1, Big_map.Id.unparse_to_z id); Seq (-1, items)], + [] ), + ctxt ) + | (Big_map_t (kt, vt, _), {id = None; diff = (module Diff); _}) -> + let items = + Diff.OPS.fold + (fun k v acc -> match v with None -> acc | Some v -> (k, v) :: acc) + (fst Diff.boxed) + [] + in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (-1, items), ctxt) + | (Lambda_t _, Lam (_, original_code)) -> + unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code + | (Never_t _, _) -> + . + | (Sapling_transaction_t _, s) -> + Lwt.return + ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) + >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s + in + (Bytes (-1, bytes), ctxt) ) + | (Sapling_state_t _, {id; diff; _}) -> + Lwt.return + ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) + >|? fun ctxt -> + ( ( match diff with + | {commitments_and_ciphertexts = []; nullifiers = []} -> ( + match id with + | None -> + Micheline.Seq (-1, []) + | Some id -> + let id = Sapling.Id.unparse_to_z id in + Micheline.Int (-1, id) ) + | diff -> ( + let diff_bytes = + Data_encoding.Binary.to_bytes_exn Sapling.diff_encoding diff + in + let unparsed_diff = Bytes (-1, diff_bytes) in + match id with + | None -> + unparsed_diff + | Some id -> + let id = Sapling.Id.unparse_to_z id in + Micheline.Prim (-1, D_Pair, [Int (-1, id); unparsed_diff], []) + ) ), + ctxt ) ) + +and unparse_items : + type k v. + context -> + stack_depth:int -> + unparsing_mode -> + k comparable_ty -> + v ty -> + (k * v) list -> + (Script.node list * context) tzresult Lwt.t = + fun ctxt ~stack_depth mode kt vt items -> + fold_left_s + (fun (l, ctxt) (k, v) -> + unparse_comparable_data ctxt mode kt k + >>=? fun (key, ctxt) -> + unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v + >|=? fun (value, ctxt) -> (Prim (-1, D_Elt, [key; value], []) :: l, ctxt)) + ([], ctxt) + items + +and unparse_code ctxt ~stack_depth mode code = + let legacy = true in + Gas.consume ctxt Unparse_costs.unparse_instr_cycle + >>?= fun ctxt -> + let non_terminal_recursion ctxt mode code = + if Compare.Int.(stack_depth > 10_000) then + fail Unparsing_too_many_recursive_calls + else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code + in + match code with + | Prim (loc, I_PUSH, [ty; data], annot) -> + parse_packable_ty ctxt ~legacy ty + >>?= fun (Ex_ty t, ctxt) -> + let allow_forged = + false + (* Forgeable in PUSH data are already forbidden at parsing, + the only case for which this matters is storing a lambda resulting + from APPLYing a non-forgeable but this cannot happen either as long + as all packable values are also forgeable. *) + in + parse_data + ctxt + ~stack_depth:(stack_depth + 1) + ~legacy + ~allow_forged + t + data + >>=? fun (data, ctxt) -> + unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data + >>=? fun (data, ctxt) -> + return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) + | Seq (loc, items) -> + fold_left_s + (fun (l, ctxt) item -> + non_terminal_recursion ctxt mode item + >|=? fun (item, ctxt) -> (item :: l, ctxt)) + ([], ctxt) + items + >>=? fun (items, ctxt) -> + return (Micheline.Seq (loc, List.rev items), ctxt) + | Prim (loc, prim, items, annot) -> + fold_left_s + (fun (l, ctxt) item -> + non_terminal_recursion ctxt mode item + >|=? fun (item, ctxt) -> (item :: l, ctxt)) + ([], ctxt) + items + >>=? fun (items, ctxt) -> + return (Prim (loc, prim, List.rev items, annot), ctxt) + | (Int _ | String _ | Bytes _) as atom -> + return (atom, ctxt) + +(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) +let unparse_script ctxt mode {code; arg_type; storage; storage_type; root_name} + = + let (Lam (_, original_code)) = code in + unparse_code ctxt ~stack_depth:0 mode original_code + >>=? fun (code, ctxt) -> + unparse_data ctxt ~stack_depth:0 mode storage_type storage + >>=? fun (storage, ctxt) -> + Lwt.return + ( unparse_ty ctxt arg_type + >>? fun (arg_type, ctxt) -> + unparse_ty ctxt storage_type + >>? fun (storage_type, ctxt) -> + let arg_type = add_field_annot root_name None arg_type in + let open Micheline in + let code = + Seq + ( -1, + [ Prim (-1, K_parameter, [arg_type], []); + Prim (-1, K_storage, [storage_type], []); + Prim (-1, K_code, [code], []) ] ) + in + Gas.consume ctxt Unparse_costs.unparse_instr_cycle + >>? fun ctxt -> + Gas.consume ctxt Unparse_costs.unparse_instr_cycle + >>? fun ctxt -> + Gas.consume ctxt Unparse_costs.unparse_instr_cycle + >>? fun ctxt -> + Gas.consume ctxt Unparse_costs.unparse_instr_cycle + >>? fun ctxt -> + Gas.consume ctxt (Script.strip_locations_cost code) + >>? fun ctxt -> + Gas.consume ctxt (Script.strip_locations_cost storage) + >|? fun ctxt -> + ( { + code = lazy_expr (strip_locations code); + storage = lazy_expr (strip_locations storage); + }, + ctxt ) ) + +let pack_node unparsed ctxt = + Gas.consume ctxt (Script.strip_locations_cost unparsed) + >>? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn + expr_encoding + (Micheline.strip_locations unparsed) + in + Gas.consume ctxt (Script.serialized_cost bytes) + >>? fun ctxt -> + let bytes = Bytes.cat (Bytes.of_string "\005") bytes in + Gas.consume ctxt (Script.serialized_cost bytes) >|? fun ctxt -> (bytes, ctxt) + +let pack_data ctxt typ data ~mode = + unparse_data ~stack_depth:0 ctxt mode typ data + >>=? fun (unparsed, ctxt) -> Lwt.return @@ pack_node unparsed ctxt + +let pack_comparable_data ctxt typ data ~mode = + unparse_comparable_data ctxt mode typ data + >>=? fun (unparsed, ctxt) -> Lwt.return @@ pack_node unparsed ctxt + +let hash_bytes ctxt bytes = + Gas.consume ctxt (Michelson_v1_gas.Cost_of.Interpreter.blake2b bytes) + >|? fun ctxt -> (Script_expr_hash.(hash_bytes [bytes]), ctxt) + +let hash_data ctxt typ data = + pack_data ctxt typ data ~mode:Optimized_legacy + >>=? fun (bytes, ctxt) -> Lwt.return @@ hash_bytes ctxt bytes + +let hash_comparable_data ctxt typ data = + pack_comparable_data ctxt typ data ~mode:Optimized_legacy + >>=? fun (bytes, ctxt) -> Lwt.return @@ hash_bytes ctxt bytes + +let pack_data ctxt typ data = pack_data ctxt typ data ~mode:Optimized_legacy + +(* ---------------- Big map -------------------------------------------------*) + +let empty_big_map key_type value_type = + {id = None; diff = empty_map key_type; key_type; value_type} + +let big_map_mem ctxt key {id; diff; key_type; _} = + match (map_get key diff, id) with + | (None, None) -> + return (false, ctxt) + | (None, Some id) -> + hash_comparable_data ctxt key_type key + >>=? fun (hash, ctxt) -> + Alpha_context.Big_map.mem ctxt id hash >|=? fun (ctxt, res) -> (res, ctxt) + | (Some None, _) -> + return (false, ctxt) + | (Some (Some _), _) -> + return (true, ctxt) + +let big_map_get ctxt key {id; diff; key_type; value_type} = + match (map_get key diff, id) with + | (Some x, _) -> + return (x, ctxt) + | (None, None) -> + return (None, ctxt) + | (None, Some id) -> ( + hash_comparable_data ctxt key_type key + >>=? fun (hash, ctxt) -> + Alpha_context.Big_map.get_opt ctxt id hash + >>=? function + | (ctxt, None) -> + return (None, ctxt) + | (ctxt, Some value) -> + parse_data + ~stack_depth:0 + ctxt + ~legacy:true + ~allow_forged:true + value_type + (Micheline.root value) + >|=? fun (x, ctxt) -> (Some x, ctxt) ) + +let big_map_update key value ({diff; _} as map) = + {map with diff = map_set key value diff} + +(* ---------------- Lazy storage---------------------------------------------*) + +type lazy_storage_ids = Lazy_storage.IdSet.t + +let no_lazy_storage_id = Lazy_storage.IdSet.empty + +let diff_of_big_map ctxt mode ~temporary ~ids_to_copy + {id; key_type; value_type; diff} = + ( match id with + | Some id -> + if Lazy_storage.IdSet.mem Big_map id ids_to_copy then + Big_map.fresh ~temporary ctxt + >|=? fun (ctxt, duplicate) -> + (ctxt, Lazy_storage.Copy {src = id}, duplicate) + else + (* The first occurrence encountered of a big_map reuses the + ID. This way, the payer is only charged for the diff. + For this to work, this diff has to be put at the end of + the global diff, otherwise the duplicates will use the + updated version as a base. This is true because we add + this diff first in the accumulator of + `extract_lazy_storage_updates`, and this accumulator is not + reversed. *) + return (ctxt, Lazy_storage.Existing, id) + | None -> + Big_map.fresh ~temporary ctxt + >>=? fun (ctxt, id) -> + Lwt.return + (let kt = unparse_comparable_ty key_type in + Gas.consume ctxt (Script.strip_locations_cost kt) + >>? fun ctxt -> + unparse_ty ctxt value_type + >>? fun (kv, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost kv) + >|? fun ctxt -> + let key_type = Micheline.strip_locations kt in + let value_type = Micheline.strip_locations kv in + (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id)) ) + >>=? fun (ctxt, init, id) -> + let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in + fold_left_s + (fun (acc, ctxt) (key, value) -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle + >>?= fun ctxt -> + hash_comparable_data ctxt key_type key + >>=? fun (key_hash, ctxt) -> + unparse_comparable_data ctxt mode key_type key + >>=? fun (key_node, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost key_node) + >>?= fun ctxt -> + let key = Micheline.strip_locations key_node in + ( match value with + | None -> + return (None, ctxt) + | Some x -> + unparse_data ~stack_depth:0 ctxt mode value_type x + >>=? fun (node, ctxt) -> + Lwt.return + ( Gas.consume ctxt (Script.strip_locations_cost node) + >|? fun ctxt -> (Some (Micheline.strip_locations node), ctxt) ) ) + >|=? fun (value, ctxt) -> + let diff_item = Big_map.{key; key_hash; value} in + (diff_item :: acc, ctxt)) + ([], ctxt) + (List.rev pairs) + >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) + +let diff_of_sapling_state ctxt ~temporary ~ids_to_copy + ({id; diff; memo_size} : Sapling.state) = + ( match id with + | Some id -> + if Lazy_storage.IdSet.mem Sapling_state id ids_to_copy then + Sapling.fresh ~temporary ctxt + >|=? fun (ctxt, duplicate) -> + (ctxt, Lazy_storage.Copy {src = id}, duplicate) + else return (ctxt, Lazy_storage.Existing, id) + | None -> + Sapling.fresh ~temporary ctxt + >|=? fun (ctxt, id) -> (ctxt, Lazy_storage.Alloc Sapling.{memo_size}, id) + ) + >|=? fun (ctxt, init, id) -> + (Lazy_storage.Update {init; updates = diff}, id, ctxt) + +(** + Witness flag for whether a type can be populated by a value containing a + lazy storage. + [False_f] must be used only when a value of the type cannot contain a lazy + storage. + + This flag is built in [has_lazy_storage] and used only in + [extract_lazy_storage_updates] and [collect_lazy_storage]. + + This flag is necessary to avoid these two functions to have a quadratic + complexity in the size of the type. + + Add new lazy storage kinds here. + + Please keep the usage of this GADT local. +*) +type 'ty has_lazy_storage = + | True_f : _ has_lazy_storage + | False_f : _ has_lazy_storage + | Pair_f : + 'a has_lazy_storage * 'b has_lazy_storage + -> ('a, 'b) pair has_lazy_storage + | Union_f : + 'a has_lazy_storage * 'b has_lazy_storage + -> ('a, 'b) union has_lazy_storage + | Option_f : 'a has_lazy_storage -> 'a option has_lazy_storage + | List_f : 'a has_lazy_storage -> 'a boxed_list has_lazy_storage + | Map_f : 'v has_lazy_storage -> (_, 'v) map has_lazy_storage + +(** + This function is called only on storage and parameter types of contracts, + once per typechecked contract. It has a complexity linear in the size of + the types, which happen to be literally written types, so the gas for them + has already been paid. +*) +let rec has_lazy_storage : type t. t ty -> t has_lazy_storage = + let aux1 cons t = + match has_lazy_storage t with False_f -> False_f | h -> cons h + in + let aux2 cons t1 t2 = + match (has_lazy_storage t1, has_lazy_storage t2) with + | (False_f, False_f) -> + False_f + | (h1, h2) -> + cons h1 h2 + in + function + | Big_map_t (_, _, _) -> + True_f + | Sapling_state_t _ -> + True_f + | Unit_t _ -> + False_f + | Int_t _ -> + False_f + | Nat_t _ -> + False_f + | Signature_t _ -> + False_f + | String_t _ -> + False_f + | Bytes_t _ -> + False_f + | Mutez_t _ -> + False_f + | Key_hash_t _ -> + False_f + | Key_t _ -> + False_f + | Timestamp_t _ -> + False_f + | Address_t _ -> + False_f + | Bool_t _ -> + False_f + | Lambda_t (_, _, _) -> + False_f + | Set_t (_, _) -> + False_f + | Contract_t (_, _) -> + False_f + | Operation_t _ -> + False_f + | Chain_id_t _ -> + False_f + | Never_t _ -> + False_f + | Bls12_381_g1_t _ -> + False_f + | Bls12_381_g2_t _ -> + False_f + | Bls12_381_fr_t _ -> + False_f + | Sapling_transaction_t _ -> + False_f + | Ticket_t _ -> + False_f + | Pair_t ((l, _, _), (r, _, _), _) -> + aux2 (fun l r -> Pair_f (l, r)) l r + | Union_t ((l, _), (r, _), _) -> + aux2 (fun l r -> Union_f (l, r)) l r + | Option_t (t, _) -> + aux1 (fun h -> Option_f h) t + | List_t (t, _) -> + aux1 (fun h -> List_f h) t + | Map_t (_, t, _) -> + aux1 (fun h -> Map_f h) t + +(** + Transforms a value potentially containing lazy storage in an intermediary + state to a value containing lazy storage only represented by identifiers. + + Returns the updated value, the updated set of ids to copy, and the lazy + storage diff to show on the receipt and apply on the storage. +*) +let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = + let rec aux : + type a. + context -> + unparsing_mode -> + temporary:bool -> + Lazy_storage.IdSet.t -> + Lazy_storage.diffs -> + a ty -> + a -> + has_lazy_storage:a has_lazy_storage -> + (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t + = + fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle + >>?= fun ctxt -> + match (has_lazy_storage, ty, x) with + | (False_f, _, _) -> + return (ctxt, x, ids_to_copy, acc) + | (_, Big_map_t (_, _, _), map) -> + diff_of_big_map ctxt mode ~temporary ~ids_to_copy map + >|=? fun (diff, id, ctxt) -> + let (module Map) = map.diff in + let map = {map with diff = empty_map Map.key_ty; id = Some id} in + let diff = Lazy_storage.make Big_map id diff in + let ids_to_copy = Lazy_storage.IdSet.add Big_map id ids_to_copy in + (ctxt, map, ids_to_copy, diff :: acc) + | (_, Sapling_state_t _, sapling_state) -> + diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state + >|=? fun (diff, id, ctxt) -> + let sapling_state = + Sapling.empty_state ~id ~memo_size:sapling_state.memo_size () + in + let diff = Lazy_storage.make Sapling_state id diff in + let ids_to_copy = + Lazy_storage.IdSet.add Sapling_state id ids_to_copy + in + (ctxt, sapling_state, ids_to_copy, diff :: acc) + | (Pair_f (hl, hr), Pair_t ((tyl, _, _), (tyr, _, _), _), (xl, xr)) -> + aux ctxt mode ~temporary ids_to_copy acc tyl xl ~has_lazy_storage:hl + >>=? fun (ctxt, xl, ids_to_copy, acc) -> + aux ctxt mode ~temporary ids_to_copy acc tyr xr ~has_lazy_storage:hr + >|=? fun (ctxt, xr, ids_to_copy, acc) -> + (ctxt, (xl, xr), ids_to_copy, acc) + | (Union_f (has_lazy_storage, _), Union_t ((ty, _), (_, _), _), L x) -> + aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) + | (Union_f (_, has_lazy_storage), Union_t ((_, _), (ty, _), _), R x) -> + aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) + | (Option_f has_lazy_storage, Option_t (ty, _), Some x) -> + aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, Some x, ids_to_copy, acc) + | (List_f has_lazy_storage, List_t (ty, _), l) -> + fold_left_s + (fun (ctxt, l, ids_to_copy, acc) x -> + aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> + (ctxt, list_cons x l, ids_to_copy, acc)) + (ctxt, list_empty, ids_to_copy, acc) + l.elements + >|=? fun (ctxt, l, ids_to_copy, acc) -> + let reversed = {length = l.length; elements = List.rev l.elements} in + (ctxt, reversed, ids_to_copy, acc) + | (Map_f has_lazy_storage, Map_t (_, ty, _), (module M)) -> + fold_left_s + (fun (ctxt, m, ids_to_copy, acc) (k, x) -> + aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> + (ctxt, M.OPS.add k x m, ids_to_copy, acc)) + (ctxt, M.OPS.empty, ids_to_copy, acc) + (M.OPS.bindings (fst M.boxed)) + >|=? fun (ctxt, m, ids_to_copy, acc) -> + let module M = struct + module OPS = M.OPS + + type key = M.key + + type value = M.value + + let key_ty = M.key_ty + + let boxed = (m, snd M.boxed) + end in + ( ctxt, + (module M : Boxed_map with type key = M.key and type value = M.value), + ids_to_copy, + acc ) + | (_, Option_t (_, _), None) -> + return (ctxt, None, ids_to_copy, acc) + | _ -> + assert false + (* TODO: fix injectivity of types *) + in + let has_lazy_storage = has_lazy_storage ty in + aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage + +let rec fold_lazy_storage : + type a. + f:'acc Lazy_storage.IdSet.fold_f -> + init:'acc -> + context -> + a ty -> + a -> + has_lazy_storage:a has_lazy_storage -> + ('acc * context) tzresult = + fun ~f ~init ctxt ty x ~has_lazy_storage -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle + >>? fun ctxt -> + match (has_lazy_storage, ty, x) with + | (_, Big_map_t (_, _, _), {id = Some id}) -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle + >>? fun ctxt -> ok (f.f Big_map id init, ctxt) + | (_, Sapling_state_t _, {id = Some id}) -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle + >>? fun ctxt -> ok (f.f Sapling_state id init, ctxt) + | (False_f, _, _) -> + ok (init, ctxt) + | (_, Big_map_t (_, _, _), {id = None}) -> + ok (init, ctxt) + | (_, Sapling_state_t _, {id = None}) -> + ok (init, ctxt) + | (Pair_f (hl, hr), Pair_t ((tyl, _, _), (tyr, _, _), _), (xl, xr)) -> + fold_lazy_storage ~f ~init ctxt tyl xl ~has_lazy_storage:hl + >>? fun (init, ctxt) -> + fold_lazy_storage ~f ~init ctxt tyr xr ~has_lazy_storage:hr + | (Union_f (has_lazy_storage, _), Union_t ((ty, _), (_, _), _), L x) -> + fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage + | (Union_f (_, has_lazy_storage), Union_t ((_, _), (ty, _), _), R x) -> + fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage + | (_, Option_t (_, _), None) -> + ok (init, ctxt) + | (Option_f has_lazy_storage, Option_t (ty, _), Some x) -> + fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage + | (List_f has_lazy_storage, List_t (ty, _), l) -> + List.fold_left + (fun acc x -> + acc + >>? fun (init, ctxt) -> + fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage) + (ok (init, ctxt)) + l.elements + | (Map_f has_lazy_storage, Map_t (_, ty, _), m) -> + map_fold + (fun _ v acc -> + acc + >>? fun (init, ctxt) -> + fold_lazy_storage ~f ~init ctxt ty v ~has_lazy_storage) + m + (ok (init, ctxt)) + | _ -> + (* TODO: fix injectivity of types *) assert false + +let collect_lazy_storage ctxt ty x = + let has_lazy_storage = has_lazy_storage ty in + fold_lazy_storage + ~f:{f = (fun kind id acc -> Lazy_storage.IdSet.add kind id acc)} + ~init:no_lazy_storage_id + ctxt + ty + x + ~has_lazy_storage + +let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty + v = + (* + Basically [to_duplicate] are ids from the argument and [to_update] are ids + from the storage before execution (i.e. it is safe to reuse them since they + will be owned by the same contract). + *) + let to_duplicate = Lazy_storage.IdSet.diff to_duplicate to_update in + extract_lazy_storage_updates ctxt mode ~temporary to_duplicate [] ty v + >|=? fun (ctxt, v, alive, diffs) -> + let diffs = + if temporary then diffs + else + let dead = Lazy_storage.IdSet.diff to_update alive in + Lazy_storage.IdSet.fold_all + {f = (fun kind id acc -> Lazy_storage.make kind id Remove :: acc)} + dead + diffs + in + match diffs with + | [] -> + (v, None, ctxt) + | diffs -> + (v, Some diffs (* do not reverse *), ctxt) + +let list_of_big_map_ids ids = + Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids [] + +let parse_data = parse_data ~stack_depth:0 + +let parse_instr = parse_instr ~stack_depth:0 + +let unparse_data = unparse_data ~stack_depth:0 + +let unparse_code = unparse_code ~stack_depth:0 + +let get_single_sapling_state ctxt ty x = + let has_lazy_storage = has_lazy_storage ty in + let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i) + single_id_opt : Sapling.Id.t option = + match kind with + | Lazy_storage.Kind.Sapling_state -> ( + match single_id_opt with None -> Some id | Some _ -> raise Not_found + (* more than one *) ) + | _ -> + single_id_opt + in + fold_lazy_storage ~f:{f} ~init:None ctxt ty x ~has_lazy_storage + >>? function (None, _) -> raise Not_found | (Some id, ctxt) -> ok (id, ctxt) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_translator.mli b/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_translator.mli new file mode 100644 index 0000000000000000000000000000000000000000..09aa2b3403aaa8d4c1c382bffc9584c1a1cbbbf9 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_ir_translator.mli @@ -0,0 +1,351 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script_tc_errors + +type ('ta, 'tb) eq = Eq : ('same, 'same) eq + +type ex_comparable_ty = + | Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> ex_comparable_ty + +type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty + +type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty + +type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script + +type ('arg, 'storage) code = { + code : + ( ('arg, 'storage) Script_typed_ir.pair, + ( Script_typed_ir.operation Script_typed_ir.boxed_list, + 'storage ) + Script_typed_ir.pair ) + Script_typed_ir.lambda; + arg_type : 'arg Script_typed_ir.ty; + storage_type : 'storage Script_typed_ir.ty; + root_name : Script_typed_ir.field_annot option; +} + +type ex_code = Ex_code : ('a, 'c) code -> ex_code + +type tc_context = + | Lambda : tc_context + | Dip : 'a Script_typed_ir.stack_ty * tc_context -> tc_context + | Toplevel : { + storage_type : 'sto Script_typed_ir.ty; + param_type : 'param Script_typed_ir.ty; + root_name : Script_typed_ir.field_annot option; + legacy_create_contract_literal : bool; + } + -> tc_context + +type 'bef judgement = + | Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement + | Failed : { + descr : + 'aft. 'aft Script_typed_ir.stack_ty -> + ('bef, 'aft) Script_typed_ir.descr; + } + -> 'bef judgement + +type unparsing_mode = Optimized | Readable | Optimized_legacy + +type type_logger = + int -> + (Script.expr * Script.annot) list -> + (Script.expr * Script.annot) list -> + unit + +(* ---- Lists, Sets and Maps ----------------------------------------------- *) + +val list_empty : 'a Script_typed_ir.boxed_list + +val list_cons : + 'a -> 'a Script_typed_ir.boxed_list -> 'a Script_typed_ir.boxed_list + +val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set + +val set_fold : + ('elt -> 'acc -> 'acc) -> 'elt Script_typed_ir.set -> 'acc -> 'acc + +val set_update : 'a -> bool -> 'a Script_typed_ir.set -> 'a Script_typed_ir.set + +val set_mem : 'elt -> 'elt Script_typed_ir.set -> bool + +val set_size : 'elt Script_typed_ir.set -> Script_int.n Script_int.num + +val empty_map : + 'a Script_typed_ir.comparable_ty -> ('a, 'b) Script_typed_ir.map + +val map_fold : + ('key -> 'value -> 'acc -> 'acc) -> + ('key, 'value) Script_typed_ir.map -> + 'acc -> + 'acc + +val map_update : + 'a -> + 'b option -> + ('a, 'b) Script_typed_ir.map -> + ('a, 'b) Script_typed_ir.map + +val map_mem : 'key -> ('key, 'value) Script_typed_ir.map -> bool + +val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option + +val map_key_ty : + ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty + +val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num + +val empty_big_map : + 'a Script_typed_ir.comparable_ty -> + 'b Script_typed_ir.ty -> + ('a, 'b) Script_typed_ir.big_map + +val big_map_mem : + context -> + 'key -> + ('key, 'value) Script_typed_ir.big_map -> + (bool * context) tzresult Lwt.t + +val big_map_get : + context -> + 'key -> + ('key, 'value) Script_typed_ir.big_map -> + ('value option * context) tzresult Lwt.t + +val big_map_update : + 'key -> + 'value option -> + ('key, 'value) Script_typed_ir.big_map -> + ('key, 'value) Script_typed_ir.big_map + +val ty_eq : + context -> + Script.location -> + 'ta Script_typed_ir.ty -> + 'tb Script_typed_ir.ty -> + (('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq * context) tzresult + +val compare_address : Script_typed_ir.address -> Script_typed_ir.address -> int + +val compare_comparable : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> int + +val parse_comparable_data : + ?type_logger:type_logger -> + context -> + 'a Script_typed_ir.comparable_ty -> + Script.node -> + ('a * context) tzresult Lwt.t + +val parse_data : + ?type_logger:type_logger -> + context -> + legacy:bool -> + allow_forged:bool -> + 'a Script_typed_ir.ty -> + Script.node -> + ('a * context) tzresult Lwt.t + +val unparse_data : + context -> + unparsing_mode -> + 'a Script_typed_ir.ty -> + 'a -> + (Script.node * context) tzresult Lwt.t + +val unparse_code : + context -> + unparsing_mode -> + Script.node -> + (Script.node * context) tzresult Lwt.t + +val parse_instr : + ?type_logger:type_logger -> + tc_context -> + context -> + legacy:bool -> + Script.node -> + 'bef Script_typed_ir.stack_ty -> + ('bef judgement * context) tzresult Lwt.t + +(** + [parse_ty] specialized for the right-hand side part of a big map type, i.e. + the `value` in `big_map key value`. +*) +val parse_big_map_value_ty : + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult + +val parse_packable_ty : + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult + +val parse_parameter_ty : + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult + +val parse_comparable_ty : + context -> Script.node -> (ex_comparable_ty * context) tzresult + +(** We expose [parse_ty] for convenience to external tools. Please use + specialized versions such as [parse_packable_ty], [parse_parameter_ty], + [parse_comparable_ty], or [parse_big_map_value_ty] if possible. *) +val parse_ty : + context -> + legacy:bool -> + allow_lazy_storage:bool -> + allow_operation:bool -> + allow_contract:bool -> + allow_ticket:bool -> + Script.node -> + (ex_ty * context) tzresult + +val unparse_ty : + context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult + +val parse_toplevel : + legacy:bool -> + Script.expr -> + (Script.node * Script.node * Script.node * Script_typed_ir.field_annot option) + tzresult + +val add_field_annot : + Script_typed_ir.field_annot option -> + Script_typed_ir.var_annot option -> + Script.node -> + Script.node + +val typecheck_code : + legacy:bool -> context -> Script.expr -> (type_map * context) tzresult Lwt.t + +val serialize_ty_for_error : + context -> 'a Script_typed_ir.ty -> (Script.expr * context) tzresult + +val parse_code : + ?type_logger:type_logger -> + context -> + legacy:bool -> + code:Script.lazy_expr -> + (ex_code * context) tzresult Lwt.t + +val parse_storage : + ?type_logger:type_logger -> + context -> + legacy:bool -> + allow_forged:bool -> + 'storage Script_typed_ir.ty -> + storage:Script.lazy_expr -> + ('storage * context) tzresult Lwt.t + +(** Combines [parse_code] and [parse_storage] *) +val parse_script : + ?type_logger:type_logger -> + context -> + legacy:bool -> + allow_forged_in_storage:bool -> + Script.t -> + (ex_script * context) tzresult Lwt.t + +(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) +val unparse_script : + context -> + unparsing_mode -> + ('a, 'b) Script_typed_ir.script -> + (Script.t * context) tzresult Lwt.t + +val parse_contract : + legacy:bool -> + context -> + Script.location -> + 'a Script_typed_ir.ty -> + Contract.t -> + entrypoint:string -> + (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t + +val parse_contract_for_script : + legacy:bool -> + context -> + Script.location -> + 'a Script_typed_ir.ty -> + Contract.t -> + entrypoint:string -> + (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t + +val find_entrypoint : + 't Script_typed_ir.ty -> + root_name:Script_typed_ir.field_annot option -> + string -> + ((Script.node -> Script.node) * ex_ty) tzresult + +module Entrypoints_map : S.MAP with type key = string + +val list_entrypoints : + 't Script_typed_ir.ty -> + context -> + root_name:Script_typed_ir.field_annot option -> + ( Michelson_v1_primitives.prim list list + * (Michelson_v1_primitives.prim list * Script.node) Entrypoints_map.t ) + tzresult + +val pack_data : + context -> 'a Script_typed_ir.ty -> 'a -> (bytes * context) tzresult Lwt.t + +val hash_comparable_data : + context -> + 'a Script_typed_ir.comparable_ty -> + 'a -> + (Script_expr_hash.t * context) tzresult Lwt.t + +val hash_data : + context -> + 'a Script_typed_ir.ty -> + 'a -> + (Script_expr_hash.t * context) tzresult Lwt.t + +type lazy_storage_ids + +val no_lazy_storage_id : lazy_storage_ids + +val collect_lazy_storage : + context -> + 'a Script_typed_ir.ty -> + 'a -> + (lazy_storage_ids * context) tzresult + +val list_of_big_map_ids : lazy_storage_ids -> Big_map.Id.t list + +val extract_lazy_storage_diff : + context -> + unparsing_mode -> + temporary:bool -> + to_duplicate:lazy_storage_ids -> + to_update:lazy_storage_ids -> + 'a Script_typed_ir.ty -> + 'a -> + ('a * Lazy_storage.diffs option * context) tzresult Lwt.t + +(* raise Not_found if none or more than one found *) +val get_single_sapling_state : + context -> 'a Script_typed_ir.ty -> 'a -> (Sapling.Id.t * context) tzresult diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/script_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..c9c74ede84691e7db71045f4455b9ee6fed99095 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_repr.ml @@ -0,0 +1,262 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type location = Micheline.canonical_location + +let location_encoding = Micheline.canonical_location_encoding + +type annot = Micheline.annot + +type expr = Michelson_v1_primitives.prim Micheline.canonical + +type lazy_expr = expr Data_encoding.lazy_t + +type node = (location, Michelson_v1_primitives.prim) Micheline.node + +let expr_encoding = + Micheline.canonical_encoding_v1 + ~variant:"michelson_v1" + Michelson_v1_primitives.prim_encoding + +type error += Lazy_script_decode (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"invalid_binary_format" + ~title:"Invalid binary format" + ~description: + "Could not deserialize some piece of data from its binary representation" + Data_encoding.empty + (function Lazy_script_decode -> Some () | _ -> None) + (fun () -> Lazy_script_decode) + +let lazy_expr_encoding = Data_encoding.lazy_encoding expr_encoding + +let lazy_expr expr = Data_encoding.make_lazy expr_encoding expr + +type t = {code : lazy_expr; storage : lazy_expr} + +let encoding = + let open Data_encoding in + def "scripted.contracts" + @@ conv + (fun {code; storage} -> (code, storage)) + (fun (code, storage) -> {code; storage}) + (obj2 (req "code" lazy_expr_encoding) (req "storage" lazy_expr_encoding)) + +let int_node_size_of_numbits n = (1, 1 + ((n + 63) / 64)) + +let int_node_size n = int_node_size_of_numbits (Z.numbits n) + +let string_node_size_of_length s = (1, 1 + ((s + 7) / 8)) + +let string_node_size s = string_node_size_of_length (String.length s) + +let bytes_node_size_of_length s = + (* approx cost of indirection to the C heap *) + (2, 1 + ((s + 7) / 8) + 12) + +let bytes_node_size s = bytes_node_size_of_length (Bytes.length s) + +let prim_node_size_nonrec_of_lengths n_args annots = + let annots_length = + List.fold_left (fun acc s -> acc + String.length s) 0 annots + in + if Compare.Int.(annots_length = 0) then (1 + n_args, 2 + (2 * n_args)) + else (2 + n_args, 4 + (2 * n_args) + ((annots_length + 7) / 8)) + +let prim_node_size_nonrec args annots = + let n_args = List.length args in + prim_node_size_nonrec_of_lengths n_args annots + +let seq_node_size_nonrec_of_length n_args = (1 + n_args, 2 + (2 * n_args)) + +let seq_node_size_nonrec args = + let n_args = List.length args in + seq_node_size_nonrec_of_length n_args + +let convert_pair (i1, i2) = (Z.of_int i1, Z.of_int i2) + +let rec node_size node = + let open Micheline in + match node with + | Int (_, n) -> + convert_pair (int_node_size n) + | String (_, s) -> + convert_pair (string_node_size s) + | Bytes (_, s) -> + convert_pair (bytes_node_size s) + | Prim (_, _, args, annot) -> + List.fold_left + (fun (blocks, words) node -> + let (nblocks, nwords) = node_size node in + (Z.add blocks nblocks, Z.add words nwords)) + (convert_pair (prim_node_size_nonrec args annot)) + args + | Seq (_, args) -> + List.fold_left + (fun (blocks, words) node -> + let (nblocks, nwords) = node_size node in + (Z.add blocks nblocks, Z.add words nwords)) + (convert_pair (seq_node_size_nonrec args)) + args + +let expr_size expr = node_size (Micheline.root expr) + +let traversal_cost node = + let (blocks, _words) = node_size node in + Gas_limit_repr.step_cost blocks + +let cost_of_size (blocks, words) = + let open Gas_limit_repr in + (Compare.Z.max Z.zero (Z.sub blocks Z.one) *@ alloc_cost Z.zero) + +@ alloc_cost words +@ step_cost blocks + +let cost_of_size_int pair = cost_of_size (convert_pair pair) + +let int_node_cost n = cost_of_size_int (int_node_size n) + +let int_node_cost_of_numbits n = cost_of_size_int (int_node_size_of_numbits n) + +let string_node_cost s = cost_of_size_int (string_node_size s) + +let string_node_cost_of_length s = + cost_of_size_int (string_node_size_of_length s) + +let bytes_node_cost s = cost_of_size_int (bytes_node_size s) + +let bytes_node_cost_of_length s = + cost_of_size_int (bytes_node_size_of_length s) + +let prim_node_cost_nonrec args annot = + cost_of_size_int (prim_node_size_nonrec args annot) + +let seq_node_cost_nonrec args = cost_of_size_int (seq_node_size_nonrec args) + +let seq_node_cost_nonrec_of_length n_args = + cost_of_size_int (seq_node_size_nonrec_of_length n_args) + +let deserialized_cost expr = cost_of_size (expr_size expr) + +let serialized_cost bytes = + let open Gas_limit_repr in + alloc_bytes_cost (Bytes.length bytes) + +let force_decode lexpr = + let account_deserialization_cost = + Data_encoding.apply_lazy + ~fun_value:(fun _ -> false) + ~fun_bytes:(fun _ -> true) + ~fun_combine:(fun _ _ -> false) + lexpr + in + match Data_encoding.force_decode lexpr with + | Some v -> + if account_deserialization_cost then ok (v, deserialized_cost v) + else ok (v, Gas_limit_repr.free) + | None -> + error Lazy_script_decode + +let force_bytes expr = + let open Gas_limit_repr in + let account_serialization_cost = + Data_encoding.apply_lazy + ~fun_value:(fun v -> Some v) + ~fun_bytes:(fun _ -> None) + ~fun_combine:(fun _ _ -> None) + expr + in + match Data_encoding.force_bytes expr with + | bytes -> ( + match account_serialization_cost with + | Some v -> + ok (bytes, traversal_cost (Micheline.root v) +@ serialized_cost bytes) + | None -> + ok (bytes, Gas_limit_repr.free) ) + | exception _ -> + error Lazy_script_decode + +let minimal_deserialize_cost lexpr = + Data_encoding.apply_lazy + ~fun_value:(fun _ -> Gas_limit_repr.free) + ~fun_bytes:(fun b -> serialized_cost b) + ~fun_combine:(fun c_free _ -> c_free) + lexpr + +let unit = + Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], [])) + +let unit_parameter = lazy_expr unit + +let is_unit_parameter = + let unit_bytes = Data_encoding.force_bytes unit_parameter in + Data_encoding.apply_lazy + ~fun_value:(fun v -> + match Micheline.root v with + | Prim (_, Michelson_v1_primitives.D_Unit, [], []) -> + true + | _ -> + false) + ~fun_bytes:(fun b -> Compare.Bytes.equal b unit_bytes) + ~fun_combine:(fun res _ -> res) + +let rec strip_annotations node = + let open Micheline in + match node with + | (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf -> + leaf + | Prim (loc, name, args, _) -> + Prim (loc, name, List.map strip_annotations args, []) + | Seq (loc, args) -> + Seq (loc, List.map strip_annotations args) + +let rec micheline_nodes node acc k = + match node with + | Micheline.Int (_, _) -> + k (acc + 1) + | Micheline.String (_, _) -> + k (acc + 1) + | Micheline.Bytes (_, _) -> + k (acc + 1) + | Micheline.Prim (_, _, subterms, _) -> + micheline_nodes_list subterms (acc + 1) k + | Micheline.Seq (_, subterms) -> + micheline_nodes_list subterms (acc + 1) k + +and micheline_nodes_list subterms acc k = + match subterms with + | [] -> + k acc + | n :: nodes -> + micheline_nodes_list nodes acc (fun acc -> micheline_nodes n acc k) + +let micheline_nodes node = micheline_nodes node 0 (fun x -> x) + +let cost_MICHELINE_STRIP_LOCATIONS size = Z.mul (Z.of_int size) (Z.of_int 100) + +let strip_locations_cost node = + let nodes = micheline_nodes node in + Gas_limit_repr.atomic_step_cost (cost_MICHELINE_STRIP_LOCATIONS nodes) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/script_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..d78c39e3aadb74867c8a55cdca296bbd2d7b215e --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_repr.mli @@ -0,0 +1,88 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type location = Micheline.canonical_location + +type annot = Micheline.annot + +type expr = Michelson_v1_primitives.prim Micheline.canonical + +type error += Lazy_script_decode (* `Permanent *) + +type lazy_expr = expr Data_encoding.lazy_t + +type node = (location, Michelson_v1_primitives.prim) Micheline.node + +val location_encoding : location Data_encoding.t + +val expr_encoding : expr Data_encoding.t + +val lazy_expr_encoding : lazy_expr Data_encoding.t + +val lazy_expr : expr -> lazy_expr + +type t = {code : lazy_expr; storage : lazy_expr} + +val encoding : t Data_encoding.encoding + +val deserialized_cost : expr -> Gas_limit_repr.cost + +val serialized_cost : bytes -> Gas_limit_repr.cost + +val traversal_cost : node -> Gas_limit_repr.cost + +val int_node_cost : Z.t -> Gas_limit_repr.cost + +val int_node_cost_of_numbits : int -> Gas_limit_repr.cost + +val string_node_cost : string -> Gas_limit_repr.cost + +val string_node_cost_of_length : int -> Gas_limit_repr.cost + +val bytes_node_cost : bytes -> Gas_limit_repr.cost + +val bytes_node_cost_of_length : int -> Gas_limit_repr.cost + +val prim_node_cost_nonrec : expr list -> annot -> Gas_limit_repr.cost + +val seq_node_cost_nonrec : expr list -> Gas_limit_repr.cost + +val seq_node_cost_nonrec_of_length : int -> Gas_limit_repr.cost + +val force_decode : lazy_expr -> (expr * Gas_limit_repr.cost) tzresult + +val force_bytes : lazy_expr -> (bytes * Gas_limit_repr.cost) tzresult + +val minimal_deserialize_cost : lazy_expr -> Gas_limit_repr.cost + +val unit_parameter : lazy_expr + +val is_unit_parameter : lazy_expr -> bool + +val strip_annotations : node -> node + +val micheline_nodes : node -> int + +val strip_locations_cost : node -> Gas_limit_repr.cost diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_tc_errors.ml b/src/proto_008_PtEdo2Zk/lib_protocol/script_tc_errors.ml new file mode 100644 index 0000000000000000000000000000000000000000..412d9f729a9b269dd8620cefc39edff9b910d675 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_tc_errors.ml @@ -0,0 +1,191 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script + +(* ---- Error definitions ---------------------------------------------------*) + +type kind = Int_kind | String_kind | Bytes_kind | Prim_kind | Seq_kind + +type unparsed_stack_ty = (Script.expr * Script.annot) list + +type type_map = (int * (unparsed_stack_ty * unparsed_stack_ty)) list + +(* Structure errors *) +type error += Invalid_arity of Script.location * prim * int * int + +type error += Invalid_seq_arity of Script.location * int * int + +type error += + | Invalid_namespace of + Script.location + * prim + * Michelson_v1_primitives.namespace + * Michelson_v1_primitives.namespace + +type error += Invalid_primitive of Script.location * prim list * prim + +type error += Invalid_kind of Script.location * kind list * kind + +type error += Invalid_never_expr of Script.location + +type error += Missing_field of prim + +type error += Duplicate_field of Script.location * prim + +type error += Unexpected_lazy_storage of Script.location + +type error += Unexpected_operation of Script.location + +type error += Unexpected_contract of Script.location + +type error += No_such_entrypoint of string + +type error += Duplicate_entrypoint of string + +type error += Unreachable_entrypoint of prim list + +type error += Entrypoint_name_too_long of string + +(* Instruction typing errors *) +type error += Fail_not_in_tail_position of Script.location + +type error += + | Undefined_binop : + Script.location * prim * Script.expr * Script.expr + -> error + +type error += Undefined_unop : Script.location * prim * Script.expr -> error + +type error += + | Bad_return : Script.location * unparsed_stack_ty * Script.expr -> error + +type error += + | Bad_stack : Script.location * prim * int * unparsed_stack_ty -> error + +type error += + | Unmatched_branches : + Script.location * unparsed_stack_ty * unparsed_stack_ty + -> error + +type error += Self_in_lambda of Script.location + +type error += Bad_stack_length + +type error += Bad_stack_item of int + +type error += Inconsistent_annotations of string * string + +type error += + | Inconsistent_type_annotations : + Script.location * Script.expr * Script.expr + -> error + +type error += Inconsistent_field_annotations of string * string + +type error += Unexpected_annotation of Script.location + +type error += Ungrouped_annotations of Script.location + +type error += Invalid_map_body : Script.location * unparsed_stack_ty -> error + +type error += Invalid_map_block_fail of Script.location + +type error += + | Invalid_iter_body : + Script.location * unparsed_stack_ty * unparsed_stack_ty + -> error + +type error += Type_too_large : Script.location * int * int -> error + +type error += Pair_bad_argument of Script.location + +type error += Unpair_bad_argument of Script.location + +type error += Dup_n_bad_argument of Script.location + +type error += Dup_n_bad_stack of Script.location + +(* Value typing errors *) +type error += + | Invalid_constant : Script.location * Script.expr * Script.expr -> error + +type error += + | Invalid_syntactic_constant : + Script.location * Script.expr * string + -> error + +type error += Invalid_contract of Script.location * Contract.t + +type error += Invalid_big_map of Script.location * Big_map.Id.t + +type error += + | Comparable_type_expected : Script.location * Script.expr -> error + +type error += Inconsistent_types : Script.expr * Script.expr -> error + +type error += + | Inconsistent_memo_sizes : + Sapling.Memo_size.t * Sapling.Memo_size.t + -> error + +type error += Unordered_map_keys of Script.location * Script.expr + +type error += Unordered_set_values of Script.location * Script.expr + +type error += Duplicate_map_keys of Script.location * Script.expr + +type error += Duplicate_set_values of Script.location * Script.expr + +(* Toplevel errors *) +type error += + | Ill_typed_data : string option * Script.expr * Script.expr -> error + +type error += + | Ill_formed_type of string option * Script.expr * Script.location + +type error += Ill_typed_contract : Script.expr * type_map -> error + +(* Gas related errors *) +type error += Cannot_serialize_error + +(* Deprecation errors *) +type error += Deprecated_instruction of prim + +(* Stackoverflow errors *) +type error += Typechecking_too_many_recursive_calls + +type error += Unparsing_too_many_recursive_calls + +(* Ticket errors *) +type error += Unexpected_ticket of Script.location + +type error += Unexpected_forged_value of Script.location + +type error += Non_dupable_type of Script.location * Script.expr + +(* Impossible errors *) +type error += Unparsing_invariant_violated diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_tc_errors_registration.ml b/src/proto_008_PtEdo2Zk/lib_protocol/script_tc_errors_registration.ml new file mode 100644 index 0000000000000000000000000000000000000000..cb62174f77affc1a47eb239ff5f4b92b9d9e7946 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_tc_errors_registration.ml @@ -0,0 +1,778 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script +open Script_tc_errors + +(* Helpers for encoding *) +let type_map_enc = + let open Data_encoding in + let stack_enc = list (tup2 Script.expr_encoding (list string)) in + list + (conv + (fun (loc, (bef, aft)) -> (loc, bef, aft)) + (fun (loc, bef, aft) -> (loc, (bef, aft))) + (obj3 + (req "location" Script.location_encoding) + (req "stack_before" stack_enc) + (req "stack_after" stack_enc))) + +let stack_ty_enc = + let open Data_encoding in + list (obj2 (req "type" Script.expr_encoding) (dft "annots" (list string) [])) + +(* main registration *) +let () = + let open Data_encoding in + let located enc = + merge_objs (obj1 (req "location" Script.location_encoding)) enc + in + let arity_enc = int8 in + let namespace_enc = + def + "primitiveNamespace" + ~title:"Primitive namespace" + ~description: + "One of the four possible namespaces of primitive (data constructor, \ + type name, instruction or keyword)." + @@ string_enum + [ ("type", Michelson_v1_primitives.Type_namespace); + ("constant", Constant_namespace); + ("instruction", Instr_namespace); + ("keyword", Keyword_namespace) ] + in + let kind_enc = + def + "expressionKind" + ~title:"Expression kind" + ~description: + "One of the four possible kinds of expression (integer, string, \ + primitive application or sequence)." + @@ string_enum + [ ("integer", Int_kind); + ("string", String_kind); + ("bytes", Bytes_kind); + ("primitiveApplication", Prim_kind); + ("sequence", Seq_kind) ] + in + (* -- Structure errors ---------------------- *) + (* Invalid arity *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_arity" + ~title:"Invalid arity" + ~description: + "In a script or data expression, a primitive was applied to an \ + unsupported number of arguments." + (located + (obj3 + (req "primitive_name" Script.prim_encoding) + (req "expected_arity" arity_enc) + (req "wrong_arity" arity_enc))) + (function + | Invalid_arity (loc, name, exp, got) -> + Some (loc, (name, exp, got)) + | _ -> + None) + (fun (loc, (name, exp, got)) -> Invalid_arity (loc, name, exp, got)) ; + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_seq_arity" + ~title:"Invalid sequence arity" + ~description: + "In a script or data expression, a sequence was used with a number of \ + elements too small." + (located + (obj2 + (req "minimal_expected_arity" arity_enc) + (req "wrong_arity" arity_enc))) + (function + | Invalid_seq_arity (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None) + (fun (loc, (exp, got)) -> Invalid_seq_arity (loc, exp, got)) ; + (* Missing field *) + register_error_kind + `Permanent + ~id:"michelson_v1.missing_script_field" + ~title:"Script is missing a field (parse error)" + ~description:"When parsing script, a field was expected, but not provided" + (obj1 (req "prim" prim_encoding)) + (function Missing_field prim -> Some prim | _ -> None) + (fun prim -> Missing_field prim) ; + (* Invalid primitive *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_primitive" + ~title:"Invalid primitive" + ~description:"In a script or data expression, a primitive was unknown." + (located + (obj2 + (dft "expected_primitive_names" (list prim_encoding) []) + (req "wrong_primitive_name" prim_encoding))) + (function + | Invalid_primitive (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None) + (fun (loc, (exp, got)) -> Invalid_primitive (loc, exp, got)) ; + (* Invalid kind *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_expression_kind" + ~title:"Invalid expression kind" + ~description: + "In a script or data expression, an expression was of the wrong kind \ + (for instance a string where only a primitive applications can appear)." + (located + (obj2 (req "expected_kinds" (list kind_enc)) (req "wrong_kind" kind_enc))) + (function + | Invalid_kind (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None) + (fun (loc, (exp, got)) -> Invalid_kind (loc, exp, got)) ; + (* Invalid namespace *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_primitive_namespace" + ~title:"Invalid primitive namespace" + ~description: + "In a script or data expression, a primitive was of the wrong namespace." + (located + (obj3 + (req "primitive_name" prim_encoding) + (req "expected_namespace" namespace_enc) + (req "wrong_namespace" namespace_enc))) + (function + | Invalid_namespace (loc, name, exp, got) -> + Some (loc, (name, exp, got)) + | _ -> + None) + (fun (loc, (name, exp, got)) -> Invalid_namespace (loc, name, exp, got)) ; + (* Invalid literal for type never *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_never_expr" + ~title:"Invalid expression for type never" + ~description: + "In a script or data expression, an expression was provided but a value \ + of type never was expected. No expression can have type never." + (located unit) + (function Invalid_never_expr loc -> Some (loc, ()) | _ -> None) + (fun (loc, ()) -> Invalid_never_expr loc) ; + (* Duplicate field *) + register_error_kind + `Permanent + ~id:"michelson_v1.duplicate_script_field" + ~title:"Script has a duplicated field (parse error)" + ~description:"When parsing script, a field was found more than once" + (obj2 (req "loc" location_encoding) (req "prim" prim_encoding)) + (function Duplicate_field (loc, prim) -> Some (loc, prim) | _ -> None) + (fun (loc, prim) -> Duplicate_field (loc, prim)) ; + (* Unexpected big_map *) + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_lazy_storage" + ~title:"Lazy storage in unauthorized position (type error)" + ~description: + "When parsing script, a big_map or sapling_state type was found in a \ + position where it could end up stored inside a big_map, which is \ + forbidden for now." + (obj1 (req "loc" location_encoding)) + (function Unexpected_lazy_storage loc -> Some loc | _ -> None) + (fun loc -> Unexpected_lazy_storage loc) ; + (* Unexpected operation *) + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_operation" + ~title:"Operation in unauthorized position (type error)" + ~description: + "When parsing script, an operation type was found in the storage or \ + parameter field." + (obj1 (req "loc" location_encoding)) + (function Unexpected_operation loc -> Some loc | _ -> None) + (fun loc -> Unexpected_operation loc) ; + (* No such entrypoint *) + register_error_kind + `Permanent + ~id:"michelson_v1.no_such_entrypoint" + ~title:"No such entrypoint (type error)" + ~description:"An entrypoint was not found when calling a contract." + (obj1 (req "entrypoint" string)) + (function No_such_entrypoint entrypoint -> Some entrypoint | _ -> None) + (fun entrypoint -> No_such_entrypoint entrypoint) ; + (* Unreachable entrypoint *) + register_error_kind + `Permanent + ~id:"michelson_v1.unreachable_entrypoint" + ~title:"Unreachable entrypoint (type error)" + ~description:"An entrypoint in the contract is not reachable." + (obj1 (req "path" (list prim_encoding))) + (function Unreachable_entrypoint path -> Some path | _ -> None) + (fun path -> Unreachable_entrypoint path) ; + (* Duplicate entrypoint *) + register_error_kind + `Permanent + ~id:"michelson_v1.duplicate_entrypoint" + ~title:"Duplicate entrypoint (type error)" + ~description:"Two entrypoints have the same name." + (obj1 (req "path" string)) + (function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None) + (fun entrypoint -> Duplicate_entrypoint entrypoint) ; + (* Entrypoint name too long *) + register_error_kind + `Permanent + ~id:"michelson_v1.entrypoint_name_too_long" + ~title:"Entrypoint name too long (type error)" + ~description: + "An entrypoint name exceeds the maximum length of 31 characters." + (obj1 (req "name" string)) + (function + | Entrypoint_name_too_long entrypoint -> Some entrypoint | _ -> None) + (fun entrypoint -> Entrypoint_name_too_long entrypoint) ; + (* Unexpected contract *) + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_contract" + ~title:"Contract in unauthorized position (type error)" + ~description: + "When parsing script, a contract type was found in the storage or \ + parameter field." + (obj1 (req "loc" location_encoding)) + (function Unexpected_contract loc -> Some loc | _ -> None) + (fun loc -> Unexpected_contract loc) ; + (* -- Value typing errors ---------------------- *) + (* Unordered map keys *) + register_error_kind + `Permanent + ~id:"michelson_v1.unordered_map_literal" + ~title:"Invalid map key order" + ~description:"Map keys must be in strictly increasing order" + (obj2 + (req "location" Script.location_encoding) + (req "item" Script.expr_encoding)) + (function Unordered_map_keys (loc, expr) -> Some (loc, expr) | _ -> None) + (fun (loc, expr) -> Unordered_map_keys (loc, expr)) ; + (* Duplicate map keys *) + register_error_kind + `Permanent + ~id:"michelson_v1.duplicate_map_keys" + ~title:"Duplicate map keys" + ~description:"Map literals cannot contain duplicated keys" + (obj2 + (req "location" Script.location_encoding) + (req "item" Script.expr_encoding)) + (function Duplicate_map_keys (loc, expr) -> Some (loc, expr) | _ -> None) + (fun (loc, expr) -> Duplicate_map_keys (loc, expr)) ; + (* Unordered set values *) + register_error_kind + `Permanent + ~id:"michelson_v1.unordered_set_literal" + ~title:"Invalid set value order" + ~description:"Set values must be in strictly increasing order" + (obj2 + (req "location" Script.location_encoding) + (req "value" Script.expr_encoding)) + (function + | Unordered_set_values (loc, expr) -> Some (loc, expr) | _ -> None) + (fun (loc, expr) -> Unordered_set_values (loc, expr)) ; + (* Duplicate set values *) + register_error_kind + `Permanent + ~id:"michelson_v1.duplicate_set_values_in_literal" + ~title:"Sets literals cannot contain duplicate elements" + ~description: + "Set literals cannot contain duplicate elements, but a duplicate was \ + found while parsing." + (obj2 + (req "location" Script.location_encoding) + (req "value" Script.expr_encoding)) + (function + | Duplicate_set_values (loc, expr) -> Some (loc, expr) | _ -> None) + (fun (loc, expr) -> Duplicate_set_values (loc, expr)) ; + (* -- Instruction typing errors ------------- *) + (* Fail not in tail position *) + register_error_kind + `Permanent + ~id:"michelson_v1.fail_not_in_tail_position" + ~title:"FAIL not in tail position" + ~description:"There is non trivial garbage code after a FAIL instruction." + (located empty) + (function Fail_not_in_tail_position loc -> Some (loc, ()) | _ -> None) + (fun (loc, ()) -> Fail_not_in_tail_position loc) ; + (* Undefined binary operation *) + register_error_kind + `Permanent + ~id:"michelson_v1.undefined_binop" + ~title:"Undefined binop" + ~description: + "A binary operation is called on operands of types over which it is not \ + defined." + (located + (obj3 + (req "operator_name" prim_encoding) + (req "wrong_left_operand_type" Script.expr_encoding) + (req "wrong_right_operand_type" Script.expr_encoding))) + (function + | Undefined_binop (loc, n, tyl, tyr) -> + Some (loc, (n, tyl, tyr)) + | _ -> + None) + (fun (loc, (n, tyl, tyr)) -> Undefined_binop (loc, n, tyl, tyr)) ; + (* Undefined unary operation *) + register_error_kind + `Permanent + ~id:"michelson_v1.undefined_unop" + ~title:"Undefined unop" + ~description: + "A unary operation is called on an operand of type over which it is not \ + defined." + (located + (obj2 + (req "operator_name" prim_encoding) + (req "wrong_operand_type" Script.expr_encoding))) + (function Undefined_unop (loc, n, ty) -> Some (loc, (n, ty)) | _ -> None) + (fun (loc, (n, ty)) -> Undefined_unop (loc, n, ty)) ; + (* Bad return *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_return" + ~title:"Bad return" + ~description:"Unexpected stack at the end of a lambda or script." + (located + (obj2 + (req "expected_return_type" Script.expr_encoding) + (req "wrong_stack_type" stack_ty_enc))) + (function Bad_return (loc, sty, ty) -> Some (loc, (ty, sty)) | _ -> None) + (fun (loc, (ty, sty)) -> Bad_return (loc, sty, ty)) ; + (* Bad stack *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_stack" + ~title:"Bad stack" + ~description:"The stack has an unexpected length or contents." + (located + (obj3 + (req "primitive_name" prim_encoding) + (req "relevant_stack_portion" int16) + (req "wrong_stack_type" stack_ty_enc))) + (function + | Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, sty)) | _ -> None) + (fun (loc, (name, s, sty)) -> Bad_stack (loc, name, s, sty)) ; + (* Inconsistent annotations *) + register_error_kind + `Permanent + ~id:"michelson_v1.inconsistent_annotations" + ~title:"Annotations inconsistent between branches" + ~description:"The annotations on two types could not be merged" + (obj2 (req "annot1" string) (req "annot2" string)) + (function + | Inconsistent_annotations (annot1, annot2) -> + Some (annot1, annot2) + | _ -> + None) + (fun (annot1, annot2) -> Inconsistent_annotations (annot1, annot2)) ; + (* Inconsistent field annotations *) + register_error_kind + `Permanent + ~id:"michelson_v1.inconsistent_field_annotations" + ~title:"Annotations for field accesses is inconsistent" + ~description: + "The specified field does not match the field annotation in the type" + (obj2 (req "annot1" string) (req "annot2" string)) + (function + | Inconsistent_field_annotations (annot1, annot2) -> + Some (annot1, annot2) + | _ -> + None) + (fun (annot1, annot2) -> Inconsistent_field_annotations (annot1, annot2)) ; + (* Inconsistent type annotations *) + register_error_kind + `Permanent + ~id:"michelson_v1.inconsistent_type_annotations" + ~title:"Types contain inconsistent annotations" + ~description:"The two types contain annotations that do not match" + (located + (obj2 + (req "type1" Script.expr_encoding) + (req "type2" Script.expr_encoding))) + (function + | Inconsistent_type_annotations (loc, ty1, ty2) -> + Some (loc, (ty1, ty2)) + | _ -> + None) + (fun (loc, (ty1, ty2)) -> Inconsistent_type_annotations (loc, ty1, ty2)) ; + (* Unexpected annotation *) + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_annotation" + ~title:"An annotation was encountered where no annotation is expected" + ~description:"A node in the syntax tree was improperly annotated" + (located empty) + (function Unexpected_annotation loc -> Some (loc, ()) | _ -> None) + (fun (loc, ()) -> Unexpected_annotation loc) ; + (* Ungrouped annotations *) + register_error_kind + `Permanent + ~id:"michelson_v1.ungrouped_annotations" + ~title:"Annotations of the same kind were found spread apart" + ~description:"Annotations of the same kind must be grouped" + (located empty) + (function Ungrouped_annotations loc -> Some (loc, ()) | _ -> None) + (fun (loc, ()) -> Ungrouped_annotations loc) ; + (* Unmatched branches *) + register_error_kind + `Permanent + ~id:"michelson_v1.unmatched_branches" + ~title:"Unmatched branches" + ~description: + "At the join point at the end of two code branches the stacks have \ + inconsistent lengths or contents." + (located + (obj2 + (req "first_stack_type" stack_ty_enc) + (req "other_stack_type" stack_ty_enc))) + (function + | Unmatched_branches (loc, stya, styb) -> + Some (loc, (stya, styb)) + | _ -> + None) + (fun (loc, (stya, styb)) -> Unmatched_branches (loc, stya, styb)) ; + (* Bad stack item *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_stack_item" + ~title:"Bad stack item" + ~description: + "The type of a stack item is unexpected (this error is always \ + accompanied by a more precise one)." + (obj1 (req "item_level" int16)) + (function Bad_stack_item n -> Some n | _ -> None) + (fun n -> Bad_stack_item n) ; + (* SELF in lambda *) + register_error_kind + `Permanent + ~id:"michelson_v1.self_in_lambda" + ~title:"SELF instruction in lambda" + ~description:"A SELF instruction was encountered in a lambda expression." + (located empty) + (function Self_in_lambda loc -> Some (loc, ()) | _ -> None) + (fun (loc, ()) -> Self_in_lambda loc) ; + (* Bad stack length *) + register_error_kind + `Permanent + ~id:"michelson_v1.inconsistent_stack_lengths" + ~title:"Inconsistent stack lengths" + ~description: + "A stack was of an unexpected length (this error is always in the \ + context of a located error)." + empty + (function Bad_stack_length -> Some () | _ -> None) + (fun () -> Bad_stack_length) ; + (* -- Value typing errors ------------------- *) + (* Invalid constant *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_constant" + ~title:"Invalid constant" + ~description:"A data expression was invalid for its expected type." + (located + (obj2 + (req "expected_type" Script.expr_encoding) + (req "wrong_expression" Script.expr_encoding))) + (function + | Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None) + (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ; + (* Invalid syntactic constant *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_syntactic_constant" + ~title:"Invalid constant (parse error)" + ~description:"A compile-time constant was invalid for its expected form." + (located + (obj2 + (req "expected_form" string) + (req "wrong_expression" Script.expr_encoding))) + (function + | Invalid_syntactic_constant (loc, expr, expected) -> + Some (loc, (expected, expr)) + | _ -> + None) + (fun (loc, (expected, expr)) -> + Invalid_syntactic_constant (loc, expr, expected)) ; + (* Invalid contract *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_contract" + ~title:"Invalid contract" + ~description: + "A script or data expression references a contract that does not exist \ + or assumes a wrong type for an existing contract." + (located (obj1 (req "contract" Contract.encoding))) + (function Invalid_contract (loc, c) -> Some (loc, c) | _ -> None) + (fun (loc, c) -> Invalid_contract (loc, c)) ; + (* Invalid big_map *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_big_map" + ~title:"Invalid big_map" + ~description: + "A script or data expression references a big_map that does not exist \ + or assumes a wrong type for an existing big_map." + (located (obj1 (req "big_map" Big_map.Id.encoding))) + (function Invalid_big_map (loc, c) -> Some (loc, c) | _ -> None) + (fun (loc, c) -> Invalid_big_map (loc, c)) ; + (* Comparable type expected *) + register_error_kind + `Permanent + ~id:"michelson_v1.comparable_type_expected" + ~title:"Comparable type expected" + ~description: + "A non comparable type was used in a place where only comparable types \ + are accepted." + (located (obj1 (req "wrong_type" Script.expr_encoding))) + (function + | Comparable_type_expected (loc, ty) -> Some (loc, ty) | _ -> None) + (fun (loc, ty) -> Comparable_type_expected (loc, ty)) ; + (* Inconsistent types *) + register_error_kind + `Permanent + ~id:"michelson_v1.inconsistent_types" + ~title:"Inconsistent types" + ~description: + "This is the basic type clash error, that appears in several places \ + where the equality of two types have to be proven, it is always \ + accompanied with another error that provides more context." + (obj2 + (req "first_type" Script.expr_encoding) + (req "other_type" Script.expr_encoding)) + (function Inconsistent_types (tya, tyb) -> Some (tya, tyb) | _ -> None) + (fun (tya, tyb) -> Inconsistent_types (tya, tyb)) ; + (* Inconsistent memo_sizes *) + register_error_kind + `Permanent + ~id:"michelson_v1.inconsistent_memo_sizes" + ~title:"Inconsistent memo sizes" + ~description: + "Memo sizes of two sapling states or transactions do not match" + (obj2 + (req "first_memo_size" Sapling.Memo_size.encoding) + (req "other_memo_size" Sapling.Memo_size.encoding)) + (function + | Inconsistent_memo_sizes (msa, msb) -> Some (msa, msb) | _ -> None) + (fun (msa, msb) -> Inconsistent_memo_sizes (msa, msb)) ; + (* -- Instruction typing errors ------------------- *) + (* Invalid map body *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_map_body" + ~title:"Invalid map body" + ~description:"The body of a map block did not match the expected type" + (obj2 (req "loc" Script.location_encoding) (req "body_type" stack_ty_enc)) + (function Invalid_map_body (loc, stack) -> Some (loc, stack) | _ -> None) + (fun (loc, stack) -> Invalid_map_body (loc, stack)) ; + (* Invalid map block FAIL *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_map_block_fail" + ~title:"FAIL instruction occurred as body of map block" + ~description: + "FAIL cannot be the only instruction in the body. The proper type of \ + the return list cannot be inferred." + (obj1 (req "loc" Script.location_encoding)) + (function Invalid_map_block_fail loc -> Some loc | _ -> None) + (fun loc -> Invalid_map_block_fail loc) ; + (* Invalid ITER body *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_iter_body" + ~title:"ITER body returned wrong stack type" + ~description: + "The body of an ITER instruction must result in the same stack type as \ + before the ITER." + (obj3 + (req "loc" Script.location_encoding) + (req "bef_stack" stack_ty_enc) + (req "aft_stack" stack_ty_enc)) + (function + | Invalid_iter_body (loc, bef, aft) -> Some (loc, bef, aft) | _ -> None) + (fun (loc, bef, aft) -> Invalid_iter_body (loc, bef, aft)) ; + (* Type too large *) + register_error_kind + `Permanent + ~id:"michelson_v1.type_too_large" + ~title:"Stack item type too large" + ~description:"An instruction generated a type larger than the limit." + (obj3 + (req "loc" Script.location_encoding) + (req "type_size" uint16) + (req "maximum_type_size" uint16)) + (function + | Type_too_large (loc, ts, maxts) -> Some (loc, ts, maxts) | _ -> None) + (fun (loc, ts, maxts) -> Type_too_large (loc, ts, maxts)) ; + (* Bad PAIR argument *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_pair_argument" + ~title:"0 or 1 passed to PAIR" + ~description:"PAIR expects an argument of at least 2" + (obj1 (req "loc" Script.location_encoding)) + (function Pair_bad_argument loc -> Some loc | _ -> None) + (fun loc -> Pair_bad_argument loc) ; + (* Bad UNPAIR argument *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_unpair_argument" + ~title:"0 or 1 passed to UNPAIR" + ~description:"UNPAIR expects an argument of at least 2" + (obj1 (req "loc" Script.location_encoding)) + (function Unpair_bad_argument loc -> Some loc | _ -> None) + (fun loc -> Unpair_bad_argument loc) ; + (* Bad dup_n argument *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_dupn_argument" + ~title:"0 passed to DUP n" + ~description:"DUP expects an argument of at least 1 (passed 0)" + (obj1 (req "loc" Script.location_encoding)) + (function Dup_n_bad_argument loc -> Some loc | _ -> None) + (fun loc -> Dup_n_bad_argument loc) ; + (* Bad dup_n stack *) + register_error_kind + `Permanent + ~id:"michelson_v1.bad_dupn_stack" + ~title:"Stack too short when typing DUP n" + ~description:"Stack present when typing DUP n was too short" + (obj1 (req "loc" Script.location_encoding)) + (function Dup_n_bad_stack x -> Some x | _ -> None) + (fun x -> Dup_n_bad_stack x) ; + (* -- Toplevel errors ------------------- *) + (* Ill typed data *) + register_error_kind + `Permanent + ~id:"michelson_v1.ill_typed_data" + ~title:"Ill typed data" + ~description: + "The toplevel error thrown when trying to typecheck a data expression \ + against a given type (always followed by more precise errors)." + (obj3 + (opt "identifier" string) + (req "expected_type" Script.expr_encoding) + (req "ill_typed_expression" Script.expr_encoding)) + (function + | Ill_typed_data (name, expr, ty) -> Some (name, ty, expr) | _ -> None) + (fun (name, ty, expr) -> Ill_typed_data (name, expr, ty)) ; + (* Ill formed type *) + register_error_kind + `Permanent + ~id:"michelson_v1.ill_formed_type" + ~title:"Ill formed type" + ~description: + "The toplevel error thrown when trying to parse a type expression \ + (always followed by more precise errors)." + (obj3 + (opt "identifier" string) + (req "ill_formed_expression" Script.expr_encoding) + (req "location" Script.location_encoding)) + (function + | Ill_formed_type (name, expr, loc) -> Some (name, expr, loc) | _ -> None) + (fun (name, expr, loc) -> Ill_formed_type (name, expr, loc)) ; + (* Ill typed contract *) + register_error_kind + `Permanent + ~id:"michelson_v1.ill_typed_contract" + ~title:"Ill typed contract" + ~description: + "The toplevel error thrown when trying to typecheck a contract code \ + against given input, output and storage types (always followed by more \ + precise errors)." + (obj2 + (req "ill_typed_code" Script.expr_encoding) + (req "type_map" type_map_enc)) + (function + | Ill_typed_contract (expr, type_map) -> + Some (expr, type_map) + | _ -> + None) + (fun (expr, type_map) -> Ill_typed_contract (expr, type_map)) ; + (* Cannot serialize error *) + register_error_kind + `Temporary + ~id:"michelson_v1.cannot_serialize_error" + ~title:"Not enough gas to serialize error" + ~description:"The error was too big to be serialized with the provided gas" + Data_encoding.empty + (function Cannot_serialize_error -> Some () | _ -> None) + (fun () -> Cannot_serialize_error) ; + (* Deprecated instruction *) + register_error_kind + `Permanent + ~id:"michelson_v1.deprecated_instruction" + ~title:"Script is using a deprecated instruction" + ~description: + "A deprecated instruction usage is disallowed in newly created contracts" + (obj1 (req "prim" prim_encoding)) + (function Deprecated_instruction prim -> Some prim | _ -> None) + (fun prim -> Deprecated_instruction prim) ; + (* Typechecking stack overflow *) + register_error_kind + `Temporary + ~id:"michelson_v1.typechecking_too_many_recursive_calls" + ~title:"Too many recursive calls during typechecking" + ~description:"Too many recursive calls were needed for typechecking" + Data_encoding.empty + (function Typechecking_too_many_recursive_calls -> Some () | _ -> None) + (fun () -> Typechecking_too_many_recursive_calls) ; + (* Unparsing stack overflow *) + register_error_kind + `Temporary + ~id:"michelson_v1.unparsing_stack_overflow" + ~title:"Too many recursive calls during unparsing" + ~description:"Too many recursive calls were needed for unparsing" + Data_encoding.empty + (function Unparsing_too_many_recursive_calls -> Some () | _ -> None) + (fun () -> Unparsing_too_many_recursive_calls) ; + (* Unexpected forged value *) + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_forged_value" + ~title:"Unexpected forged value" + ~description: + "A forged value was encountered but disallowed for that position." + (obj1 (req "location" Script.location_encoding)) + (function Unexpected_forged_value loc -> Some loc | _ -> None) + (fun loc -> Unexpected_forged_value loc) ; + (* Unexpected ticket *) + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_ticket" + ~title:"Ticket in unauthorized position (type error)" + ~description:"A ticket type has been found" + (obj1 (req "loc" location_encoding)) + (function Unexpected_ticket loc -> Some loc | _ -> None) + (fun loc -> Unexpected_ticket loc) ; + (* Attempt to duplicate a non-dupable type *) + register_error_kind + `Permanent + ~id:"michelson_v1.non_dupable_type" + ~title:"Non-dupable type duplication attempt" + ~description:"DUP was used on a non-dupable type (e.g. tickets)." + (obj2 (req "loc" location_encoding) (req "type" Script.expr_encoding)) + (function Non_dupable_type (loc, ty) -> Some (loc, ty) | _ -> None) + (fun (loc, ty) -> Non_dupable_type (loc, ty)) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_timestamp_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/script_timestamp_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..c8474e2e1d3ea7ed395c45c4a5ca9e53d708ba2e --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_timestamp_repr.ml @@ -0,0 +1,57 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t = Z.t + +let compare = Z.compare + +let of_int64 = Z.of_int64 + +let of_string x = + match Time_repr.of_notation x with + | None -> ( + try Some (Z.of_string x) with _ -> None ) + | Some time -> + Some (of_int64 (Time_repr.to_seconds time)) + +let to_notation x = + try + let notation = Time_repr.to_notation (Time.of_seconds (Z.to_int64 x)) in + if String.equal notation "out_of_range" then None else Some notation + with _ -> None + +let to_num_str = Z.to_string + +let to_string x = match to_notation x with None -> to_num_str x | Some s -> s + +let diff x y = Script_int_repr.of_zint @@ Z.sub x y + +let sub_delta t delta = Z.sub t (Script_int_repr.to_zint delta) + +let add_delta t delta = Z.add t (Script_int_repr.to_zint delta) + +let to_zint x = x + +let of_zint x = x diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_timestamp_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/script_timestamp_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..7f2b156d2fabd4057844835c31e2c45ba5f6fc09 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_timestamp_repr.mli @@ -0,0 +1,53 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Script_int_repr + +type t + +val of_int64 : int64 -> t + +val compare : t -> t -> int + +(* Convert a timestamp to a notation if possible *) +val to_notation : t -> string option + +(* Convert a timestamp to a string representation of the seconds *) +val to_num_str : t -> string + +(* Convert to a notation if possible, or num if not *) +val to_string : t -> string + +val of_string : string -> t option + +val diff : t -> t -> z num + +val add_delta : t -> z num -> t + +val sub_delta : t -> z num -> t + +val to_zint : t -> Z.t + +val of_zint : Z.t -> t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/script_typed_ir.ml b/src/proto_008_PtEdo2Zk/lib_protocol/script_typed_ir.ml new file mode 100644 index 0000000000000000000000000000000000000000..cb1019c9588f7c185a37b785379d41d4ac91a5e2 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/script_typed_ir.ml @@ -0,0 +1,552 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script_int + +(* ---- Auxiliary types -----------------------------------------------------*) + +type var_annot = Var_annot of string + +type type_annot = Type_annot of string + +type field_annot = Field_annot of string + +type address = Contract.t * string + +type ('a, 'b) pair = 'a * 'b + +type ('a, 'b) union = L of 'a | R of 'b + +type never = | + +type _ comparable_ty = + | Unit_key : type_annot option -> unit comparable_ty + | Never_key : type_annot option -> never comparable_ty + | Int_key : type_annot option -> z num comparable_ty + | Nat_key : type_annot option -> n num comparable_ty + | Signature_key : type_annot option -> signature comparable_ty + | String_key : type_annot option -> string comparable_ty + | Bytes_key : type_annot option -> Bytes.t comparable_ty + | Mutez_key : type_annot option -> Tez.t comparable_ty + | Bool_key : type_annot option -> bool comparable_ty + | Key_hash_key : type_annot option -> public_key_hash comparable_ty + | Key_key : type_annot option -> public_key comparable_ty + | Timestamp_key : type_annot option -> Script_timestamp.t comparable_ty + | Chain_id_key : type_annot option -> Chain_id.t comparable_ty + | Address_key : type_annot option -> address comparable_ty + | Pair_key : + ('a comparable_ty * field_annot option) + * ('b comparable_ty * field_annot option) + * type_annot option + -> ('a, 'b) pair comparable_ty + | Union_key : + ('a comparable_ty * field_annot option) + * ('b comparable_ty * field_annot option) + * type_annot option + -> ('a, 'b) union comparable_ty + | Option_key : + 'v comparable_ty * type_annot option + -> 'v option comparable_ty + +module type Boxed_set = sig + type elt + + val elt_ty : elt comparable_ty + + module OPS : S.SET with type elt = elt + + val boxed : OPS.t + + val size : int +end + +type 'elt set = (module Boxed_set with type elt = 'elt) + +module type Boxed_map = sig + type key + + type value + + val key_ty : key comparable_ty + + module OPS : S.MAP with type key = key + + val boxed : value OPS.t * int +end + +type ('key, 'value) map = + (module Boxed_map with type key = 'key and type value = 'value) + +type operation = packed_internal_operation * Lazy_storage.diffs option + +type 'a ticket = {ticketer : address; contents : 'a; amount : n num} + +type ('arg, 'storage) script = { + code : (('arg, 'storage) pair, (operation boxed_list, 'storage) pair) lambda; + arg_type : 'arg ty; + storage : 'storage; + storage_type : 'storage ty; + root_name : field_annot option; +} + +and end_of_stack = unit + +and ('arg, 'ret) lambda = + | Lam : + ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.node + -> ('arg, 'ret) lambda + +and 'arg typed_contract = 'arg ty * address + +and 'ty ty = + | Unit_t : type_annot option -> unit ty + | Int_t : type_annot option -> z num ty + | Nat_t : type_annot option -> n num ty + | Signature_t : type_annot option -> signature ty + | String_t : type_annot option -> string ty + | Bytes_t : type_annot option -> bytes ty + | Mutez_t : type_annot option -> Tez.t ty + | Key_hash_t : type_annot option -> public_key_hash ty + | Key_t : type_annot option -> public_key ty + | Timestamp_t : type_annot option -> Script_timestamp.t ty + | Address_t : type_annot option -> address ty + | Bool_t : type_annot option -> bool ty + | Pair_t : + ('a ty * field_annot option * var_annot option) + * ('b ty * field_annot option * var_annot option) + * type_annot option + -> ('a, 'b) pair ty + | Union_t : + ('a ty * field_annot option) + * ('b ty * field_annot option) + * type_annot option + -> ('a, 'b) union ty + | Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty + | Option_t : 'v ty * type_annot option -> 'v option ty + | List_t : 'v ty * type_annot option -> 'v boxed_list ty + | Set_t : 'v comparable_ty * type_annot option -> 'v set ty + | Map_t : 'k comparable_ty * 'v ty * type_annot option -> ('k, 'v) map ty + | Big_map_t : + 'k comparable_ty * 'v ty * type_annot option + -> ('k, 'v) big_map ty + | Contract_t : 'arg ty * type_annot option -> 'arg typed_contract ty + | Sapling_transaction_t : + Sapling.Memo_size.t * type_annot option + -> Sapling.transaction ty + | Sapling_state_t : + Sapling.Memo_size.t * type_annot option + -> Sapling.state ty + | Operation_t : type_annot option -> operation ty + | Chain_id_t : type_annot option -> Chain_id.t ty + | Never_t : type_annot option -> never ty + | Bls12_381_g1_t : type_annot option -> Bls12_381.G1.t ty + | Bls12_381_g2_t : type_annot option -> Bls12_381.G2.t ty + | Bls12_381_fr_t : type_annot option -> Bls12_381.Fr.t ty + | Ticket_t : 'a comparable_ty * type_annot option -> 'a ticket ty + +and 'ty stack_ty = + | Item_t : + 'ty ty * 'rest stack_ty * var_annot option + -> ('ty * 'rest) stack_ty + | Empty_t : end_of_stack stack_ty + +and ('key, 'value) big_map = { + id : Big_map.Id.t option; + diff : ('key, 'value option) map; + key_type : 'key comparable_ty; + value_type : 'value ty; +} + +and 'elt boxed_list = {elements : 'elt list; length : int} + +(* ---- Instructions --------------------------------------------------------*) + +(* The low-level, typed instructions, as a GADT whose parameters + encode the typing rules. + + The left parameter is the typed shape of the stack before the + instruction, the right one the shape after. Any program whose + construction is accepted by OCaml's type-checker is guaranteed to + be type-safe. Overloadings of the concrete syntax are already + resolved in this representation, either by using different + constructors or type witness parameters. + + When adding a new instruction, please check whether it is duplicating a data + (rule of thumb: the type variable appears twice in the after stack, beware + it might be hidden in a witness). + If it is, please protect it with [check_dupable_ty]. +*) +and ('bef, 'aft) instr = + (* stack ops *) + | Drop : (_ * 'rest, 'rest) instr + | Dup : ('top * 'rest, 'top * ('top * 'rest)) instr + | Swap : ('tip * ('top * 'rest), 'top * ('tip * 'rest)) instr + | Const : 'ty -> ('rest, 'ty * 'rest) instr + (* pairs *) + | Cons_pair : ('car * ('cdr * 'rest), ('car, 'cdr) pair * 'rest) instr + | Car : (('car, _) pair * 'rest, 'car * 'rest) instr + | Cdr : ((_, 'cdr) pair * 'rest, 'cdr * 'rest) instr + | Unpair : (('car, 'cdr) pair * 'rest, 'car * ('cdr * 'rest)) instr + (* options *) + | Cons_some : ('v * 'rest, 'v option * 'rest) instr + | Cons_none : 'a ty -> ('rest, 'a option * 'rest) instr + | If_none : + ('bef, 'aft) descr * ('a * 'bef, 'aft) descr + -> ('a option * 'bef, 'aft) instr + (* unions *) + | Cons_left : ('l * 'rest, ('l, 'r) union * 'rest) instr + | Cons_right : ('r * 'rest, ('l, 'r) union * 'rest) instr + | If_left : + ('l * 'bef, 'aft) descr * ('r * 'bef, 'aft) descr + -> (('l, 'r) union * 'bef, 'aft) instr + (* lists *) + | Cons_list : ('a * ('a boxed_list * 'rest), 'a boxed_list * 'rest) instr + | Nil : ('rest, 'a boxed_list * 'rest) instr + | If_cons : + ('a * ('a boxed_list * 'bef), 'aft) descr * ('bef, 'aft) descr + -> ('a boxed_list * 'bef, 'aft) instr + | List_map : + ('a * 'rest, 'b * 'rest) descr + -> ('a boxed_list * 'rest, 'b boxed_list * 'rest) instr + | List_iter : + ('a * 'rest, 'rest) descr + -> ('a boxed_list * 'rest, 'rest) instr + | List_size : ('a boxed_list * 'rest, n num * 'rest) instr + (* sets *) + | Empty_set : 'a comparable_ty -> ('rest, 'a set * 'rest) instr + | Set_iter : ('a * 'rest, 'rest) descr -> ('a set * 'rest, 'rest) instr + | Set_mem : ('elt * ('elt set * 'rest), bool * 'rest) instr + | Set_update : ('elt * (bool * ('elt set * 'rest)), 'elt set * 'rest) instr + | Set_size : ('a set * 'rest, n num * 'rest) instr + (* maps *) + | Empty_map : 'a comparable_ty * 'v ty -> ('rest, ('a, 'v) map * 'rest) instr + | Map_map : + (('a * 'v) * 'rest, 'r * 'rest) descr + -> (('a, 'v) map * 'rest, ('a, 'r) map * 'rest) instr + | Map_iter : + (('a * 'v) * 'rest, 'rest) descr + -> (('a, 'v) map * 'rest, 'rest) instr + | Map_mem : ('a * (('a, 'v) map * 'rest), bool * 'rest) instr + | Map_get : ('a * (('a, 'v) map * 'rest), 'v option * 'rest) instr + | Map_update + : ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr + | Map_get_and_update + : ( 'a * ('v option * (('a, 'v) map * 'rest)), + 'v option * (('a, 'v) map * 'rest) ) + instr + | Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr + (* big maps *) + | Empty_big_map : + 'a comparable_ty * 'v ty + -> ('rest, ('a, 'v) big_map * 'rest) instr + | Big_map_mem : ('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr + | Big_map_get : ('a * (('a, 'v) big_map * 'rest), 'v option * 'rest) instr + | Big_map_update + : ( 'key * ('value option * (('key, 'value) big_map * 'rest)), + ('key, 'value) big_map * 'rest ) + instr + | Big_map_get_and_update + : ( 'a * ('v option * (('a, 'v) big_map * 'rest)), + 'v option * (('a, 'v) big_map * 'rest) ) + instr + (* string operations *) + | Concat_string : (string boxed_list * 'rest, string * 'rest) instr + | Concat_string_pair : (string * (string * 'rest), string * 'rest) instr + | Slice_string + : (n num * (n num * (string * 'rest)), string option * 'rest) instr + | String_size : (string * 'rest, n num * 'rest) instr + (* bytes operations *) + | Concat_bytes : (bytes boxed_list * 'rest, bytes * 'rest) instr + | Concat_bytes_pair : (bytes * (bytes * 'rest), bytes * 'rest) instr + | Slice_bytes + : (n num * (n num * (bytes * 'rest)), bytes option * 'rest) instr + | Bytes_size : (bytes * 'rest, n num * 'rest) instr + (* timestamp operations *) + | Add_seconds_to_timestamp + : ( z num * (Script_timestamp.t * 'rest), + Script_timestamp.t * 'rest ) + instr + | Add_timestamp_to_seconds + : ( Script_timestamp.t * (z num * 'rest), + Script_timestamp.t * 'rest ) + instr + | Sub_timestamp_seconds + : ( Script_timestamp.t * (z num * 'rest), + Script_timestamp.t * 'rest ) + instr + | Diff_timestamps + : ( Script_timestamp.t * (Script_timestamp.t * 'rest), + z num * 'rest ) + instr + (* tez operations *) + | Add_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr + | Sub_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr + | Mul_teznat : (Tez.t * (n num * 'rest), Tez.t * 'rest) instr + | Mul_nattez : (n num * (Tez.t * 'rest), Tez.t * 'rest) instr + | Ediv_teznat + : (Tez.t * (n num * 'rest), (Tez.t, Tez.t) pair option * 'rest) instr + | Ediv_tez + : (Tez.t * (Tez.t * 'rest), (n num, Tez.t) pair option * 'rest) instr + (* boolean operations *) + | Or : (bool * (bool * 'rest), bool * 'rest) instr + | And : (bool * (bool * 'rest), bool * 'rest) instr + | Xor : (bool * (bool * 'rest), bool * 'rest) instr + | Not : (bool * 'rest, bool * 'rest) instr + (* integer operations *) + | Is_nat : (z num * 'rest, n num option * 'rest) instr + | Neg_nat : (n num * 'rest, z num * 'rest) instr + | Neg_int : (z num * 'rest, z num * 'rest) instr + | Abs_int : (z num * 'rest, n num * 'rest) instr + | Int_nat : (n num * 'rest, z num * 'rest) instr + | Add_intint : (z num * (z num * 'rest), z num * 'rest) instr + | Add_intnat : (z num * (n num * 'rest), z num * 'rest) instr + | Add_natint : (n num * (z num * 'rest), z num * 'rest) instr + | Add_natnat : (n num * (n num * 'rest), n num * 'rest) instr + | Sub_int : ('s num * ('t num * 'rest), z num * 'rest) instr + | Mul_intint : (z num * (z num * 'rest), z num * 'rest) instr + | Mul_intnat : (z num * (n num * 'rest), z num * 'rest) instr + | Mul_natint : (n num * (z num * 'rest), z num * 'rest) instr + | Mul_natnat : (n num * (n num * 'rest), n num * 'rest) instr + | Ediv_intint + : (z num * (z num * 'rest), (z num, n num) pair option * 'rest) instr + | Ediv_intnat + : (z num * (n num * 'rest), (z num, n num) pair option * 'rest) instr + | Ediv_natint + : (n num * (z num * 'rest), (z num, n num) pair option * 'rest) instr + | Ediv_natnat + : (n num * (n num * 'rest), (n num, n num) pair option * 'rest) instr + | Lsl_nat : (n num * (n num * 'rest), n num * 'rest) instr + | Lsr_nat : (n num * (n num * 'rest), n num * 'rest) instr + | Or_nat : (n num * (n num * 'rest), n num * 'rest) instr + | And_nat : (n num * (n num * 'rest), n num * 'rest) instr + | And_int_nat : (z num * (n num * 'rest), n num * 'rest) instr + | Xor_nat : (n num * (n num * 'rest), n num * 'rest) instr + | Not_nat : (n num * 'rest, z num * 'rest) instr + | Not_int : (z num * 'rest, z num * 'rest) instr + (* control *) + | Seq : ('bef, 'trans) descr * ('trans, 'aft) descr -> ('bef, 'aft) instr + | If : ('bef, 'aft) descr * ('bef, 'aft) descr -> (bool * 'bef, 'aft) instr + | Loop : ('rest, bool * 'rest) descr -> (bool * 'rest, 'rest) instr + | Loop_left : + ('a * 'rest, ('a, 'b) union * 'rest) descr + -> (('a, 'b) union * 'rest, 'b * 'rest) instr + | Dip : ('bef, 'aft) descr -> ('top * 'bef, 'top * 'aft) instr + | Exec : ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr + | Apply : + 'arg ty + -> ( 'arg * (('arg * 'remaining, 'ret) lambda * 'rest), + ('remaining, 'ret) lambda * 'rest ) + instr + | Lambda : ('arg, 'ret) lambda -> ('rest, ('arg, 'ret) lambda * 'rest) instr + | Failwith : 'a ty -> ('a * 'rest, 'aft) instr + | Nop : ('rest, 'rest) instr + (* comparison *) + | Compare : 'a comparable_ty -> ('a * ('a * 'rest), z num * 'rest) instr + (* comparators *) + | Eq : (z num * 'rest, bool * 'rest) instr + | Neq : (z num * 'rest, bool * 'rest) instr + | Lt : (z num * 'rest, bool * 'rest) instr + | Gt : (z num * 'rest, bool * 'rest) instr + | Le : (z num * 'rest, bool * 'rest) instr + | Ge : (z num * 'rest, bool * 'rest) instr + (* protocol *) + | Address : (_ typed_contract * 'rest, address * 'rest) instr + | Contract : + 'p ty * string + -> (address * 'rest, 'p typed_contract option * 'rest) instr + | Transfer_tokens + : ( 'arg * (Tez.t * ('arg typed_contract * 'rest)), + operation * 'rest ) + instr + | Implicit_account + : (public_key_hash * 'rest, unit typed_contract * 'rest) instr + | Create_contract : + 'g ty + * 'p ty + * ('p * 'g, operation boxed_list * 'g) lambda + * field_annot option + -> ( public_key_hash option * (Tez.t * ('g * 'rest)), + operation * (address * 'rest) ) + instr + | Set_delegate : (public_key_hash option * 'rest, operation * 'rest) instr + | Now : ('rest, Script_timestamp.t * 'rest) instr + | Balance : ('rest, Tez.t * 'rest) instr + | Level : ('rest, n num * 'rest) instr + | Check_signature + : (public_key * (signature * (bytes * 'rest)), bool * 'rest) instr + | Hash_key : (public_key * 'rest, public_key_hash * 'rest) instr + | Pack : 'a ty -> ('a * 'rest, bytes * 'rest) instr + | Unpack : 'a ty -> (bytes * 'rest, 'a option * 'rest) instr + | Blake2b : (bytes * 'rest, bytes * 'rest) instr + | Sha256 : (bytes * 'rest, bytes * 'rest) instr + | Sha512 : (bytes * 'rest, bytes * 'rest) instr + | Source : ('rest, address * 'rest) instr + | Sender : ('rest, address * 'rest) instr + | Self : 'p ty * string -> ('rest, 'p typed_contract * 'rest) instr + | Self_address : ('rest, address * 'rest) instr + | Amount : ('rest, Tez.t * 'rest) instr + | Sapling_empty_state : { + memo_size : Sapling.Memo_size.t; + } + -> ('rest, Sapling.state * 'rest) instr + | Sapling_verify_update + : ( Sapling.transaction * (Sapling.state * 'rest), + (z num, Sapling.state) pair option * 'rest ) + instr + | Dig : + int * ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness + -> ('bef, 'x * 'aft) instr + | Dug : + int * ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness + -> ('x * 'bef, 'aft) instr + | Dipn : + int + * ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness + * ('fbef, 'faft) descr + -> ('bef, 'aft) instr + | Dropn : + int * ('rest, 'rest, 'bef, _) stack_prefix_preservation_witness + -> ('bef, 'rest) instr + | ChainId : ('rest, Chain_id.t * 'rest) instr + | Never : (never * 'rest, 'aft) instr + | Voting_power : (public_key_hash * 'rest, n num * 'rest) instr + | Total_voting_power : ('rest, n num * 'rest) instr + | Keccak : (bytes * 'rest, bytes * 'rest) instr + | Sha3 : (bytes * 'rest, bytes * 'rest) instr + | Add_bls12_381_g1 + : ( Bls12_381.G1.t * (Bls12_381.G1.t * 'rest), + Bls12_381.G1.t * 'rest ) + instr + | Add_bls12_381_g2 + : ( Bls12_381.G2.t * (Bls12_381.G2.t * 'rest), + Bls12_381.G2.t * 'rest ) + instr + | Add_bls12_381_fr + : ( Bls12_381.Fr.t * (Bls12_381.Fr.t * 'rest), + Bls12_381.Fr.t * 'rest ) + instr + | Mul_bls12_381_g1 + : ( Bls12_381.G1.t * (Bls12_381.Fr.t * 'rest), + Bls12_381.G1.t * 'rest ) + instr + | Mul_bls12_381_g2 + : ( Bls12_381.G2.t * (Bls12_381.Fr.t * 'rest), + Bls12_381.G2.t * 'rest ) + instr + | Mul_bls12_381_fr + : ( Bls12_381.Fr.t * (Bls12_381.Fr.t * 'rest), + Bls12_381.Fr.t * 'rest ) + instr + | Mul_bls12_381_z_fr + : (Bls12_381.Fr.t * (_ num * 'rest), Bls12_381.Fr.t * 'rest) instr + | Mul_bls12_381_fr_z + : (_ num * (Bls12_381.Fr.t * 'rest), Bls12_381.Fr.t * 'rest) instr + | Int_bls12_381_fr : (Bls12_381.Fr.t * 'rest, z num * 'rest) instr + | Neg_bls12_381_g1 : (Bls12_381.G1.t * 'rest, Bls12_381.G1.t * 'rest) instr + | Neg_bls12_381_g2 : (Bls12_381.G2.t * 'rest, Bls12_381.G2.t * 'rest) instr + | Neg_bls12_381_fr : (Bls12_381.Fr.t * 'rest, Bls12_381.Fr.t * 'rest) instr + | Pairing_check_bls12_381 + : ( (Bls12_381.G1.t, Bls12_381.G2.t) pair boxed_list * 'rest, + bool * 'rest ) + instr + | Comb : int * ('before, 'after) comb_gadt_witness -> ('before, 'after) instr + | Uncomb : + int * ('before, 'after) uncomb_gadt_witness + -> ('before, 'after) instr + | Comb_get : + int * ('before, 'after) comb_get_gadt_witness + -> ('before * 'rest, 'after * 'rest) instr + | Comb_set : + int * ('value, 'before, 'after) comb_set_gadt_witness + -> ('value * ('before * 'rest), 'after * 'rest) instr + | Dup_n : + int * ('before, 'after) dup_n_gadt_witness + -> ('before, 'after * 'before) instr + | Ticket : ('a * (n num * 'rest), 'a ticket * 'rest) instr + | Read_ticket + : ( 'a ticket * 'rest, + (address * ('a * n num)) * ('a ticket * 'rest) ) + instr + | Split_ticket + : ( 'a ticket * ((n num * n num) * 'rest), + ('a ticket * 'a ticket) option * 'rest ) + instr + | Join_tickets : + 'a comparable_ty + -> (('a ticket * 'a ticket) * 'rest, 'a ticket option * 'rest) instr + +and ('before, 'after) comb_gadt_witness = + | Comb_one : ('a * 'before, 'a * 'before) comb_gadt_witness + | Comb_succ : + ('before, 'b * 'after) comb_gadt_witness + -> ('a * 'before, ('a * 'b) * 'after) comb_gadt_witness + +and ('before, 'after) uncomb_gadt_witness = + | Uncomb_one : ('rest, 'rest) uncomb_gadt_witness + | Uncomb_succ : + ('b * 'before, 'after) uncomb_gadt_witness + -> (('a * 'b) * 'before, 'a * 'after) uncomb_gadt_witness + +and ('before, 'after) comb_get_gadt_witness = + | Comb_get_zero : ('b, 'b) comb_get_gadt_witness + | Comb_get_one : ('a * 'b, 'a) comb_get_gadt_witness + | Comb_get_plus_two : + ('before, 'after) comb_get_gadt_witness + -> ('a * 'before, 'after) comb_get_gadt_witness + +and ('value, 'before, 'after) comb_set_gadt_witness = + | Comb_set_zero : ('value, _, 'value) comb_set_gadt_witness + | Comb_set_one : ('value, 'hd * 'tl, 'value * 'tl) comb_set_gadt_witness + | Comb_set_plus_two : + ('value, 'before, 'after) comb_set_gadt_witness + -> ('value, 'a * 'before, 'a * 'after) comb_set_gadt_witness + +and ('before, 'after) dup_n_gadt_witness = + | Dup_n_zero : ('a * 'rest, 'a) dup_n_gadt_witness + | Dup_n_succ : + ('before, 'b) dup_n_gadt_witness + -> ('a * 'before, 'b) dup_n_gadt_witness + +(* Type witness for operations that work deep in the stack ignoring + (and preserving) a prefix. + + The two right parameters are the shape of the stack with the (same) + prefix before and after the transformation. The two left + parameters are the shape of the stack without the prefix before and + after. The inductive definition makes it so by construction. *) +and ('bef, 'aft, 'bef_suffix, 'aft_suffix) stack_prefix_preservation_witness = + | Prefix : + ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness + -> ('fbef, 'faft, 'x * 'bef, 'x * 'aft) stack_prefix_preservation_witness + | Rest : ('bef, 'aft, 'bef, 'aft) stack_prefix_preservation_witness + +and ('bef, 'aft) descr = { + loc : Script.location; + bef : 'bef stack_ty; + aft : 'aft stack_ty; + instr : ('bef, 'aft) instr; +} diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/seed_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/seed_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..591f7da797a9a07380cc201c8ad5420e250f1809 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/seed_repr.ml @@ -0,0 +1,134 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Tezos Protocol Implementation - Random number generation *) + +type seed = B of State_hash.t + +type t = T of State_hash.t + +type sequence = S of State_hash.t + +type nonce = bytes + +let nonce_encoding = Data_encoding.Fixed.bytes Constants_repr.nonce_length + +let initial_seed = "Laissez-faire les proprietaires." + +let zero_bytes = Bytes.make Nonce_hash.size '\000' + +let state_hash_encoding = + let open Data_encoding in + conv + State_hash.to_bytes + State_hash.of_bytes_exn + (Fixed.bytes Nonce_hash.size) + +let seed_encoding = + let open Data_encoding in + conv (fun (B b) -> b) (fun b -> B b) state_hash_encoding + +let empty = B (State_hash.hash_bytes [Bytes.of_string initial_seed]) + +let nonce (B state) nonce = + B (State_hash.hash_bytes [State_hash.to_bytes state; nonce]) + +let initialize_new (B state) append = + T (State_hash.hash_bytes (State_hash.to_bytes state :: zero_bytes :: append)) + +let xor_higher_bits i b = + let higher = TzEndian.get_int32 b 0 in + let r = Int32.logxor higher i in + let res = Bytes.copy b in + TzEndian.set_int32 res 0 r ; res + +let sequence (T state) n = + State_hash.to_bytes state |> xor_higher_bits n + |> fun b -> S (State_hash.hash_bytes [b]) + +let take (S state) = + let b = State_hash.to_bytes state in + let h = State_hash.hash_bytes [b] in + (State_hash.to_bytes h, S h) + +let take_int32 s bound = + if Compare.Int32.(bound <= 0l) then invalid_arg "Seed_repr.take_int32" + (* FIXME *) + else + let rec loop s = + let (bytes, s) = take s in + let r = Int32.abs (TzEndian.get_int32 bytes 0) in + let drop_if_over = + Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) + in + if Compare.Int32.(r >= drop_if_over) then loop s + else + let v = Int32.rem r bound in + (v, s) + in + loop s + +type error += Unexpected_nonce_length (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"unexpected_nonce_length" + ~title:"Unexpected nonce length" + ~description:"Nonce length is incorrect." + ~pp:(fun ppf () -> + Format.fprintf + ppf + "Nonce length is not %i bytes long as it should." + Constants_repr.nonce_length) + Data_encoding.empty + (function Unexpected_nonce_length -> Some () | _ -> None) + (fun () -> Unexpected_nonce_length) + +let make_nonce nonce = + if Compare.Int.(Bytes.length nonce <> Constants_repr.nonce_length) then + error Unexpected_nonce_length + else ok nonce + +let hash nonce = Nonce_hash.hash_bytes [nonce] + +let check_hash nonce hash = + Compare.Int.(Bytes.length nonce = Constants_repr.nonce_length) + && Nonce_hash.equal (Nonce_hash.hash_bytes [nonce]) hash + +let nonce_hash_key_part = Nonce_hash.to_path + +let initial_nonce_0 = zero_bytes + +let initial_nonce_hash_0 = hash initial_nonce_0 + +let deterministic_seed seed = nonce seed zero_bytes + +let initial_seeds n = + let rec loop acc elt i = + if Compare.Int.(i = 1) then List.rev (elt :: acc) + else loop (elt :: acc) (deterministic_seed elt) (i - 1) + in + loop [] (B (State_hash.hash_bytes [])) n diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/seed_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/seed_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..a067ac9d2952b9a351f26319d436ec733b2fa110 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/seed_repr.mli @@ -0,0 +1,100 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos Protocol Implementation - Random number generation + + This is not expected to be a good cryptographic random number + generator. In particular this is supposed to be used in situations + where the seed is a globally known information. + + The only expected property is: It should be difficult to find a + seed such that the generated sequence is a given one. *) + +(** {2 Random Generation} *) + +(** The state of the random number generator *) +type t + +(** A random seed, to derive random sequences from *) +type seed + +(** A random sequence, to derive random values from *) +type sequence + +(** [initialize_new state ident] returns a new generator *) +val initialize_new : seed -> bytes list -> t + +(** [sequence state n] prepares the n-th sequence of a state *) +val sequence : t -> int32 -> sequence + +(** Generates the next random value in the sequence *) +val take : sequence -> bytes * sequence + +(** Generates the next random value as a bounded [int32] *) +val take_int32 : sequence -> int32 -> int32 * sequence + +(** {2 Predefined seeds} *) + +val empty : seed + +(** Returns a new seed by hashing the one passed with a constant. *) +val deterministic_seed : seed -> seed + +(** [initial_seeds n] generates the first [n] seeds for which there are no nonces. + The first seed is a constant value. The kth seed is the hash of seed (k-1) + concatenated with a constant. *) +val initial_seeds : int -> seed list + +(** {2 Entropy} *) + +(** A nonce for adding entropy to the generator *) +type nonce + +(** Add entropy to the seed generator *) +val nonce : seed -> nonce -> seed + +(** Use a byte sequence as a nonce *) +val make_nonce : bytes -> nonce tzresult + +(** Compute the has of a nonce *) +val hash : nonce -> Nonce_hash.t + +(** [check_hash nonce hash] is true if the nonce correspond to the hash *) +val check_hash : nonce -> Nonce_hash.t -> bool + +(** For using nonce hashes as keys in the hierarchical database *) +val nonce_hash_key_part : Nonce_hash.t -> string list -> string list + +(** {2 Predefined nonce} *) + +val initial_nonce_0 : nonce + +val initial_nonce_hash_0 : Nonce_hash.t + +(** {2 Serializers} *) + +val nonce_encoding : nonce Data_encoding.t + +val seed_encoding : seed Data_encoding.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/seed_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/seed_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..17063519a235e36c1cb878305c9a6c1e3a361482 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/seed_storage.ml @@ -0,0 +1,146 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Misc + +type error += + | Unknown of { + oldest : Cycle_repr.t; + cycle : Cycle_repr.t; + latest : Cycle_repr.t; + } + +(* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"seed.unknown_seed" + ~title:"Unknown seed" + ~description:"The requested seed is not available" + ~pp:(fun ppf (oldest, cycle, latest) -> + if Cycle_repr.(cycle < oldest) then + Format.fprintf + ppf + "The seed for cycle %a has been cleared from the context (oldest \ + known seed is for cycle %a)" + Cycle_repr.pp + cycle + Cycle_repr.pp + oldest + else + Format.fprintf + ppf + "The seed for cycle %a has not been computed yet (latest known \ + seed is for cycle %a)" + Cycle_repr.pp + cycle + Cycle_repr.pp + latest) + Data_encoding.( + obj3 + (req "oldest" Cycle_repr.encoding) + (req "requested" Cycle_repr.encoding) + (req "latest" Cycle_repr.encoding)) + (function + | Unknown {oldest; cycle; latest} -> + Some (oldest, cycle, latest) + | _ -> + None) + (fun (oldest, cycle, latest) -> Unknown {oldest; cycle; latest}) + +let compute_for_cycle c ~revealed cycle = + match Cycle_repr.pred cycle with + | None -> + assert false (* should not happen *) + | Some previous_cycle -> + let levels = Level_storage.levels_with_commitments_in_cycle c revealed in + let combine (c, random_seed, unrevealed) level = + Storage.Seed.Nonce.get c level + >>=? function + | Revealed nonce -> + Storage.Seed.Nonce.delete c level + >|=? fun c -> (c, Seed_repr.nonce random_seed nonce, unrevealed) + | Unrevealed u -> + Storage.Seed.Nonce.delete c level + >|=? fun c -> (c, random_seed, u :: unrevealed) + in + Storage.Seed.For_cycle.get c previous_cycle + >>=? fun prev_seed -> + let seed = Seed_repr.deterministic_seed prev_seed in + fold_left_s combine (c, seed, []) levels + >>=? fun (c, seed, unrevealed) -> + Storage.Seed.For_cycle.init c cycle seed >|=? fun c -> (c, unrevealed) + +let for_cycle ctxt cycle = + let preserved = Constants_storage.preserved_cycles ctxt in + let current_level = Level_storage.current ctxt in + let current_cycle = current_level.cycle in + let latest = + if Cycle_repr.(current_cycle = root) then + Cycle_repr.add current_cycle (preserved + 1) + else Cycle_repr.add current_cycle preserved + in + let oldest = + match Cycle_repr.sub current_cycle preserved with + | None -> + Cycle_repr.root + | Some oldest -> + oldest + in + error_unless + Cycle_repr.(oldest <= cycle && cycle <= latest) + (Unknown {oldest; cycle; latest}) + >>?= fun () -> Storage.Seed.For_cycle.get ctxt cycle + +let clear_cycle c cycle = Storage.Seed.For_cycle.delete c cycle + +let init ctxt = + let preserved = Constants_storage.preserved_cycles ctxt in + List.fold_left2 + (fun ctxt c seed -> + ctxt + >>=? fun ctxt -> + let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in + Storage.Seed.For_cycle.init ctxt cycle seed) + (return ctxt) + (0 --> (preserved + 1)) + (Seed_repr.initial_seeds (preserved + 2)) + +let cycle_end ctxt last_cycle = + let preserved = Constants_storage.preserved_cycles ctxt in + ( match Cycle_repr.sub last_cycle preserved with + | None -> + return ctxt + | Some cleared_cycle -> + clear_cycle ctxt cleared_cycle ) + >>=? fun ctxt -> + match Cycle_repr.pred last_cycle with + | None -> + return (ctxt, []) + | Some revealed -> + (* cycle with revelations *) + let inited_seed_cycle = Cycle_repr.add last_cycle (preserved + 1) in + compute_for_cycle ctxt ~revealed inited_seed_cycle diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/seed_storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/seed_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..37e87efed99be2323d767f15a3dda6f117baff00 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/seed_storage.mli @@ -0,0 +1,47 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += + | Unknown of { + oldest : Cycle_repr.t; + cycle : Cycle_repr.t; + latest : Cycle_repr.t; + } + +(* `Permanent *) + +(** Generates the first [preserved_cycles+2] seeds for which + there are no nonces. *) +val init : Raw_context.t -> Raw_context.t tzresult Lwt.t + +val for_cycle : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t + +(** If it is the end of the cycle, computes and stores the seed of cycle at + distance [preserved_cycle+2] in the future using the seed of the previous + cycle and the revelations of the current one. *) +val cycle_end : + Raw_context.t -> + Cycle_repr.t -> + (Raw_context.t * Nonce_storage.unrevealed list) tzresult Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/services_registration.ml b/src/proto_008_PtEdo2Zk/lib_protocol/services_registration.ml new file mode 100644 index 0000000000000000000000000000000000000000..50673b7121c435381a5a3a1018c459678e0153c9 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/services_registration.ml @@ -0,0 +1,93 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +type rpc_context = { + block_hash : Block_hash.t; + block_header : Block_header.shell_header; + context : Alpha_context.t; +} + +let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) = + let level = block_header.level in + let timestamp = block_header.timestamp in + let fitness = block_header.fitness in + Alpha_context.prepare + ~level + ~predecessor_timestamp:timestamp + ~timestamp + ~fitness + context + >|=? fun context -> {block_hash; block_header; context} + +let rpc_services = + ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t) + +let register0_fullctxt s f = + rpc_services := + RPC_directory.register !rpc_services s (fun ctxt q i -> + rpc_init ctxt >>=? fun ctxt -> f ctxt q i) + +let opt_register0_fullctxt s f = + rpc_services := + RPC_directory.opt_register !rpc_services s (fun ctxt q i -> + rpc_init ctxt >>=? fun ctxt -> f ctxt q i) + +let register0 s f = register0_fullctxt s (fun {context; _} -> f context) + +let register0_noctxt s f = + rpc_services := RPC_directory.register !rpc_services s (fun _ q i -> f q i) + +let register1_fullctxt s f = + rpc_services := + RPC_directory.register !rpc_services s (fun (ctxt, arg) q i -> + rpc_init ctxt >>=? fun ctxt -> f ctxt arg q i) + +let register1 s f = register1_fullctxt s (fun {context; _} x -> f context x) + +let register1_noctxt s f = + rpc_services := + RPC_directory.register !rpc_services s (fun (_, arg) q i -> f arg q i) + +let register2_fullctxt s f = + rpc_services := + RPC_directory.register !rpc_services s (fun ((ctxt, arg1), arg2) q i -> + rpc_init ctxt >>=? fun ctxt -> f ctxt arg1 arg2 q i) + +let register2 s f = + register2_fullctxt s (fun {context; _} a1 a2 q i -> f context a1 a2 q i) + +let get_rpc_services () = + let p = + RPC_directory.map + (fun c -> + rpc_init c >|= function Error _ -> assert false | Ok c -> c.context) + (Storage_description.build_directory Alpha_context.description) + in + RPC_directory.register_dynamic_directory + !rpc_services + RPC_path.(open_root / "context" / "raw" / "json") + (fun _ -> Lwt.return p) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/state_hash.ml b/src/proto_008_PtEdo2Zk/lib_protocol/state_hash.ml new file mode 100644 index 0000000000000000000000000000000000000000..f72c0d5c5637638e07207fe0942099c636e29baa --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/state_hash.ml @@ -0,0 +1,40 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let random_state_hash = "\076\064\204" (* rng(53): never used... *) + +include Blake2B.Make + (Base58) + (struct + let name = "random" + + let title = "A random generation state" + + let b58check_prefix = random_state_hash + + let size = None + end) + +let () = Base58.check_encoded_prefix b58check_encoding "rng" 53 diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..ce93ff5652204570555b3a3fb68b0f3da2f6325a --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/storage.ml @@ -0,0 +1,1229 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Storage_functors + +module UInt16 = struct + type t = int + + let encoding = Data_encoding.uint16 +end + +module Int32 = struct + include Int32 + + let encoding = Data_encoding.int32 +end + +module Int64 = struct + include Int64 + + let encoding = Data_encoding.int64 +end + +module Z = struct + type t = Z.t + + let encoding = Data_encoding.z +end + +module Int31_index : INDEX with type t = int = struct + type t = int + + let path_length = 1 + + let to_path c l = string_of_int c :: l + + let of_path = function + | [] | _ :: _ :: _ -> + None + | [c] -> + int_of_string_opt c + + type 'a ipath = 'a * t + + let args = + Storage_description.One + { + rpc_arg = RPC_arg.int; + encoding = Data_encoding.int31; + compare = Compare.Int.compare; + } +end + +module Make_index (H : Storage_description.INDEX) : + INDEX with type t = H.t and type 'a ipath = 'a * H.t = struct + include H + + type 'a ipath = 'a * t + + let args = Storage_description.One {rpc_arg; encoding; compare} +end + +module Block_priority = + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["block_priority"] + end) + (UInt16) + +(** Contracts handling *) + +module Contract = struct + module Raw_context = + Make_subcontext (Registered) (Raw_context) + (struct + let name = ["contracts"] + end) + + module Global_counter = + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["global_counter"] + end) + (Z) + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["index"] + end)) + (Make_index (Contract_repr.Index)) + + let fold = Indexed_context.fold_keys + + let list = Indexed_context.keys + + module Balance = + Indexed_context.Make_map + (struct + let name = ["balance"] + end) + (Tez_repr) + + module Frozen_balance_index = + Make_indexed_subcontext + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["frozen_balance"] + end)) + (Make_index (Cycle_repr.Index)) + + module Frozen_deposits = + Frozen_balance_index.Make_map + (struct + let name = ["deposits"] + end) + (Tez_repr) + + module Frozen_fees = + Frozen_balance_index.Make_map + (struct + let name = ["fees"] + end) + (Tez_repr) + + module Frozen_rewards = + Frozen_balance_index.Make_map + (struct + let name = ["rewards"] + end) + (Tez_repr) + + module Manager = + Indexed_context.Make_map + (struct + let name = ["manager"] + end) + (Manager_repr) + + module Delegate = + Indexed_context.Make_map + (struct + let name = ["delegate"] + end) + (Signature.Public_key_hash) + + module Inactive_delegate = + Indexed_context.Make_set + (Registered) + (struct + let name = ["inactive_delegate"] + end) + + module Delegate_desactivation = + Indexed_context.Make_map + (struct + let name = ["delegate_desactivation"] + end) + (Cycle_repr) + + module Delegated = + Make_data_set_storage + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["delegated"] + end)) + (Make_index (Contract_repr.Index)) + + module Counter = + Indexed_context.Make_map + (struct + let name = ["counter"] + end) + (Z) + + (* Consume gas for serialization and deserialization of expr in this + module *) + module Make_carbonated_map_expr (N : Storage_sigs.NAME) : + Storage_sigs.Non_iterable_indexed_carbonated_data_storage + with type key = Contract_repr.t + and type value = Script_repr.lazy_expr + and type t := Raw_context.t = struct + module I = + Indexed_context.Make_carbonated_map + (N) + (struct + type t = Script_repr.lazy_expr + + let encoding = Script_repr.lazy_expr_encoding + end) + + type context = I.context + + type key = I.key + + type value = I.value + + let mem = I.mem + + let delete = I.delete + + let remove = I.remove + + let consume_deserialize_gas ctxt value = + Raw_context.check_enough_gas + ctxt + (Script_repr.minimal_deserialize_cost value) + >>? fun () -> + Script_repr.force_decode value + >>? fun (_value, value_cost) -> Raw_context.consume_gas ctxt value_cost + + let consume_serialize_gas ctxt value = + Script_repr.force_bytes value + >>? fun (_value, value_cost) -> Raw_context.consume_gas ctxt value_cost + + let get ctxt contract = + I.get ctxt contract + >>=? fun (ctxt, value) -> + Lwt.return + (consume_deserialize_gas ctxt value >|? fun ctxt -> (ctxt, value)) + + let get_option ctxt contract = + I.get_option ctxt contract + >>=? fun (ctxt, value_opt) -> + Lwt.return + @@ + match value_opt with + | None -> + ok (ctxt, None) + | Some value -> + consume_deserialize_gas ctxt value >|? fun ctxt -> (ctxt, value_opt) + + let set ctxt contract value = + consume_serialize_gas ctxt value + >>?= fun ctxt -> I.set ctxt contract value + + let set_option ctxt contract value_opt = + match value_opt with + | None -> + I.set_option ctxt contract None + | Some value -> + consume_serialize_gas ctxt value + >>?= fun ctxt -> I.set_option ctxt contract value_opt + + let init ctxt contract value = + consume_serialize_gas ctxt value + >>?= fun ctxt -> I.init ctxt contract value + + let init_set ctxt contract value = + consume_serialize_gas ctxt value + >>?= fun ctxt -> I.init_set ctxt contract value + end + + module Code = Make_carbonated_map_expr (struct + let name = ["code"] + end) + + module Storage = Make_carbonated_map_expr (struct + let name = ["storage"] + end) + + module Paid_storage_space = + Indexed_context.Make_map + (struct + let name = ["paid_bytes"] + end) + (Z) + + module Used_storage_space = + Indexed_context.Make_map + (struct + let name = ["used_bytes"] + end) + (Z) + + module Roll_list = + Indexed_context.Make_map + (struct + let name = ["roll_list"] + end) + (Roll_repr) + + module Change = + Indexed_context.Make_map + (struct + let name = ["change"] + end) + (Tez_repr) +end + +(** Big maps handling *) + +module Big_map = struct + type id = Lazy_storage_kind.Big_map.Id.t + + module Raw_context = + Make_subcontext (Registered) (Raw_context) + (struct + let name = ["big_maps"] + end) + + module Next = struct + include Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["next"] + end) + (Lazy_storage_kind.Big_map.Id) + + let incr ctxt = + get ctxt + >>=? fun i -> + set ctxt (Lazy_storage_kind.Big_map.Id.next i) >|=? fun ctxt -> (ctxt, i) + + let init ctxt = init ctxt Lazy_storage_kind.Big_map.Id.init + end + + module Index = struct + (* After flat storage, just use module Index = Lazy_storage_kind.Big_map.Id *) + + include Lazy_storage_kind.Big_map.Id + + let path_length = 6 + path_length + + let to_path c l = + let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in + let (`Hex index_key) = Hex.of_bytes (Raw_hashes.blake2b raw_key) in + String.sub index_key 0 2 :: String.sub index_key 2 2 + :: String.sub index_key 4 2 :: String.sub index_key 6 2 + :: String.sub index_key 8 2 :: String.sub index_key 10 2 :: to_path c l + + let of_path = function + | [] + | [_] + | [_; _] + | [_; _; _] + | [_; _; _; _] + | [_; _; _; _; _] + | [_; _; _; _; _; _] + | _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ -> + None + | index1 :: index2 :: index3 :: index4 :: index5 :: index6 :: tail -> + of_path tail + |> Option.map (fun c -> + let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in + let (`Hex index_key) = + Hex.of_bytes (Raw_hashes.blake2b raw_key) + in + assert (Compare.String.(String.sub index_key 0 2 = index1)) ; + assert (Compare.String.(String.sub index_key 2 2 = index2)) ; + assert (Compare.String.(String.sub index_key 4 2 = index3)) ; + assert (Compare.String.(String.sub index_key 6 2 = index4)) ; + assert (Compare.String.(String.sub index_key 8 2 = index5)) ; + assert (Compare.String.(String.sub index_key 10 2 = index6)) ; + c) + end + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["index"] + end)) + (Make_index (Index)) + + let rpc_arg = Index.rpc_arg + + let fold = Indexed_context.fold_keys + + let list = Indexed_context.keys + + let remove_rec ctxt n = Indexed_context.remove_rec ctxt n + + let copy ctxt ~from ~to_ = Indexed_context.copy ctxt ~from ~to_ + + type key = Raw_context.t * Index.t + + module Total_bytes = + Indexed_context.Make_map + (struct + let name = ["total_bytes"] + end) + (Z) + + module Key_type = + Indexed_context.Make_map + (struct + let name = ["key_type"] + end) + (struct + type t = Script_repr.expr + + let encoding = Script_repr.expr_encoding + end) + + module Value_type = + Indexed_context.Make_map + (struct + let name = ["value_type"] + end) + (struct + type t = Script_repr.expr + + let encoding = Script_repr.expr_encoding + end) + + module Contents = struct + module I = + Storage_functors.Make_indexed_carbonated_data_storage + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["contents"] + end)) + (Make_index (Script_expr_hash)) + (struct + type t = Script_repr.expr + + let encoding = Script_repr.expr_encoding + end) + + type context = I.context + + type key = I.key + + type value = I.value + + let mem = I.mem + + let delete = I.delete + + let remove = I.remove + + let set = I.set + + let set_option = I.set_option + + let init = I.init + + let init_set = I.init_set + + let consume_deserialize_gas ctxt value = + Raw_context.consume_gas ctxt (Script_repr.deserialized_cost value) + + let get ctxt contract = + I.get ctxt contract + >>=? fun (ctxt, value) -> + Lwt.return + (consume_deserialize_gas ctxt value >|? fun ctxt -> (ctxt, value)) + + let get_option ctxt contract = + I.get_option ctxt contract + >>=? fun (ctxt, value_opt) -> + Lwt.return + @@ + match value_opt with + | None -> + ok (ctxt, None) + | Some value -> + consume_deserialize_gas ctxt value >|? fun ctxt -> (ctxt, value_opt) + end +end + +module Sapling = struct + type id = Lazy_storage_kind.Sapling_state.Id.t + + module Raw_context = + Make_subcontext (Registered) (Raw_context) + (struct + let name = ["sapling"] + end) + + module Next = struct + include Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["next"] + end) + (Lazy_storage_kind.Sapling_state.Id) + + let incr ctxt = + get ctxt + >>=? fun i -> + set ctxt (Lazy_storage_kind.Sapling_state.Id.next i) + >|=? fun ctxt -> (ctxt, i) + + let init ctxt = init ctxt Lazy_storage_kind.Sapling_state.Id.init + end + + module Index = Lazy_storage_kind.Sapling_state.Id + + let rpc_arg = Index.rpc_arg + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["index"] + end)) + (Make_index (Index)) + + let remove_rec ctxt n = Indexed_context.remove_rec ctxt n + + let copy ctxt ~from ~to_ = Indexed_context.copy ctxt ~from ~to_ + + module Total_bytes = + Indexed_context.Make_map + (struct + let name = ["total_bytes"] + end) + (Z) + + module Commitments_size = + Make_single_data_storage (Registered) (Indexed_context.Raw_context) + (struct + let name = ["commitments_size"] + end) + (Int64) + + module Memo_size = + Make_single_data_storage (Registered) (Indexed_context.Raw_context) + (struct + let name = ["memo_size"] + end) + (Sapling_repr.Memo_size) + + module Commitments = + Make_indexed_carbonated_data_storage + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["commitments"] + end)) + (Make_index (struct + type t = int64 + + let rpc_arg = + let construct = Int64.to_string in + let destruct hash = + match Int64.of_string_opt hash with + | None -> + Error "Cannot parse node position" + | Some id -> + Ok id + in + RPC_arg.make + ~descr:"The position of a node in a sapling commitment tree" + ~name:"sapling_node_position" + ~construct + ~destruct + () + + let encoding = + Data_encoding.def + "sapling_node_position" + ~title:"Sapling node position" + ~description: + "The position of a node in a sapling commitment tree" + Data_encoding.int64 + + let compare = Compare.Int64.compare + + let path_length = 1 + + let to_path c l = Int64.to_string c :: l + + let of_path = function [c] -> Int64.of_string_opt c | _ -> None + end)) + (Sapling.Hash) + + let commitments_init ctx id = + Indexed_context.Raw_context.remove_rec (ctx, id) ["commitments"] + >|= fun (ctx, _id) -> ctx + + module Ciphertexts = + Make_indexed_carbonated_data_storage + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["ciphertexts"] + end)) + (Make_index (struct + type t = int64 + + let rpc_arg = + let construct = Int64.to_string in + let destruct hash = + match Int64.of_string_opt hash with + | None -> + Error "Cannot parse ciphertext position" + | Some id -> + Ok id + in + RPC_arg.make + ~descr:"The position of a sapling ciphertext" + ~name:"sapling_ciphertext_position" + ~construct + ~destruct + () + + let encoding = + Data_encoding.def + "sapling_ciphertext_position" + ~title:"Sapling ciphertext position" + ~description:"The position of a sapling ciphertext" + Data_encoding.int64 + + let compare = Compare.Int64.compare + + let path_length = 1 + + let to_path c l = Int64.to_string c :: l + + let of_path = function [c] -> Int64.of_string_opt c | _ -> None + end)) + (Sapling.Ciphertext) + + let ciphertexts_init ctx id = + Indexed_context.Raw_context.remove_rec (ctx, id) ["commitments"] + >|= fun (ctx, _id) -> ctx + + module Nullifiers_size = + Make_single_data_storage (Registered) (Indexed_context.Raw_context) + (struct + let name = ["nullifiers_size"] + end) + (Int64) + + (* For sequential access when building a diff *) + module Nullifiers_ordered = + Make_indexed_data_storage + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["nullifiers_ordered"] + end)) + (Make_index (struct + type t = int64 + + let rpc_arg = + let construct = Int64.to_string in + let destruct hash = + match Int64.of_string_opt hash with + | None -> + Error "Cannot parse nullifier position" + | Some id -> + Ok id + in + RPC_arg.make + ~descr:"A sapling nullifier position" + ~name:"sapling_nullifier_position" + ~construct + ~destruct + () + + let encoding = + Data_encoding.def + "sapling_nullifier_position" + ~title:"Sapling nullifier position" + ~description:"Sapling nullifier position" + Data_encoding.int64 + + let compare = Compare.Int64.compare + + let path_length = 1 + + let to_path c l = Int64.to_string c :: l + + let of_path = function [c] -> Int64.of_string_opt c | _ -> None + end)) + (Sapling.Nullifier) + + (* Check membership in O(1) for verify_update *) + module Nullifiers_hashed = + Make_carbonated_data_set_storage + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["nullifiers_hashed"] + end)) + (Make_index (struct + type t = Sapling.Nullifier.t + + let encoding = Sapling.Nullifier.encoding + + let of_string hexstring = + let b = Hex.to_bytes (`Hex hexstring) in + match Data_encoding.Binary.of_bytes encoding b with + | None -> + Error "Cannot parse sapling nullifier" + | Some nf -> + Ok nf + + let to_string nf = + let b = Data_encoding.Binary.to_bytes_exn encoding nf in + let (`Hex hexstring) = Hex.of_bytes b in + hexstring + + let rpc_arg = + RPC_arg.make + ~descr:"A sapling nullifier" + ~name:"sapling_nullifier" + ~construct:to_string + ~destruct:of_string + () + + let compare = Sapling.Nullifier.compare + + let path_length = 1 + + let to_path c l = to_string c :: l + + let of_path = function + | [c] -> ( + match of_string c with Error _ -> None | Ok nf -> Some nf ) + | _ -> + None + end)) + + let nullifiers_init ctx id = + Nullifiers_size.init_set (ctx, id) Int64.zero + >>= fun ctx -> + Indexed_context.Raw_context.remove_rec (ctx, id) ["nullifiers_ordered"] + >>= fun (ctx, id) -> + Indexed_context.Raw_context.remove_rec (ctx, id) ["nullifiers_hashed"] + >|= fun (ctx, _id) -> ctx + + module Roots = + Make_indexed_data_storage + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["roots"] + end)) + (Make_index (struct + type t = int32 + + let rpc_arg = + let construct = Int32.to_string in + let destruct hash = + match Int32.of_string_opt hash with + | None -> + Error "Cannot parse nullifier position" + | Some id -> + Ok id + in + RPC_arg.make + ~descr:"A sapling root" + ~name:"sapling_root" + ~construct + ~destruct + () + + let encoding = + Data_encoding.def + "sapling_root" + ~title:"Sapling root" + ~description:"Sapling root" + Data_encoding.int32 + + let compare = Compare.Int32.compare + + let path_length = 1 + + let to_path c l = Int32.to_string c :: l + + let of_path = function [c] -> Int32.of_string_opt c | _ -> None + end)) + (Sapling.Hash) + + module Roots_pos = + Make_single_data_storage (Registered) (Indexed_context.Raw_context) + (struct + let name = ["roots_pos"] + end) + (Int32) + + module Roots_level = + Make_single_data_storage (Registered) (Indexed_context.Raw_context) + (struct + let name = ["roots_level"] + end) + (Raw_level_repr) +end + +module Delegates = + Make_data_set_storage + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["delegates"] + end)) + (Make_index (Signature.Public_key_hash)) + +module Active_delegates_with_rolls = + Make_data_set_storage + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["active_delegates_with_rolls"] + end)) + (Make_index (Signature.Public_key_hash)) + +module Delegates_with_frozen_balance_index = + Make_indexed_subcontext + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["delegates_with_frozen_balance"] + end)) + (Make_index (Cycle_repr.Index)) + +module Delegates_with_frozen_balance = + Make_data_set_storage + (Delegates_with_frozen_balance_index.Raw_context) + (Make_index (Signature.Public_key_hash)) + +(** Rolls *) + +module Cycle = struct + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["cycle"] + end)) + (Make_index (Cycle_repr.Index)) + + module Last_roll = + Make_indexed_data_storage + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["last_roll"] + end)) + (Int31_index) + (Roll_repr) + + module Roll_snapshot = + Indexed_context.Make_map + (struct + let name = ["roll_snapshot"] + end) + (UInt16) + + type unrevealed_nonce = { + nonce_hash : Nonce_hash.t; + delegate : Signature.Public_key_hash.t; + rewards : Tez_repr.t; + fees : Tez_repr.t; + } + + type nonce_status = + | Unrevealed of unrevealed_nonce + | Revealed of Seed_repr.nonce + + let nonce_status_encoding = + let open Data_encoding in + union + [ case + (Tag 0) + ~title:"Unrevealed" + (tup4 + Nonce_hash.encoding + Signature.Public_key_hash.encoding + Tez_repr.encoding + Tez_repr.encoding) + (function + | Unrevealed {nonce_hash; delegate; rewards; fees} -> + Some (nonce_hash, delegate, rewards, fees) + | _ -> + None) + (fun (nonce_hash, delegate, rewards, fees) -> + Unrevealed {nonce_hash; delegate; rewards; fees}); + case + (Tag 1) + ~title:"Revealed" + Seed_repr.nonce_encoding + (function Revealed nonce -> Some nonce | _ -> None) + (fun nonce -> Revealed nonce) ] + + module Nonce = + Make_indexed_data_storage + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["nonces"] + end)) + (Make_index (Raw_level_repr.Index)) + (struct + type t = nonce_status + + let encoding = nonce_status_encoding + end) + + module Seed = + Indexed_context.Make_map + (struct + let name = ["random_seed"] + end) + (struct + type t = Seed_repr.seed + + let encoding = Seed_repr.seed_encoding + end) +end + +module Roll = struct + module Raw_context = + Make_subcontext (Registered) (Raw_context) + (struct + let name = ["rolls"] + end) + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["index"] + end)) + (Make_index (Roll_repr.Index)) + + module Next = + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["next"] + end) + (Roll_repr) + + module Limbo = + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["limbo"] + end) + (Roll_repr) + + module Delegate_roll_list = + Wrap_indexed_data_storage + (Contract.Roll_list) + (struct + type t = Signature.Public_key_hash.t + + let wrap = Contract_repr.implicit_contract + + let unwrap = Contract_repr.is_implicit + end) + + module Successor = + Indexed_context.Make_map + (struct + let name = ["successor"] + end) + (Roll_repr) + + module Delegate_change = + Wrap_indexed_data_storage + (Contract.Change) + (struct + type t = Signature.Public_key_hash.t + + let wrap = Contract_repr.implicit_contract + + let unwrap = Contract_repr.is_implicit + end) + + module Snapshoted_owner_index = struct + type t = Cycle_repr.t * int + + let path_length = Cycle_repr.Index.path_length + 1 + + let to_path (c, n) s = Cycle_repr.Index.to_path c (string_of_int n :: s) + + let of_path l = + match Misc.take Cycle_repr.Index.path_length l with + | None | Some (_, ([] | _ :: _ :: _)) -> + None + | Some (l1, [l2]) -> ( + match (Cycle_repr.Index.of_path l1, int_of_string_opt l2) with + | (None, _) | (_, None) -> + None + | (Some c, Some i) -> + Some (c, i) ) + + type 'a ipath = ('a * Cycle_repr.t) * int + + let left_args = + Storage_description.One + { + rpc_arg = Cycle_repr.rpc_arg; + encoding = Cycle_repr.encoding; + compare = Cycle_repr.compare; + } + + let right_args = + Storage_description.One + { + rpc_arg = RPC_arg.int; + encoding = Data_encoding.int31; + compare = Compare.Int.compare; + } + + let args = Storage_description.(Pair (left_args, right_args)) + end + + module Owner = + Make_indexed_data_snapshotable_storage + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["owner"] + end)) + (Snapshoted_owner_index) + (Make_index (Roll_repr.Index)) + (Signature.Public_key) + + module Snapshot_for_cycle = Cycle.Roll_snapshot + module Last_for_snapshot = Cycle.Last_roll + + let clear = Indexed_context.clear +end + +(** Votes *) + +module Vote = struct + module Raw_context = + Make_subcontext (Registered) (Raw_context) + (struct + let name = ["votes"] + end) + + module Pred_period_kind = + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["pred_period_kind"] + end) + (struct + type t = Voting_period_repr.kind + + let encoding = Voting_period_repr.kind_encoding + end) + + module Current_period_kind_007 = + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["current_period_kind"] + end) + (struct + type t = Voting_period_repr.kind + + let encoding = Voting_period_repr.kind_encoding + end) + + module Current_period = + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["current_period"] + end) + (struct + type t = Voting_period_repr.t + + let encoding = Voting_period_repr.encoding + end) + + module Participation_ema = + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["participation_ema"] + end) + (Int32) + + module Current_proposal = + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["current_proposal"] + end) + (Protocol_hash) + + module Listings_size = + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["listings_size"] + end) + (Int32) + + module Listings = + Make_indexed_data_storage + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["listings"] + end)) + (Make_index (Signature.Public_key_hash)) + (Int32) + + module Proposals = + Make_data_set_storage + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["proposals"] + end)) + (Pair + (Make_index + (Protocol_hash)) + (Make_index (Signature.Public_key_hash))) + + module Proposals_count = + Make_indexed_data_storage + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["proposals_count"] + end)) + (Make_index (Signature.Public_key_hash)) + (UInt16) + + module Ballots = + Make_indexed_data_storage + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["ballots"] + end)) + (Make_index (Signature.Public_key_hash)) + (struct + type t = Vote_repr.ballot + + let encoding = Vote_repr.ballot_encoding + end) +end + +(** Seed *) + +module Seed = struct + type unrevealed_nonce = Cycle.unrevealed_nonce = { + nonce_hash : Nonce_hash.t; + delegate : Signature.Public_key_hash.t; + rewards : Tez_repr.t; + fees : Tez_repr.t; + } + + type nonce_status = Cycle.nonce_status = + | Unrevealed of unrevealed_nonce + | Revealed of Seed_repr.nonce + + module Nonce = struct + open Level_repr + + type context = Raw_context.t + + let mem ctxt (l : Level_repr.t) = Cycle.Nonce.mem (ctxt, l.cycle) l.level + + let get ctxt (l : Level_repr.t) = Cycle.Nonce.get (ctxt, l.cycle) l.level + + let get_option ctxt (l : Level_repr.t) = + Cycle.Nonce.get_option (ctxt, l.cycle) l.level + + let set ctxt (l : Level_repr.t) v = + Cycle.Nonce.set (ctxt, l.cycle) l.level v + + let init ctxt (l : Level_repr.t) v = + Cycle.Nonce.init (ctxt, l.cycle) l.level v + + let init_set ctxt (l : Level_repr.t) v = + Cycle.Nonce.init_set (ctxt, l.cycle) l.level v + + let set_option ctxt (l : Level_repr.t) v = + Cycle.Nonce.set_option (ctxt, l.cycle) l.level v + + let delete ctxt (l : Level_repr.t) = + Cycle.Nonce.delete (ctxt, l.cycle) l.level + + let remove ctxt (l : Level_repr.t) = + Cycle.Nonce.remove (ctxt, l.cycle) l.level + end + + module For_cycle = Cycle.Seed +end + +(** Commitments *) + +module Commitments = + Make_indexed_data_storage + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["commitments"] + end)) + (Make_index (Blinded_public_key_hash.Index)) + (Tez_repr) + +(** Ramp up security deposits... *) + +module Ramp_up = struct + module Rewards = + Make_indexed_data_storage + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["ramp_up"; "rewards"] + end)) + (Make_index (Cycle_repr.Index)) + (struct + type t = Tez_repr.t list * Tez_repr.t list + + let encoding = + Data_encoding.( + obj2 + (req "baking_reward_per_endorsement" (list Tez_repr.encoding)) + (req "endorsement_reward" (list Tez_repr.encoding))) + end) + + module Security_deposits = + Make_indexed_data_storage + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["ramp_up"; "deposits"] + end)) + (Make_index (Cycle_repr.Index)) + (struct + type t = Tez_repr.t * Tez_repr.t + + let encoding = + Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding + end) +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..52135f0a68cda1759a80ede59e897648146fd28c --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/storage.mli @@ -0,0 +1,488 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos Protocol Implementation - Typed storage + + This module hides the hierarchical (key x value) database under + pre-allocated typed accessors for all persistent entities of the + tezos context. + + This interface enforces no invariant on the contents of the + database. Its goal is to centralize all accessors in order to have + a complete view over the database contents and avoid key + collisions. *) + +open Storage_sigs + +module Block_priority : sig + val get : Raw_context.t -> int tzresult Lwt.t + + val set : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t + + val init : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t +end + +module Roll : sig + (** Storage from this submodule must only be accessed through the + module `Roll`. *) + + module Owner : + Indexed_data_snapshotable_storage + with type key = Roll_repr.t + and type snapshot = Cycle_repr.t * int + and type value = Signature.Public_key.t + and type t := Raw_context.t + + val clear : Raw_context.t -> Raw_context.t Lwt.t + + (** The next roll to be allocated. *) + module Next : + Single_data_storage + with type value = Roll_repr.t + and type t := Raw_context.t + + (** Rolls linked lists represent both account owned and free rolls. + All rolls belongs either to the limbo list or to an owned list. *) + + (** Head of the linked list of rolls in limbo *) + module Limbo : + Single_data_storage + with type value = Roll_repr.t + and type t := Raw_context.t + + (** Rolls associated to contracts, a linked list per contract *) + module Delegate_roll_list : + Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = Roll_repr.t + and type t := Raw_context.t + + (** Use this to iter on a linked list of rolls *) + module Successor : + Indexed_data_storage + with type key = Roll_repr.t + and type value = Roll_repr.t + and type t := Raw_context.t + + (** The tez of a contract that are not assigned to rolls *) + module Delegate_change : + Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = Tez_repr.t + and type t := Raw_context.t + + (** Index of the randomly selected roll snapshot of a given cycle. *) + module Snapshot_for_cycle : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = int + and type t := Raw_context.t + + (** Last roll in the snapshoted roll allocation of a given cycle. *) + module Last_for_snapshot : + Indexed_data_storage + with type key = int + and type value = Roll_repr.t + and type t = Raw_context.t * Cycle_repr.t +end + +module Contract : sig + (** Storage from this submodule must only be accessed through the + module `Contract`. *) + + module Global_counter : sig + val get : Raw_context.t -> Z.t tzresult Lwt.t + + val set : Raw_context.t -> Z.t -> Raw_context.t tzresult Lwt.t + + val init : Raw_context.t -> Z.t -> Raw_context.t tzresult Lwt.t + end + + (** The domain of alive contracts *) + val fold : + Raw_context.t -> + init:'a -> + f:(Contract_repr.t -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + + val list : Raw_context.t -> Contract_repr.t list Lwt.t + + (** All the tez possessed by a contract, including rolls and change *) + module Balance : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Tez_repr.t + and type t := Raw_context.t + + (** Frozen balance, see 'delegate_storage.mli' for more explanation. + Always update `Delegates_with_frozen_balance` accordingly. *) + module Frozen_deposits : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t + and type t = Raw_context.t * Contract_repr.t + + module Frozen_fees : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t + and type t = Raw_context.t * Contract_repr.t + + module Frozen_rewards : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t + and type t = Raw_context.t * Contract_repr.t + + (** The manager of a contract *) + module Manager : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Manager_repr.t + and type t := Raw_context.t + + (** The delegate of a contract, if any. *) + module Delegate : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Signature.Public_key_hash.t + and type t := Raw_context.t + + (** All contracts (implicit and originated) that are delegated, if any *) + module Delegated : + Data_set_storage + with type elt = Contract_repr.t + and type t = Raw_context.t * Contract_repr.t + + module Inactive_delegate : + Data_set_storage with type elt = Contract_repr.t and type t = Raw_context.t + + (** The cycle where the delegate should be deactivated. *) + module Delegate_desactivation : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Cycle_repr.t + and type t := Raw_context.t + + module Counter : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Z.t + and type t := Raw_context.t + + module Code : + Non_iterable_indexed_carbonated_data_storage + with type key = Contract_repr.t + and type value = Script_repr.lazy_expr + and type t := Raw_context.t + + module Storage : + Non_iterable_indexed_carbonated_data_storage + with type key = Contract_repr.t + and type value = Script_repr.lazy_expr + and type t := Raw_context.t + + (** Current storage space in bytes. + Includes code, global storage and big map elements. *) + module Used_storage_space : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Z.t + and type t := Raw_context.t + + (** Maximal space available without needing to burn new fees. *) + module Paid_storage_space : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Z.t + and type t := Raw_context.t +end + +module Big_map : sig + type id = Lazy_storage_kind.Big_map.Id.t + + module Next : sig + val incr : Raw_context.t -> (Raw_context.t * id) tzresult Lwt.t + + val init : Raw_context.t -> Raw_context.t tzresult Lwt.t + end + + (** The domain of alive big maps *) + val fold : Raw_context.t -> init:'a -> f:(id -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + val list : Raw_context.t -> id list Lwt.t + + val remove_rec : Raw_context.t -> id -> Raw_context.t Lwt.t + + val copy : Raw_context.t -> from:id -> to_:id -> Raw_context.t tzresult Lwt.t + + type key = Raw_context.t * id + + val rpc_arg : id RPC_arg.t + + module Contents : + Non_iterable_indexed_carbonated_data_storage + with type key = Script_expr_hash.t + and type value = Script_repr.expr + and type t := key + + module Total_bytes : + Indexed_data_storage + with type key = id + and type value = Z.t + and type t := Raw_context.t + + module Key_type : + Indexed_data_storage + with type key = id + and type value = Script_repr.expr + and type t := Raw_context.t + + module Value_type : + Indexed_data_storage + with type key = id + and type value = Script_repr.expr + and type t := Raw_context.t +end + +module Sapling : sig + type id = Lazy_storage_kind.Sapling_state.Id.t + + val rpc_arg : id RPC_arg.t + + module Next : sig + val incr : Raw_context.t -> (Raw_context.t * id) tzresult Lwt.t + + val init : Raw_context.t -> Raw_context.t tzresult Lwt.t + end + + val remove_rec : Raw_context.t -> id -> Raw_context.t Lwt.t + + val copy : Raw_context.t -> from:id -> to_:id -> Raw_context.t tzresult Lwt.t + + module Total_bytes : + Indexed_data_storage + with type key = id + and type value = Z.t + and type t := Raw_context.t + + (* Used by both Commitments and Ciphertexts *) + module Commitments_size : + Single_data_storage + with type t := Raw_context.t * id + and type value = int64 + + module Memo_size : + Single_data_storage with type t := Raw_context.t * id and type value = int + + module Commitments : + Non_iterable_indexed_carbonated_data_storage + with type t := Raw_context.t * id + and type key = int64 + and type value = Sapling.Hash.t + + val commitments_init : Raw_context.t -> id -> Raw_context.t Lwt.t + + module Ciphertexts : + Non_iterable_indexed_carbonated_data_storage + with type t := Raw_context.t * id + and type key = int64 + and type value = Sapling.Ciphertext.t + + val ciphertexts_init : Raw_context.t -> id -> Raw_context.t Lwt.t + + module Nullifiers_size : + Single_data_storage + with type t := Raw_context.t * id + and type value = int64 + + module Nullifiers_ordered : + Non_iterable_indexed_data_storage + with type t := Raw_context.t * id + and type key = int64 + and type value = Sapling.Nullifier.t + + module Nullifiers_hashed : + Carbonated_data_set_storage + with type t := Raw_context.t * id + and type elt = Sapling.Nullifier.t + + val nullifiers_init : Raw_context.t -> id -> Raw_context.t Lwt.t + + module Roots : + Non_iterable_indexed_data_storage + with type t := Raw_context.t * id + and type key = int32 + and type value = Sapling.Hash.t + + module Roots_pos : + Single_data_storage + with type t := Raw_context.t * id + and type value = int32 + + module Roots_level : + Single_data_storage + with type t := Raw_context.t * id + and type value = Raw_level_repr.t +end + +(** Set of all registered delegates. *) +module Delegates : + Data_set_storage + with type t := Raw_context.t + and type elt = Signature.Public_key_hash.t + +(** Set of all active delegates with rolls. *) +module Active_delegates_with_rolls : + Data_set_storage + with type t := Raw_context.t + and type elt = Signature.Public_key_hash.t + +(** Set of all the delegates with frozen rewards/bonds/fees for a given cycle. *) +module Delegates_with_frozen_balance : + Data_set_storage + with type t = Raw_context.t * Cycle_repr.t + and type elt = Signature.Public_key_hash.t + +(** Votes *) + +module Vote : sig + module Pred_period_kind : + Single_data_storage + with type value = Voting_period_repr.kind + and type t := Raw_context.t + + module Current_period_kind_007 : + Single_data_storage + with type value = Voting_period_repr.kind + and type t := Raw_context.t + + module Current_period : + Single_data_storage + with type value = Voting_period_repr.t + and type t := Raw_context.t + + (** Participation exponential moving average, in centile of percentage *) + module Participation_ema : + Single_data_storage with type value = int32 and type t := Raw_context.t + + module Current_proposal : + Single_data_storage + with type value = Protocol_hash.t + and type t := Raw_context.t + + (** Sum of all rolls of all delegates. *) + module Listings_size : + Single_data_storage with type value = int32 and type t := Raw_context.t + + (** Contains all delegates with their assigned number of rolls. *) + module Listings : + Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = int32 + and type t := Raw_context.t + + (** Set of protocol proposal with corresponding proposer delegate *) + module Proposals : + Data_set_storage + with type elt = Protocol_hash.t * Signature.Public_key_hash.t + and type t := Raw_context.t + + (** Keeps for each delegate the number of proposed protocols *) + module Proposals_count : + Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = int + and type t := Raw_context.t + + (** Contains for each delegate its ballot *) + module Ballots : + Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = Vote_repr.ballot + and type t := Raw_context.t +end + +(** Seed *) + +module Seed : sig + (** Storage from this submodule must only be accessed through the + module `Seed`. *) + + type unrevealed_nonce = { + nonce_hash : Nonce_hash.t; + delegate : Signature.Public_key_hash.t; + rewards : Tez_repr.t; + fees : Tez_repr.t; + } + + type nonce_status = + | Unrevealed of unrevealed_nonce + | Revealed of Seed_repr.nonce + + module Nonce : + Non_iterable_indexed_data_storage + with type key := Level_repr.t + and type value := nonce_status + and type t := Raw_context.t + + module For_cycle : sig + val init : + Raw_context.t -> + Cycle_repr.t -> + Seed_repr.seed -> + Raw_context.t tzresult Lwt.t + + val get : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t + + val delete : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t + end +end + +(** Commitments *) + +module Commitments : + Indexed_data_storage + with type key = Blinded_public_key_hash.t + and type value = Tez_repr.t + and type t := Raw_context.t + +(** Ramp up security deposits... *) + +module Ramp_up : sig + module Rewards : + Indexed_data_storage + with type key = Cycle_repr.t + and type value := Tez_repr.t list * Tez_repr.t list + (* baking rewards per endorsement * endorsement rewards *) + and type t := Raw_context.t + + module Security_deposits : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t * Tez_repr.t + (* baking * endorsement *) + and type t := Raw_context.t +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/storage_costs.ml b/src/proto_008_PtEdo2Zk/lib_protocol/storage_costs.ml new file mode 100644 index 0000000000000000000000000000000000000000..f2d14564babedb727707c6e16575de5151d96ed5 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/storage_costs.ml @@ -0,0 +1,41 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* The model for read accesses is the following: + + cost(path_length, read_bytes) = 200_000 + 5000 * path_length + 2 * read_bytes +*) +let read_access ~path_length ~read_bytes = + let base_cost = Z.of_int (200_000 + (5000 * path_length)) in + Gas_limit_repr.atomic_step_cost + (Z.add base_cost (Z.mul (Z.of_int 2) (Z.of_int read_bytes))) + +(* The model for write accesses is the following: + + cost(written_bytes) = 200_000 + 4 * written_bytes +*) +let write_access ~written_bytes = + Gas_limit_repr.atomic_step_cost + (Z.add (Z.of_int 200_000) (Z.mul (Z.of_int 4) (Z.of_int written_bytes))) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/storage_costs.mli b/src/proto_008_PtEdo2Zk/lib_protocol/storage_costs.mli new file mode 100644 index 0000000000000000000000000000000000000000..0b91ce04eaaeef355cb5c30393331439c413ccf4 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/storage_costs.mli @@ -0,0 +1,30 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Cost of reading [read_bytes] at a key of length [path_length]. *) +val read_access : path_length:int -> read_bytes:int -> Gas_limit_repr.cost + +(** Cost of performing a single write access, writing [written_bytes] bytes. *) +val write_access : written_bytes:int -> Gas_limit_repr.cost diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/storage_description.ml b/src/proto_008_PtEdo2Zk/lib_protocol/storage_description.ml new file mode 100644 index 0000000000000000000000000000000000000000..ad91de97eca4dce15b07a7bfe23f23b6a3702375 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/storage_description.ml @@ -0,0 +1,337 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module StringMap = Map.Make (String) + +type 'key t = 'key description ref + +and 'key description = + | Empty : 'key description + | Value : { + get : 'key -> 'a option tzresult Lwt.t; + encoding : 'a Data_encoding.t; + } + -> 'key description + | NamedDir : 'key t StringMap.t -> 'key description + | IndexedDir : { + arg : 'a RPC_arg.t; + arg_encoding : 'a Data_encoding.t; + list : 'key -> 'a list tzresult Lwt.t; + subdir : ('key * 'a) t; + } + -> 'key description + +let rec register_named_subcontext : type r. r t -> string list -> r t = + fun dir names -> + match (!dir, names) with + | (_, []) -> + dir + | (Value _, _) -> + invalid_arg "" + | (IndexedDir _, _) -> + invalid_arg "" + | (Empty, name :: names) -> + let subdir = ref Empty in + dir := NamedDir (StringMap.singleton name subdir) ; + register_named_subcontext subdir names + | (NamedDir map, name :: names) -> + let subdir = + match StringMap.find_opt name map with + | Some subdir -> + subdir + | None -> + let subdir = ref Empty in + dir := NamedDir (StringMap.add name subdir map) ; + subdir + in + register_named_subcontext subdir names + +type (_, _, _) args = + | One : { + rpc_arg : 'a RPC_arg.t; + encoding : 'a Data_encoding.t; + compare : 'a -> 'a -> int; + } + -> ('key, 'a, 'key * 'a) args + | Pair : + ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args + -> ('key, 'a * 'b, 'sub_key) args + +let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function + | One _ -> + fun x -> x + | Pair (l, r) -> + let unpack_l = unpack l in + let unpack_r = unpack r in + fun x -> + let (c, d) = unpack_r x in + let (b, a) = unpack_l c in + (b, (a, d)) + +let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function + | One _ -> + fun b a -> (b, a) + | Pair (l, r) -> + let pack_l = pack l in + let pack_r = pack r in + fun b (a, d) -> + let c = pack_l b a in + pack_r c d + +let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function + | One {compare; _} -> + compare + | Pair (l, r) -> ( + let compare_l = compare l in + let compare_r = compare r in + fun (a1, b1) (a2, b2) -> + match compare_l a1 a2 with 0 -> compare_r b1 b2 | x -> x ) + +let destutter equal l = + match l with + | [] -> + [] + | (i, _) :: l -> + let rec loop acc i = function + | [] -> + acc + | (j, _) :: l -> + if equal i j then loop acc i l else loop (j :: acc) j l + in + loop [i] i l + +let rec register_indexed_subcontext : + type r a b. + r t -> list:(r -> a list tzresult Lwt.t) -> (r, a, b) args -> b t = + fun dir ~list path -> + match path with + | Pair (left, right) -> + let compare_left = compare left in + let equal_left x y = Compare.Int.(compare_left x y = 0) in + let list_left r = list r >|=? fun l -> destutter equal_left l in + let list_right r = + let (a, k) = unpack left r in + list a + >|=? fun l -> + List.map snd (List.filter (fun (x, _) -> equal_left x k) l) + in + register_indexed_subcontext + (register_indexed_subcontext dir ~list:list_left left) + ~list:list_right + right + | One {rpc_arg = arg; encoding = arg_encoding; _} -> ( + match !dir with + | Value _ -> + invalid_arg "" + | NamedDir _ -> + invalid_arg "" + | Empty -> + let subdir = ref Empty in + dir := IndexedDir {arg; arg_encoding; list; subdir} ; + subdir + | IndexedDir {arg = inner_arg; subdir; _} -> ( + match RPC_arg.eq arg inner_arg with + | None -> + invalid_arg "" + | Some RPC_arg.Eq -> + subdir ) ) + +let register_value : + type a b. + a t -> get:(a -> b option tzresult Lwt.t) -> b Data_encoding.t -> unit = + fun dir ~get encoding -> + match !dir with Empty -> dir := Value {get; encoding} | _ -> invalid_arg "" + +let create () = ref Empty + +let rec pp : type a. Format.formatter -> a t -> unit = + fun ppf dir -> + match !dir with + | Empty -> + Format.fprintf ppf "EMPTY" + | Value _e -> + Format.fprintf ppf "Value" + | NamedDir map -> + Format.fprintf + ppf + "@[%a@]" + (Format.pp_print_list pp_item) + (StringMap.bindings map) + | IndexedDir {arg; subdir; _} -> + let name = Format.asprintf "<%s>" (RPC_arg.descr arg).name in + pp_item ppf (name, subdir) + +and pp_item : type a. Format.formatter -> string * a t -> unit = + fun ppf (name, dir) -> Format.fprintf ppf "@[%s@ %a@]" name pp dir + +module type INDEX = sig + type t + + val path_length : int + + val to_path : t -> string list -> string list + + val of_path : string list -> t option + + val rpc_arg : t RPC_arg.t + + val encoding : t Data_encoding.t + + val compare : t -> t -> int +end + +type _ handler = + | Handler : { + encoding : 'a Data_encoding.t; + get : 'key -> int -> 'a tzresult Lwt.t; + } + -> 'key handler + +type _ opt_handler = + | Opt_handler : { + encoding : 'a Data_encoding.t; + get : 'key -> int -> 'a option tzresult Lwt.t; + } + -> 'key opt_handler + +let rec combine_object = function + | [] -> + Handler {encoding = Data_encoding.unit; get = (fun _ _ -> return_unit)} + | (name, Opt_handler handler) :: fields -> + let (Handler handlers) = combine_object fields in + Handler + { + encoding = + Data_encoding.merge_objs + Data_encoding.(obj1 (opt name (dynamic_size handler.encoding))) + handlers.encoding; + get = + (fun k i -> + handler.get k i + >>=? fun v1 -> handlers.get k i >|=? fun v2 -> (v1, v2)); + } + +type query = {depth : int} + +let depth_query = + let open RPC_query in + query (fun depth -> {depth}) + |+ field "depth" RPC_arg.int 0 (fun t -> t.depth) + |> seal + +let build_directory : type key. key t -> key RPC_directory.t = + fun dir -> + let rpc_dir = ref (RPC_directory.empty : key RPC_directory.t) in + let register : type ikey. (key, ikey) RPC_path.t -> ikey opt_handler -> unit + = + fun path (Opt_handler {encoding; get}) -> + let service = + RPC_service.get_service ~query:depth_query ~output:encoding path + in + rpc_dir := + RPC_directory.register !rpc_dir service (fun k q () -> + get k (q.depth + 1) + >|=? function None -> raise Not_found | Some x -> x) + in + let rec build_handler : + type ikey. ikey t -> (key, ikey) RPC_path.t -> ikey opt_handler = + fun dir path -> + match !dir with + | Empty -> + Opt_handler + {encoding = Data_encoding.unit; get = (fun _ _ -> return_none)} + | Value {get; encoding} -> + let handler = + Opt_handler + { + encoding; + get = + (fun k i -> if Compare.Int.(i < 0) then return_none else get k); + } + in + register path handler ; handler + | NamedDir map -> + let fields = StringMap.bindings map in + let fields = + List.map + (fun (name, dir) -> + (name, build_handler dir RPC_path.(path / name))) + fields + in + let (Handler handler) = combine_object fields in + let handler = + Opt_handler + { + encoding = handler.encoding; + get = + (fun k i -> + if Compare.Int.(i < 0) then return_none + else handler.get k (i - 1) >>=? fun v -> return_some v); + } + in + register path handler ; handler + | IndexedDir {arg; arg_encoding; list; subdir} -> + let (Opt_handler handler) = + build_handler subdir RPC_path.(path /: arg) + in + let encoding = + let open Data_encoding in + union + [ case + (Tag 0) + ~title:"Leaf" + (dynamic_size arg_encoding) + (function (key, None) -> Some key | _ -> None) + (fun key -> (key, None)); + case + (Tag 1) + ~title:"Dir" + (tup2 + (dynamic_size arg_encoding) + (dynamic_size handler.encoding)) + (function (key, Some value) -> Some (key, value) | _ -> None) + (fun (key, value) -> (key, Some value)) ] + in + let get k i = + if Compare.Int.(i < 0) then return_none + else if Compare.Int.(i = 0) then return_some [] + else + list k + >>=? fun keys -> + map_s + (fun key -> + if Compare.Int.(i = 1) then return (key, None) + else handler.get (k, key) (i - 1) >|=? fun value -> (key, value)) + keys + >>=? fun values -> return_some values + in + let handler = + Opt_handler + {encoding = Data_encoding.(list (dynamic_size encoding)); get} + in + register path handler ; handler + in + ignore (build_handler dir RPC_path.open_root : key opt_handler) ; + !rpc_dir diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/storage_description.mli b/src/proto_008_PtEdo2Zk/lib_protocol/storage_description.mli new file mode 100644 index 0000000000000000000000000000000000000000..ccd7587082e9458e2996a89bc6d617ad9e9fe95c --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/storage_description.mli @@ -0,0 +1,95 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Typed description of the key-value context. *) +type 'key t + +(** Trivial display of the key-value context layout. *) +val pp : Format.formatter -> 'key t -> unit + +(** Export an RPC hierarchy for querying the context. There is one service + by possible path in the context. Services for "directory" are able to + aggregate in one JSON object the whole subtree. *) +val build_directory : 'key t -> 'key RPC_directory.t + +(** Create a empty context description, + keys will be registered by side effects. *) +val create : unit -> 'key t + +(** Register a single key accessor at a given path. *) +val register_value : + 'key t -> + get:('key -> 'a option tzresult Lwt.t) -> + 'a Data_encoding.t -> + unit + +(** Return a description for a prefixed fragment of the given context. + All keys registered in the subcontext will be shared by the external + context *) +val register_named_subcontext : 'key t -> string list -> 'key t + +(** Description of an index as a sequence of `RPC_arg.t`. *) +type (_, _, _) args = + | One : { + rpc_arg : 'a RPC_arg.t; + encoding : 'a Data_encoding.t; + compare : 'a -> 'a -> int; + } + -> ('key, 'a, 'key * 'a) args + | Pair : + ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args + -> ('key, 'a * 'b, 'sub_key) args + +(** Return a description for a indexed sub-context. + All keys registered in the subcontext will be shared by the external + context. One should provide a function to list all the registered + index in the context. *) +val register_indexed_subcontext : + 'key t -> + list:('key -> 'arg list tzresult Lwt.t) -> + ('key, 'arg, 'sub_key) args -> + 'sub_key t + +(** Helpers for manipulating and defining indexes. *) + +val pack : ('key, 'a, 'sub_key) args -> 'key -> 'a -> 'sub_key + +val unpack : ('key, 'a, 'sub_key) args -> 'sub_key -> 'key * 'a + +module type INDEX = sig + type t + + val path_length : int + + val to_path : t -> string list -> string list + + val of_path : string list -> t option + + val rpc_arg : t RPC_arg.t + + val encoding : t Data_encoding.t + + val compare : t -> t -> int +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/storage_functors.ml b/src/proto_008_PtEdo2Zk/lib_protocol/storage_functors.ml new file mode 100644 index 0000000000000000000000000000000000000000..77f8d6cd16e2b2de57e159ff24757ed741cbb874 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/storage_functors.ml @@ -0,0 +1,1170 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Storage_sigs + +module Registered = struct + let ghost = false +end + +module Ghost = struct + let ghost = true +end + +module Make_encoder (V : VALUE) = struct + let of_bytes ~key b = + match Data_encoding.Binary.of_bytes V.encoding b with + | None -> + error (Raw_context.Storage_error (Corrupted_data key)) + | Some v -> + Ok v + + let to_bytes v = + match Data_encoding.Binary.to_bytes V.encoding v with + | Some b -> + b + | None -> + Bytes.empty +end + +let len_name = "len" + +let data_name = "data" + +let encode_len_value bytes = + let length = Bytes.length bytes in + Data_encoding.(Binary.to_bytes_exn int31) length + +let decode_len_value key len = + match Data_encoding.(Binary.of_bytes int31) len with + | None -> + error (Raw_context.Storage_error (Corrupted_data key)) + | Some len -> + ok len + +let map_key f = function `Key k -> `Key (f k) | `Dir k -> `Dir (f k) + +module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : + Raw_context.T with type t = C.t = struct + type t = C.t + + type context = t + + let name_length = List.length N.name + + let to_key k = N.name @ k + + let of_key k = Misc.remove_elem_from_list name_length k + + let mem t k = C.mem t (to_key k) + + let dir_mem t k = C.dir_mem t (to_key k) + + let get t k = C.get t (to_key k) + + let get_option t k = C.get_option t (to_key k) + + let init t k v = C.init t (to_key k) v + + let set t k v = C.set t (to_key k) v + + let init_set t k v = C.init_set t (to_key k) v + + let set_option t k v = C.set_option t (to_key k) v + + let delete t k = C.delete t (to_key k) + + let remove t k = C.remove t (to_key k) + + let remove_rec t k = C.remove_rec t (to_key k) + + let copy t ~from ~to_ = C.copy t ~from:(to_key from) ~to_:(to_key to_) + + let fold t k ~init ~f = + C.fold t (to_key k) ~init ~f:(fun k acc -> f (map_key of_key k) acc) + + let keys t k = C.keys t (to_key k) >|= fun keys -> List.map of_key keys + + let fold_keys t k ~init ~f = + C.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc) + + let project = C.project + + let absolute_key c k = C.absolute_key c (to_key k) + + let consume_gas = C.consume_gas + + let check_enough_gas = C.check_enough_gas + + let description = + let description = + if R.ghost then Storage_description.create () else C.description + in + Storage_description.register_named_subcontext description N.name +end + +module Make_single_data_storage + (R : REGISTER) + (C : Raw_context.T) + (N : NAME) + (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t = +struct + type t = C.t + + type context = t + + type value = V.t + + let mem t = C.mem t N.name + + include Make_encoder (V) + + let get t = + C.get t N.name + >>=? fun b -> + let key = C.absolute_key t N.name in + Lwt.return (of_bytes ~key b) + + let get_option t = + C.get_option t N.name + >|= function + | None -> + ok_none + | Some b -> + let key = C.absolute_key t N.name in + of_bytes ~key b >|? fun v -> Some v + + let init t v = C.init t N.name (to_bytes v) >|=? fun t -> C.project t + + let set t v = C.set t N.name (to_bytes v) >|=? fun t -> C.project t + + let init_set t v = C.init_set t N.name (to_bytes v) >|= fun t -> C.project t + + let set_option t v = + C.set_option t N.name (Option.map to_bytes v) >|= fun t -> C.project t + + let remove t = C.remove t N.name >|= fun t -> C.project t + + let delete t = C.delete t N.name >|=? fun t -> C.project t + + let () = + let open Storage_description in + let description = + if R.ghost then Storage_description.create () else C.description + in + register_value + ~get:get_option + (register_named_subcontext description N.name) + V.encoding +end + +module type INDEX = sig + type t + + val path_length : int + + val to_path : t -> string list -> string list + + val of_path : string list -> t option + + type 'a ipath + + val args : ('a, t, 'a ipath) Storage_description.args +end + +module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t = +struct + type t = I1.t * I2.t + + let path_length = I1.path_length + I2.path_length + + let to_path (x, y) l = I1.to_path x (I2.to_path y l) + + let of_path l = + match Misc.take I1.path_length l with + | None -> + None + | Some (l1, l2) -> ( + match (I1.of_path l1, I2.of_path l2) with + | (Some x, Some y) -> + Some (x, y) + | _ -> + None ) + + type 'a ipath = 'a I1.ipath I2.ipath + + let args = Storage_description.Pair (I1.args, I2.args) +end + +module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : + Data_set_storage with type t = C.t and type elt = I.t = struct + type t = C.t + + type context = t + + type elt = I.t + + let inited = Bytes.of_string "inited" + + let mem s i = C.mem s (I.to_path i []) + + let add s i = C.init_set s (I.to_path i []) inited >|= fun t -> C.project t + + let del s i = C.remove s (I.to_path i []) >|= fun t -> C.project t + + let set s i = function true -> add s i | false -> del s i + + let clear s = C.remove_rec s [] >|= fun t -> C.project t + + let fold s ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 1) then + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir _ -> + Lwt.return acc + | `Key file -> ( + match I.of_path file with + | None -> + assert false + | Some p -> + f p acc )) + else + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir k -> + dig (i - 1) k acc + | `Key _ -> + Lwt.return acc) + in + dig I.path_length [] init + + let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + + let () = + let open Storage_description in + let unpack = unpack I.args in + register_value (* TODO fixme 'elements...' *) + ~get:(fun c -> + let (c, k) = unpack c in + mem c k >>= function true -> return_some true | false -> return_none) + (register_indexed_subcontext + ~list:(fun c -> elements c >|= ok) + C.description + I.args) + Data_encoding.bool +end + +module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) : + Indexed_data_storage + with type t = C.t + and type key = I.t + and type value = V.t = struct + type t = C.t + + type context = t + + type key = I.t + + type value = V.t + + include Make_encoder (V) + + let mem s i = C.mem s (I.to_path i []) + + let get s i = + C.get s (I.to_path i []) + >>=? fun b -> + let key = C.absolute_key s (I.to_path i []) in + Lwt.return (of_bytes ~key b) + + let get_option s i = + C.get_option s (I.to_path i []) + >|= function + | None -> + ok_none + | Some b -> + let key = C.absolute_key s (I.to_path i []) in + of_bytes ~key b >|? fun v -> Some v + + let set s i v = + C.set s (I.to_path i []) (to_bytes v) >|=? fun t -> C.project t + + let init s i v = + C.init s (I.to_path i []) (to_bytes v) >|=? fun t -> C.project t + + let init_set s i v = + C.init_set s (I.to_path i []) (to_bytes v) >|= fun t -> C.project t + + let set_option s i v = + C.set_option s (I.to_path i []) (Option.map to_bytes v) + >|= fun t -> C.project t + + let remove s i = C.remove s (I.to_path i []) >|= fun t -> C.project t + + let delete s i = C.delete s (I.to_path i []) >|=? fun t -> C.project t + + let clear s = C.remove_rec s [] >|= fun t -> C.project t + + let fold_keys s ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 1) then + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir _ -> + Lwt.return acc + | `Key file -> ( + match I.of_path file with + | None -> + assert false + | Some path -> + f path acc )) + else + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir k -> + dig (i - 1) k acc + | `Key _ -> + Lwt.return acc) + in + dig I.path_length [] init + + let fold s ~init ~f = + let f path acc = + get s path + >>= function + | Error _ -> + (* FIXME: silently ignore unparsable data *) + Lwt.return acc + | Ok v -> + f path v acc + in + fold_keys s ~init ~f + + let bindings s = + fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc)) + + let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + + let () = + let open Storage_description in + let unpack = unpack I.args in + register_value + ~get:(fun c -> + let (c, k) = unpack c in + get_option c k) + (register_indexed_subcontext + ~list:(fun c -> keys c >|= ok) + C.description + I.args) + V.encoding +end + +(* Internal-use-only version of {!Make_indexed_carbonated_data_storage} to + expose fold_keys_unaccounted *) +module Make_indexed_carbonated_data_storage_INTERNAL + (C : Raw_context.T) + (I : INDEX) + (V : VALUE) = +struct + type t = C.t + + type context = t + + type key = I.t + + type value = V.t + + include Make_encoder (V) + + let data_key i = I.to_path i [data_name] + + let len_key i = I.to_path i [len_name] + + let consume_mem_gas c key = + C.consume_gas + c + (Storage_costs.read_access ~path_length:(List.length key) ~read_bytes:0) + + let existing_size c i = + C.get_option c (len_key i) + >|= function + | None -> + ok (0, false) + | Some len -> + decode_len_value (len_key i) len >|? fun len -> (len, true) + + let consume_read_gas get c i = + let len_key = len_key i in + get c len_key + >>=? fun len -> + Lwt.return + ( decode_len_value len_key len + >>? fun read_bytes -> + let cost = + Storage_costs.read_access + ~path_length:(List.length len_key) + ~read_bytes + in + C.consume_gas c cost ) + + (* For the future: here, we bill a generic cost for encoding the value + to bytes. It would be cleaner for users of this functor to provide + gas costs for the encoding. *) + let consume_serialize_write_gas set c i v = + let bytes = to_bytes v in + let len = Bytes.length bytes in + C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len) + >>?= fun c -> + let cost = Storage_costs.write_access ~written_bytes:len in + C.consume_gas c cost + >>?= fun c -> + set c (len_key i) (encode_len_value bytes) >|=? fun c -> (c, bytes) + + let consume_remove_gas del c i = + C.consume_gas c (Storage_costs.write_access ~written_bytes:0) + >>?= fun c -> del c (len_key i) + + let mem s i = + let key = data_key i in + consume_mem_gas s key + >>?= fun s -> C.mem s key >|= fun exists -> ok (C.project s, exists) + + let get s i = + consume_read_gas C.get s i + >>=? fun s -> + C.get s (data_key i) + >>=? fun b -> + let key = C.absolute_key s (data_key i) in + Lwt.return (of_bytes ~key b >|? fun v -> (C.project s, v)) + + let get_option s i = + let key = data_key i in + consume_mem_gas s key + >>?= fun s -> + C.mem s key + >>= fun exists -> + if exists then get s i >|=? fun (s, v) -> (s, Some v) + else return (C.project s, None) + + let set s i v = + existing_size s i + >>=? fun (prev_size, _) -> + consume_serialize_write_gas C.set s i v + >>=? fun (s, bytes) -> + C.set s (data_key i) bytes + >|=? fun t -> + let size_diff = Bytes.length bytes - prev_size in + (C.project t, size_diff) + + let init s i v = + consume_serialize_write_gas C.init s i v + >>=? fun (s, bytes) -> + C.init s (data_key i) bytes + >|=? fun t -> + let size = Bytes.length bytes in + (C.project t, size) + + let init_set s i v = + let init_set s i v = C.init_set s i v >|= ok in + existing_size s i + >>=? fun (prev_size, existed) -> + consume_serialize_write_gas init_set s i v + >>=? fun (s, bytes) -> + init_set s (data_key i) bytes + >|=? fun t -> + let size_diff = Bytes.length bytes - prev_size in + (C.project t, size_diff, existed) + + let remove s i = + let remove s i = C.remove s i >|= ok in + existing_size s i + >>=? fun (prev_size, existed) -> + consume_remove_gas remove s i + >>=? fun s -> + remove s (data_key i) >|=? fun t -> (C.project t, prev_size, existed) + + let delete s i = + existing_size s i + >>=? fun (prev_size, _) -> + consume_remove_gas C.delete s i + >>=? fun s -> C.delete s (data_key i) >|=? fun t -> (C.project t, prev_size) + + let set_option s i v = + match v with None -> remove s i | Some v -> init_set s i v + + let fold_keys_unaccounted s ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 0) then + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir _ -> + Lwt.return acc + | `Key file -> ( + match List.rev file with + | last :: _ when Compare.String.(last = len_name) -> + Lwt.return acc + | last :: rest when Compare.String.(last = data_name) -> ( + let file = List.rev rest in + match I.of_path file with + | None -> + assert false + | Some path -> + f path acc ) + | _ -> + assert false )) + else + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir k -> + dig (i - 1) k acc + | `Key _ -> + Lwt.return acc) + in + dig I.path_length [] init + + let keys_unaccounted s = + fold_keys_unaccounted s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + + let () = + let open Storage_description in + let unpack = unpack I.args in + register_value (* TODO export consumed gas ?? *) + ~get:(fun c -> + let (c, k) = unpack c in + get_option c k >|=? fun (_, v) -> v) + (register_indexed_subcontext + ~list:(fun c -> keys_unaccounted c >|= ok) + C.description + I.args) + V.encoding +end + +module Make_indexed_carbonated_data_storage : functor + (C : Raw_context.T) + (I : INDEX) + (V : VALUE) + -> + Non_iterable_indexed_carbonated_data_storage + with type t = C.t + and type key = I.t + and type value = V.t = + Make_indexed_carbonated_data_storage_INTERNAL + +module Make_carbonated_data_set_storage (C : Raw_context.T) (I : INDEX) : + Carbonated_data_set_storage with type t = C.t and type elt = I.t = struct + module V = struct + type t = unit + + let encoding = Data_encoding.unit + end + + module M = Make_indexed_carbonated_data_storage_INTERNAL (C) (I) (V) + + type t = M.t + + type context = t + + type elt = I.t + + let mem = M.mem + + let init s i = M.init s i () + + let del s i = M.remove s i + + let fold_keys_unaccounted = M.fold_keys_unaccounted +end + +module Make_indexed_data_snapshotable_storage + (C : Raw_context.T) + (Snapshot_index : INDEX) + (I : INDEX) + (V : VALUE) : + Indexed_data_snapshotable_storage + with type t = C.t + and type snapshot = Snapshot_index.t + and type key = I.t + and type value = V.t = struct + type snapshot = Snapshot_index.t + + let data_name = ["current"] + + let snapshot_name = ["snapshot"] + + module C_data = + Make_subcontext (Registered) (C) + (struct + let name = data_name + end) + + module C_snapshot = + Make_subcontext (Registered) (C) + (struct + let name = snapshot_name + end) + + include Make_indexed_data_storage (C_data) (I) (V) + module Snapshot = + Make_indexed_data_storage (C_snapshot) (Pair (Snapshot_index) (I)) (V) + + let snapshot_path id = snapshot_name @ Snapshot_index.to_path id [] + + let snapshot_exists s id = C.dir_mem s (snapshot_path id) + + let snapshot s id = + C.copy s ~from:data_name ~to_:(snapshot_path id) >|=? fun t -> C.project t + + let delete_snapshot s id = + C.remove_rec s (snapshot_path id) >|= fun t -> C.project t +end + +module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : + Indexed_raw_context + with type t = C.t + and type key = I.t + and type 'a ipath = 'a I.ipath = struct + type t = C.t + + type context = t + + type key = I.t + + type 'a ipath = 'a I.ipath + + let clear t = C.remove_rec t [] >|= fun t -> C.project t + + let fold_keys t ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 0) then + match I.of_path path with + | None -> + assert false + | Some path -> + f path acc + else + C.fold t path ~init:acc ~f:(fun k acc -> + match k with + | `Dir k -> + dig (i - 1) k acc + | `Key _ -> + Lwt.return acc) + in + dig I.path_length [] init + + let keys t = fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc)) + + let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) + + let remove_rec t k = C.remove_rec t (I.to_path k []) + + let copy t ~from ~to_ = + C.copy t ~from:(I.to_path from []) ~to_:(I.to_path to_ []) + + let description = + Storage_description.register_indexed_subcontext + ~list:(fun c -> keys c >|= ok) + C.description + I.args + + let unpack = Storage_description.unpack I.args + + let pack = Storage_description.pack I.args + + module Raw_context = struct + type t = C.t I.ipath + + type context = t + + let to_key i k = I.to_path i k + + let of_key k = Misc.remove_elem_from_list I.path_length k + + let mem c k = + let (t, i) = unpack c in + C.mem t (to_key i k) + + let dir_mem c k = + let (t, i) = unpack c in + C.dir_mem t (to_key i k) + + let get c k = + let (t, i) = unpack c in + C.get t (to_key i k) + + let get_option c k = + let (t, i) = unpack c in + C.get_option t (to_key i k) + + let init c k v = + let (t, i) = unpack c in + C.init t (to_key i k) v >|=? fun t -> pack t i + + let set c k v = + let (t, i) = unpack c in + C.set t (to_key i k) v >|=? fun t -> pack t i + + let init_set c k v = + let (t, i) = unpack c in + C.init_set t (to_key i k) v >|= fun t -> pack t i + + let set_option c k v = + let (t, i) = unpack c in + C.set_option t (to_key i k) v >|= fun t -> pack t i + + let delete c k = + let (t, i) = unpack c in + C.delete t (to_key i k) >|=? fun t -> pack t i + + let remove c k = + let (t, i) = unpack c in + C.remove t (to_key i k) >|= fun t -> pack t i + + let remove_rec c k = + let (t, i) = unpack c in + C.remove_rec t (to_key i k) >|= fun t -> pack t i + + let copy c ~from ~to_ = + let (t, i) = unpack c in + C.copy t ~from:(to_key i from) ~to_:(to_key i to_) >|=? fun t -> pack t i + + let fold c k ~init ~f = + let (t, i) = unpack c in + C.fold t (to_key i k) ~init ~f:(fun k acc -> f (map_key of_key k) acc) + + let keys c k = + let (t, i) = unpack c in + C.keys t (to_key i k) >|= fun keys -> List.map of_key keys + + let fold_keys c k ~init ~f = + let (t, i) = unpack c in + C.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc) + + let project c = + let (t, _) = unpack c in + C.project t + + let absolute_key c k = + let (t, i) = unpack c in + C.absolute_key t (to_key i k) + + let consume_gas c g = + let (t, i) = unpack c in + C.consume_gas t g >>? fun t -> ok (pack t i) + + let check_enough_gas c g = + let (t, _i) = unpack c in + C.check_enough_gas t g + + let description = description + end + + let resolve t prefix = + let rec loop i prefix = function + | [] when Compare.Int.(i = I.path_length) -> ( + match I.of_path prefix with + | None -> + assert false + | Some path -> + Lwt.return [path] ) + | [] -> + list t prefix + >>= fun prefixes -> + Lwt_list.map_s + (function `Key prefix | `Dir prefix -> loop (i + 1) prefix []) + prefixes + >|= List.flatten + | [d] when Compare.Int.(i = I.path_length - 1) -> + if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ; + list t prefix + >>= fun prefixes -> + Lwt_list.map_s + (function + | `Key prefix | `Dir prefix -> ( + match + Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) + with + | None -> + Lwt.return_nil + | Some _ -> + loop (i + 1) prefix [] )) + prefixes + >|= List.flatten + | "" :: ds -> + list t prefix + >>= fun prefixes -> + Lwt_list.map_s + (function `Key prefix | `Dir prefix -> loop (i + 1) prefix ds) + prefixes + >|= List.flatten + | d :: ds -> ( + if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ; + C.dir_mem t (prefix @ [d]) + >>= function + | true -> loop (i + 1) (prefix @ [d]) ds | false -> Lwt.return_nil ) + in + loop 0 [] prefix + + module Make_set (R : REGISTER) (N : NAME) = struct + type t = C.t + + type context = t + + type elt = I.t + + let inited = Bytes.of_string "inited" + + let mem s i = Raw_context.mem (pack s i) N.name + + let add s i = + Raw_context.init_set (pack s i) N.name inited + >|= fun c -> + let (s, _) = unpack c in + C.project s + + let del s i = + Raw_context.remove (pack s i) N.name + >|= fun c -> + let (s, _) = unpack c in + C.project s + + let set s i = function true -> add s i | false -> del s i + + let clear s = + fold_keys s ~init:s ~f:(fun i s -> + Raw_context.remove (pack s i) N.name + >|= fun c -> + let (s, _) = unpack c in + s) + >|= fun t -> C.project t + + let fold s ~init ~f = + fold_keys s ~init ~f:(fun i acc -> + mem s i >>= function true -> f i acc | false -> Lwt.return acc) + + let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + + let () = + let open Storage_description in + let unpack = unpack I.args in + let description = + if R.ghost then Storage_description.create () + else Raw_context.description + in + register_value + ~get:(fun c -> + let (c, k) = unpack c in + mem c k + >>= function true -> return_some true | false -> return_none) + (register_named_subcontext description N.name) + Data_encoding.bool + end + + module Make_map (N : NAME) (V : VALUE) = struct + type t = C.t + + type context = t + + type key = I.t + + type value = V.t + + include Make_encoder (V) + + let mem s i = Raw_context.mem (pack s i) N.name + + let get s i = + Raw_context.get (pack s i) N.name + >>=? fun b -> + let key = Raw_context.absolute_key (pack s i) N.name in + Lwt.return (of_bytes ~key b) + + let get_option s i = + Raw_context.get_option (pack s i) N.name + >|= function + | None -> + ok_none + | Some b -> + let key = Raw_context.absolute_key (pack s i) N.name in + of_bytes ~key b >|? fun v -> Some v + + let set s i v = + Raw_context.set (pack s i) N.name (to_bytes v) + >|=? fun c -> + let (s, _) = unpack c in + C.project s + + let init s i v = + Raw_context.init (pack s i) N.name (to_bytes v) + >|=? fun c -> + let (s, _) = unpack c in + C.project s + + let init_set s i v = + Raw_context.init_set (pack s i) N.name (to_bytes v) + >|= fun c -> + let (s, _) = unpack c in + C.project s + + let set_option s i v = + Raw_context.set_option (pack s i) N.name (Option.map to_bytes v) + >|= fun c -> + let (s, _) = unpack c in + C.project s + + let remove s i = + Raw_context.remove (pack s i) N.name + >|= fun c -> + let (s, _) = unpack c in + C.project s + + let delete s i = + Raw_context.delete (pack s i) N.name + >|=? fun c -> + let (s, _) = unpack c in + C.project s + + let clear s = + fold_keys s ~init:s ~f:(fun i s -> + Raw_context.remove (pack s i) N.name + >|= fun c -> + let (s, _) = unpack c in + s) + >|= fun t -> C.project t + + let fold s ~init ~f = + fold_keys s ~init ~f:(fun i acc -> + get s i >>= function Error _ -> Lwt.return acc | Ok v -> f i v acc) + + let bindings s = + fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc)) + + let fold_keys s ~init ~f = + fold_keys s ~init ~f:(fun i acc -> + mem s i >>= function false -> Lwt.return acc | true -> f i acc) + + let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + + let () = + let open Storage_description in + let unpack = unpack I.args in + register_value + ~get:(fun c -> + let (c, k) = unpack c in + get_option c k) + (register_named_subcontext Raw_context.description N.name) + V.encoding + end + + module Make_carbonated_map (N : NAME) (V : VALUE) = struct + type t = C.t + + type context = t + + type key = I.t + + type value = V.t + + include Make_encoder (V) + + let len_name = len_name :: N.name + + let data_name = data_name :: N.name + + let path_length = List.length N.name + 1 + + let consume_mem_gas c = + Raw_context.consume_gas + c + (Storage_costs.read_access ~path_length ~read_bytes:0) + + let existing_size c = + Raw_context.get_option c len_name + >|= function + | None -> + ok (0, false) + | Some len -> + decode_len_value len_name len >|? fun len -> (len, true) + + let consume_read_gas get c = + get c len_name + >>=? fun len -> + Lwt.return + ( decode_len_value len_name len + >>? fun read_bytes -> + Raw_context.consume_gas + c + (Storage_costs.read_access ~path_length ~read_bytes) ) + + let consume_write_gas set c v = + let bytes = to_bytes v in + let len = Bytes.length bytes in + Raw_context.consume_gas c (Storage_costs.write_access ~written_bytes:len) + >>?= fun c -> + set c len_name (encode_len_value bytes) >|=? fun c -> (c, bytes) + + let consume_remove_gas del c = + Raw_context.consume_gas c (Storage_costs.write_access ~written_bytes:0) + >>?= fun c -> del c len_name + + let mem s i = + consume_mem_gas (pack s i) + >>?= fun c -> + Raw_context.mem c data_name >|= fun res -> ok (Raw_context.project c, res) + + let get s i = + consume_read_gas Raw_context.get (pack s i) + >>=? fun c -> + Raw_context.get c data_name + >>=? fun b -> + let key = Raw_context.absolute_key c data_name in + Lwt.return (of_bytes ~key b >|? fun v -> (Raw_context.project c, v)) + + let get_option s i = + consume_mem_gas (pack s i) + >>?= fun c -> + let (s, _) = unpack c in + Raw_context.mem (pack s i) data_name + >>= fun exists -> + if exists then get s i >|=? fun (s, v) -> (s, Some v) + else return (C.project s, None) + + let set s i v = + existing_size (pack s i) + >>=? fun (prev_size, _) -> + consume_write_gas Raw_context.set (pack s i) v + >>=? fun (c, bytes) -> + Raw_context.set c data_name bytes + >|=? fun c -> + let size_diff = Bytes.length bytes - prev_size in + (Raw_context.project c, size_diff) + + let init s i v = + consume_write_gas Raw_context.init (pack s i) v + >>=? fun (c, bytes) -> + Raw_context.init c data_name bytes + >|=? fun c -> + let size = Bytes.length bytes in + (Raw_context.project c, size) + + let init_set s i v = + let init_set c k v = Raw_context.init_set c k v >|= ok in + existing_size (pack s i) + >>=? fun (prev_size, existed) -> + consume_write_gas init_set (pack s i) v + >>=? fun (c, bytes) -> + init_set c data_name bytes + >|=? fun c -> + let size_diff = Bytes.length bytes - prev_size in + (Raw_context.project c, size_diff, existed) + + let remove s i = + let remove c k = Raw_context.remove c k >|= ok in + existing_size (pack s i) + >>=? fun (prev_size, existed) -> + consume_remove_gas remove (pack s i) + >>=? fun c -> + remove c data_name + >|=? fun c -> (Raw_context.project c, prev_size, existed) + + let delete s i = + existing_size (pack s i) + >>=? fun (prev_size, _) -> + consume_remove_gas Raw_context.delete (pack s i) + >>=? fun c -> + Raw_context.delete c data_name + >|=? fun c -> (Raw_context.project c, prev_size) + + let set_option s i v = + match v with None -> remove s i | Some v -> init_set s i v + + let () = + let open Storage_description in + let unpack = unpack I.args in + register_value + ~get:(fun c -> + let (c, k) = unpack c in + get_option c k >|=? fun (_, v) -> v) + (register_named_subcontext Raw_context.description N.name) + V.encoding + end +end + +module type WRAPPER = sig + type t + + type key + + val wrap : t -> key + + val unwrap : key -> t option +end + +module Wrap_indexed_data_storage + (C : Indexed_data_storage) + (K : WRAPPER with type key := C.key) = +struct + type t = C.t + + type context = C.t + + type key = K.t + + type value = C.value + + let mem ctxt k = C.mem ctxt (K.wrap k) + + let get ctxt k = C.get ctxt (K.wrap k) + + let get_option ctxt k = C.get_option ctxt (K.wrap k) + + let set ctxt k v = C.set ctxt (K.wrap k) v + + let init ctxt k v = C.init ctxt (K.wrap k) v + + let init_set ctxt k v = C.init_set ctxt (K.wrap k) v + + let set_option ctxt k v = C.set_option ctxt (K.wrap k) v + + let delete ctxt k = C.delete ctxt (K.wrap k) + + let remove ctxt k = C.remove ctxt (K.wrap k) + + let clear ctxt = C.clear ctxt + + let fold ctxt ~init ~f = + C.fold ctxt ~init ~f:(fun k v acc -> + match K.unwrap k with None -> Lwt.return acc | Some k -> f k v acc) + + let bindings s = + fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc)) + + let fold_keys s ~init ~f = + C.fold_keys s ~init ~f:(fun k acc -> + match K.unwrap k with None -> Lwt.return acc | Some k -> f k acc) + + let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) +end diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/storage_functors.mli b/src/proto_008_PtEdo2Zk/lib_protocol/storage_functors.mli new file mode 100644 index 0000000000000000000000000000000000000000..31c8b1aa5e0f40d7f42603d8ae043713ca5c4bc4 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/storage_functors.mli @@ -0,0 +1,114 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tezos Protocol Implementation - Typed storage builders. *) + +open Storage_sigs + +module Registered : REGISTER + +module Ghost : REGISTER + +module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : + Raw_context.T with type t = C.t + +module Make_single_data_storage + (R : REGISTER) + (C : Raw_context.T) + (N : NAME) + (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t + +module type INDEX = sig + type t + + val path_length : int + + val to_path : t -> string list -> string list + + val of_path : string list -> t option + + type 'a ipath + + val args : ('a, t, 'a ipath) Storage_description.args +end + +module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t + +module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : + Data_set_storage with type t = C.t and type elt = I.t + +module Make_carbonated_data_set_storage (C : Raw_context.T) (I : INDEX) : + Carbonated_data_set_storage with type t = C.t and type elt = I.t + +module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) : + Indexed_data_storage + with type t = C.t + and type key = I.t + and type value = V.t + +module Make_indexed_carbonated_data_storage + (C : Raw_context.T) + (I : INDEX) + (V : VALUE) : + Non_iterable_indexed_carbonated_data_storage + with type t = C.t + and type key = I.t + and type value = V.t + +module Make_indexed_data_snapshotable_storage + (C : Raw_context.T) + (Snapshot : INDEX) + (I : INDEX) + (V : VALUE) : + Indexed_data_snapshotable_storage + with type t = C.t + and type snapshot = Snapshot.t + and type key = I.t + and type value = V.t + +module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : + Indexed_raw_context + with type t = C.t + and type key = I.t + and type 'a ipath = 'a I.ipath + +module type WRAPPER = sig + type t + + type key + + val wrap : t -> key + + val unwrap : key -> t option +end + +module Wrap_indexed_data_storage + (C : Indexed_data_storage) + (K : WRAPPER with type key := C.key) : + Indexed_data_storage + with type t = C.t + and type key = K.t + and type value = C.value diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/storage_sigs.ml b/src/proto_008_PtEdo2Zk/lib_protocol/storage_sigs.ml new file mode 100644 index 0000000000000000000000000000000000000000..893a347f267983007b2fbd5f6149fae169b83f25 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/storage_sigs.ml @@ -0,0 +1,441 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019-2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** {1 Entity Accessor Signatures} *) + +(** The generic signature of a single data accessor (a single value + bound to a specific key in the hierarchical (key x value) + database). *) +module type Single_data_storage = sig + type t + + type context = t + + (** The type of the value *) + type value + + (** Tells if the data is already defined *) + val mem : context -> bool Lwt.t + + (** Retrieve the value from the storage bucket ; returns a + {!Storage_error} if the key is not set or if the deserialisation + fails *) + val get : context -> value tzresult Lwt.t + + (** Retrieves the value from the storage bucket ; returns [None] if + the data is not initialized, or {!Storage_helpers.Storage_error} + if the deserialisation fails *) + val get_option : context -> value option tzresult Lwt.t + + (** Allocates the storage bucket and initializes it ; returns a + {!Storage_error Existing_key} if the bucket exists *) + val init : context -> value -> Raw_context.t tzresult Lwt.t + + (** Updates the content of the bucket ; returns a {!Storage_Error + Missing_key} if the value does not exists *) + val set : context -> value -> Raw_context.t tzresult Lwt.t + + (** Allocates the data and initializes it with a value ; just + updates it if the bucket exists *) + val init_set : context -> value -> Raw_context.t Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + value is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. *) + val set_option : context -> value option -> Raw_context.t Lwt.t + + (** Delete the storage bucket ; returns a {!Storage_error + Missing_key} if the bucket does not exists *) + val delete : context -> Raw_context.t tzresult Lwt.t + + (** Removes the storage bucket and its contents ; does nothing if + the bucket does not exists *) + val remove : context -> Raw_context.t Lwt.t +end + +(** Variant of {!Single_data_storage} with gas accounting. *) +module type Single_carbonated_data_storage = sig + type t + + type context = t + + (** The type of the value *) + type value + + (** Tells if the data is already defined. + Consumes [Gas_repr.read_bytes_cost Z.zero]. *) + val mem : context -> (Raw_context.t * bool) tzresult Lwt.t + + (** Retrieve the value from the storage bucket ; returns a + {!Storage_error} if the key is not set or if the deserialisation + fails. + Consumes [Gas_repr.read_bytes_cost ]. *) + val get : context -> (Raw_context.t * value) tzresult Lwt.t + + (** Retrieves the value from the storage bucket ; returns [None] if + the data is not initialized, or {!Storage_helpers.Storage_error} + if the deserialisation fails. + Consumes [Gas_repr.read_bytes_cost ] if present + or [Gas_repr.read_bytes_cost Z.zero]. *) + val get_option : context -> (Raw_context.t * value option) tzresult Lwt.t + + (** Allocates the storage bucket and initializes it ; returns a + {!Storage_error Missing_key} if the bucket exists. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the size. *) + val init : context -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** Updates the content of the bucket ; returns a {!Storage_Error + Existing_key} if the value does not exists. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the difference from the old to the new size. *) + val set : context -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** Allocates the data and initializes it with a value ; just + updates it if the bucket exists. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val init_set : + context -> value -> (Raw_context.t * int * bool) tzresult Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + value is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. + Consumes the same gas cost as either {!remove} or {!init_set}. + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val set_option : + context -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t + + (** Delete the storage bucket ; returns a {!Storage_error + Missing_key} if the bucket does not exists. + Consumes [Gas_repr.write_bytes_cost Z.zero]. + Returns the freed size. *) + val delete : context -> (Raw_context.t * int) tzresult Lwt.t + + (** Removes the storage bucket and its contents ; does nothing if + the bucket does not exists. + Consumes [Gas_repr.write_bytes_cost Z.zero]. + Returns the freed size, and a boolean + indicating if a value was already associated to this key. *) + val remove : context -> (Raw_context.t * int * bool) tzresult Lwt.t +end + +(** Restricted version of {!Indexed_data_storage} w/o iterators. *) +module type Non_iterable_indexed_data_storage = sig + type t + + type context = t + + (** An abstract type for keys *) + type key + + (** The type of values *) + type value + + (** Tells if a given key is already bound to a storage bucket *) + val mem : context -> key -> bool Lwt.t + + (** Retrieve a value from the storage bucket at a given key ; + returns {!Storage_error Missing_key} if the key is not set ; + returns {!Storage_error Corrupted_data} if the deserialisation + fails. *) + val get : context -> key -> value tzresult Lwt.t + + (** Retrieve a value from the storage bucket at a given key ; + returns [None] if the value is not set ; returns {!Storage_error + Corrupted_data} if the deserialisation fails. *) + val get_option : context -> key -> value option tzresult Lwt.t + + (** Updates the content of a bucket ; returns A {!Storage_Error + Missing_key} if the value does not exists. *) + val set : context -> key -> value -> Raw_context.t tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error Existing_key} if the bucket exists. *) + val init : context -> key -> value -> Raw_context.t tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it + with a value ; just updates it if the bucket exists. *) + val init_set : context -> key -> value -> Raw_context.t Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + value is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. *) + val set_option : context -> key -> value option -> Raw_context.t Lwt.t + + (** Delete a storage bucket and its contents ; returns a + {!Storage_error Missing_key} if the bucket does not exists. *) + val delete : context -> key -> Raw_context.t tzresult Lwt.t + + (** Removes a storage bucket and its contents ; does nothing if the + bucket does not exists. *) + val remove : context -> key -> Raw_context.t Lwt.t +end + +(** Variant of {!Non_iterable_indexed_data_storage} with gas accounting. *) +module type Non_iterable_indexed_carbonated_data_storage = sig + type t + + type context = t + + (** An abstract type for keys *) + type key + + (** The type of values *) + type value + + (** Tells if a given key is already bound to a storage bucket. + Consumes [Gas_repr.read_bytes_cost Z.zero]. *) + val mem : context -> key -> (Raw_context.t * bool) tzresult Lwt.t + + (** Retrieve a value from the storage bucket at a given key ; + returns {!Storage_error Missing_key} if the key is not set ; + returns {!Storage_error Corrupted_data} if the deserialisation + fails. + Consumes [Gas_repr.read_bytes_cost ]. *) + val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t + + (** Retrieve a value from the storage bucket at a given key ; + returns [None] if the value is not set ; returns {!Storage_error + Corrupted_data} if the deserialisation fails. + Consumes [Gas_repr.read_bytes_cost ] if present + or [Gas_repr.read_bytes_cost Z.zero]. *) + val get_option : + context -> key -> (Raw_context.t * value option) tzresult Lwt.t + + (** Updates the content of a bucket ; returns A {!Storage_Error + Missing_key} if the value does not exists. + Consumes serialization cost. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the difference from the old to the new size. *) + val set : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error Existing_key} if the bucket exists. + Consumes serialization cost. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the size. *) + val init : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** Allocates a storage bucket at the given key and initializes it + with a value ; just updates it if the bucket exists. + Consumes serialization cost. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val init_set : + context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + value is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. + Consumes serialization cost. + Consumes the same gas cost as either {!remove} or {!init_set}. + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val set_option : + context -> + key -> + value option -> + (Raw_context.t * int * bool) tzresult Lwt.t + + (** Delete a storage bucket and its contents ; returns a + {!Storage_error Missing_key} if the bucket does not exists. + Consumes [Gas_repr.write_bytes_cost Z.zero]. + Returns the freed size. *) + val delete : context -> key -> (Raw_context.t * int) tzresult Lwt.t + + (** Removes a storage bucket and its contents ; does nothing if the + bucket does not exists. + Consumes [Gas_repr.write_bytes_cost Z.zero]. + Returns the freed size, and a boolean + indicating if a value was already associated to this key. *) + val remove : context -> key -> (Raw_context.t * int * bool) tzresult Lwt.t +end + +(** The generic signature of indexed data accessors (a set of values + of the same type indexed by keys of the same form in the + hierarchical (key x value) database). *) +module type Indexed_data_storage = sig + include Non_iterable_indexed_data_storage + + (** Empties all the keys and associated data. *) + val clear : context -> Raw_context.t Lwt.t + + (** Lists all the keys. *) + val keys : context -> key list Lwt.t + + (** Lists all the keys and associated data. *) + val bindings : context -> (key * value) list Lwt.t + + (** Iterates over all the keys and associated data. *) + val fold : + context -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + (** Iterate over all the keys. *) + val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t +end + +module type Indexed_data_snapshotable_storage = sig + type snapshot + + type key + + include Indexed_data_storage with type key := key + + module Snapshot : + Indexed_data_storage + with type key = snapshot * key + and type value = value + and type t = t + + val snapshot_exists : context -> snapshot -> bool Lwt.t + + val snapshot : context -> snapshot -> Raw_context.t tzresult Lwt.t + + val delete_snapshot : context -> snapshot -> Raw_context.t Lwt.t +end + +(** The generic signature of a data set accessor (a set of values + bound to a specific key prefix in the hierarchical (key x value) + database). *) +module type Data_set_storage = sig + type t + + type context = t + + (** The type of elements. *) + type elt + + (** Tells if a elt is a member of the set *) + val mem : context -> elt -> bool Lwt.t + + (** Adds a elt is a member of the set *) + val add : context -> elt -> Raw_context.t Lwt.t + + (** Removes a elt of the set ; does nothing if not a member *) + val del : context -> elt -> Raw_context.t Lwt.t + + (** Adds/Removes a elt of the set *) + val set : context -> elt -> bool -> Raw_context.t Lwt.t + + (** Returns the elements of the set, deserialized in a list in no + particular order. *) + val elements : context -> elt list Lwt.t + + (** Iterates over the elements of the set. *) + val fold : context -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + (** Removes all elements in the set *) + val clear : context -> Raw_context.t Lwt.t +end + +(** Variant of {!Data_set_storage} with gas accounting. *) +module type Carbonated_data_set_storage = sig + type t + + type context = t + + (** The type of elements. *) + type elt + + (** Tells whether an elt is a member of the set. + Consumes [Gas_repr.read_bytes_cost Z.zero] *) + val mem : context -> elt -> (Raw_context.t * bool) tzresult Lwt.t + + (** Adds an elt as a member of the set. + Consumes [Gas_repr.write_bytes_cost ]. + Returns the difference from the old (maybe 0) to the new size. *) + val init : context -> elt -> (Raw_context.t * int) tzresult Lwt.t + + (** Removes an elt from the set ; does nothing if not a member. + Consumes [Gas_repr.write_bytes_cost Z.zero]. + Returns the freed size, and a boolean + indicating if a value was already associated to this key. *) + val del : context -> elt -> (Raw_context.t * int * bool) tzresult Lwt.t + + val fold_keys_unaccounted : + context -> init:'acc -> f:(elt -> 'acc -> 'acc Lwt.t) -> 'acc Lwt.t +end + +module type NAME = sig + val name : Raw_context.key +end + +module type VALUE = sig + type t + + val encoding : t Data_encoding.t +end + +module type REGISTER = sig + val ghost : bool +end + +module type Indexed_raw_context = sig + type t + + type context = t + + type key + + type 'a ipath + + val clear : context -> Raw_context.t Lwt.t + + val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + val keys : context -> key list Lwt.t + + val resolve : context -> string list -> key list Lwt.t + + val remove_rec : context -> key -> context Lwt.t + + val copy : context -> from:key -> to_:key -> context tzresult Lwt.t + + module Make_set (R : REGISTER) (N : NAME) : + Data_set_storage with type t = t and type elt = key + + module Make_map (N : NAME) (V : VALUE) : + Indexed_data_storage + with type t = t + and type key = key + and type value = V.t + + module Make_carbonated_map (N : NAME) (V : VALUE) : + Non_iterable_indexed_carbonated_data_storage + with type t = t + and type key = key + and type value = V.t + + module Raw_context : Raw_context.T with type t = t ipath +end diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/test.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/test.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/.ocamlformat b/src/proto_008_PtEdo2Zk/lib_protocol/test/.ocamlformat similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/.ocamlformat rename to src/proto_008_PtEdo2Zk/lib_protocol/test/.ocamlformat diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/activation.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/activation.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/activation.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/activation.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/baking.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/baking.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/baking.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/baking.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/combined_operations.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/combined_operations.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/combined_operations.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/combined_operations.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/contracts/big_interpreter_stack.tz b/src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/big_interpreter_stack.tz similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/contracts/big_interpreter_stack.tz rename to src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/big_interpreter_stack.tz diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_contract.tz b/src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_contract.tz similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_contract.tz rename to src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_contract.tz diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_contract_double.tz b/src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_contract_double.tz similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_contract_double.tz rename to src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_contract_double.tz diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_contract_drop.tz b/src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_contract_drop.tz similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_contract_drop.tz rename to src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_contract_drop.tz diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_contract_send.tz b/src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_contract_send.tz similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_contract_send.tz rename to src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_contract_send.tz diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_contract_state_as_arg.tz b/src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_contract_state_as_arg.tz similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_contract_state_as_arg.tz rename to src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_contract_state_as_arg.tz diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_push_sapling_state.tz b/src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_push_sapling_state.tz similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_push_sapling_state.tz rename to src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_push_sapling_state.tz diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_use_existing_state.tz b/src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_use_existing_state.tz similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/contracts/sapling_use_existing_state.tz rename to src/proto_008_PtEdo2Zk/lib_protocol/test/contracts/sapling_use_existing_state.tz diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/delegation.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/delegation.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/delegation.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/delegation.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/double_baking.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/double_baking.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/double_baking.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/double_baking.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/double_endorsement.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/double_endorsement.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/double_endorsement.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/double_endorsement.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/dune b/src/proto_008_PtEdo2Zk/lib_protocol/test/dune similarity index 56% rename from src/proto_008_PtEdoTez/lib_protocol/test/dune rename to src/proto_008_PtEdo2Zk/lib_protocol/test/dune index a538423f94f89baa56b6ccbbb805a147dc2db9c2..c533843b5724d7ac59fc35c67265b0bfb35a3fbd 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/dune +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/dune @@ -4,48 +4,48 @@ tezos-micheline tezos-protocol-environment alcotest-lwt - tezos-008-PtEdoTez-test-helpers + tezos-008-PtEdo2Zk-test-helpers tezos-stdlib-unix tezos-client-base - tezos-protocol-008-PtEdoTez-parameters + tezos-protocol-008-PtEdo2Zk-parameters tezos-test-services - sapling) + tezos-sapling) (flags (:standard -open Tezos_base__TzPervasives -open Tezos_micheline - -open Tezos_client_008_PtEdoTez - -open Tezos_protocol_008_PtEdoTez - -open Tezos_protocol_environment_008_PtEdoTez - -open Tezos_008_PtEdoTez_test_helpers + -open Tezos_client_008_PtEdo2Zk + -open Tezos_protocol_008_PtEdo2Zk + -open Tezos_protocol_environment_008_PtEdo2Zk + -open Tezos_008_PtEdo2Zk_test_helpers -open Tezos_test_services))) (rule (alias buildtest) - (package tezos-protocol-008-PtEdoTez-tests) + (package tezos-protocol-008-PtEdo2Zk-tests) (deps main.exe) (action (progn))) (rule - (copy %{lib:tezos-protocol-008-PtEdoTez-parameters:test-parameters.json} + (copy %{lib:tezos-protocol-008-PtEdo2Zk-parameters:test-parameters.json} protocol_parameters.json)) ; runs only the `Quick tests (rule - (alias runtest_proto_008_PtEdoTez) + (alias runtest_proto_008_PtEdo2Zk) (deps (glob_files contracts/*)) - (package tezos-protocol-008-PtEdoTez-tests) + (package tezos-protocol-008-PtEdo2Zk-tests) (action (run %{exe:main.exe} -v -q))) ; runs both `Quick and `Slow tests (rule (alias runtest_slow) (deps (glob_files contracts/*)) - (package tezos-protocol-008-PtEdoTez-tests) + (package tezos-protocol-008-PtEdo2Zk-tests) (action (run %{exe:main.exe} -v))) (rule (alias runtest) - (package tezos-protocol-008-PtEdoTez-tests) - (deps (alias runtest_proto_008_PtEdoTez)) + (package tezos-protocol-008-PtEdo2Zk-tests) + (deps (alias runtest_proto_008_PtEdo2Zk)) (action (progn))) (rule diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/endorsement.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/endorsement.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/endorsement.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/endorsement.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/fixed_point.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/fixed_point.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/fixed_point.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/fixed_point.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/gas_costs.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/gas_costs.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/gas_costs.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/gas_costs.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/gas_properties.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/gas_properties.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/gas_properties.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/gas_properties.ml diff --git a/src/proto_alpha/lib_mempool/.ocamlformat b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/.ocamlformat similarity index 100% rename from src/proto_alpha/lib_mempool/.ocamlformat rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/.ocamlformat diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/account.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/account.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/account.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/account.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/account.mli b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/account.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/account.mli rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/account.mli diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/assert.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/assert.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/assert.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/assert.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/block.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/block.ml similarity index 98% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/block.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/block.ml index c43e57530f86036596ce6ef6c50e8fffb6072bb5..a48ebea84e019376ef19d73602c6ebce48955485 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/block.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/block.ml @@ -245,7 +245,7 @@ let check_constants_consistency constants = let initial_context ?(with_commitments = false) constants header initial_accounts = - let open Tezos_protocol_008_PtEdoTez_parameters in + let open Tezos_protocol_008_PtEdo2Zk_parameters in let bootstrap_accounts = List.map (fun (Account.{pk; pkh; _}, amount) -> @@ -284,7 +284,7 @@ let genesis_with_parameters parameters = ~operations_hash:Operation_list_list_hash.zero in let contents = Forge.make_contents ~priority:0 ~seed_nonce_hash:None () in - let open Tezos_protocol_008_PtEdoTez_parameters in + let open Tezos_protocol_008_PtEdo2Zk_parameters in let json = Default_parameters.json_of_parameters parameters in let proto_params = Data_encoding.Binary.to_bytes_exn Data_encoding.json json @@ -309,7 +309,7 @@ let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers ?min_proposal_quorum (initial_accounts : (Account.t * Tez_repr.t) list) = if initial_accounts = [] then Stdlib.failwith "Must have one account with a roll to bake" ; - let open Tezos_protocol_008_PtEdoTez_parameters in + let open Tezos_protocol_008_PtEdo2Zk_parameters in let constants = Default_parameters.constants_test in let endorsers_per_block = Option.value ~default:constants.endorsers_per_block endorsers_per_block diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/block.mli b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/block.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/block.mli rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/block.mli diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/context.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/context.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.mli b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/context.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.mli rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/context.mli diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/dune b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/dune similarity index 54% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/dune rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/dune index 2434f1db83651a25e0e9dfe41c5b3e667c586bbc..5fc6c071e9ae47b143f7b9b7d0b13e51b845ce2d 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/dune +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/dune @@ -1,20 +1,20 @@ (library - (name tezos_008_PtEdoTez_test_helpers) - (public_name tezos-008-PtEdoTez-test-helpers) + (name tezos_008_PtEdo2Zk_test_helpers) + (public_name tezos-008-PtEdo2Zk-test-helpers) (libraries alcotest-lwt tezos-base tezos-stdlib-unix tezos-shell-services tezos-protocol-environment - tezos-protocol-008-PtEdoTez - tezos-protocol-008-PtEdoTez-parameters - tezos-client-008-PtEdoTez) + tezos-protocol-008-PtEdo2Zk + tezos-protocol-008-PtEdo2Zk-parameters + tezos-client-008-PtEdo2Zk) (flags (:standard -open Tezos_base__TzPervasives -open Tezos_micheline -open Tezos_stdlib_unix - -open Tezos_protocol_008_PtEdoTez - -open Tezos_client_008_PtEdoTez - -open Tezos_protocol_environment_008_PtEdoTez + -open Tezos_protocol_008_PtEdo2Zk + -open Tezos_client_008_PtEdo2Zk + -open Tezos_protocol_environment_008_PtEdo2Zk -open Tezos_shell_services))) (rule diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/dune-project b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/dune-project similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/dune-project rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/dune-project diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/expr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/expr.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/expr.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/expr.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/incremental.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/incremental.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/incremental.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/incremental.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/incremental.mli b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/incremental.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/incremental.mli rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/incremental.mli diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/nonce.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/nonce.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/nonce.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/nonce.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/nonce.mli b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/nonce.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/nonce.mli rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/nonce.mli diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/op.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/op.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/op.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/op.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/op.mli b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/op.mli similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/op.mli rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/op.mli diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/rewards.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/rewards.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/rewards.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/rewards.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/sapling_helpers.ml similarity index 85% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/sapling_helpers.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/sapling_helpers.ml index b26e1de737d9ea70b49448a289061db69eca816f..c7def6e32fcd0a3092edeabafbac7cb95d2432af 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/sapling_helpers.ml @@ -68,15 +68,16 @@ module Common = struct Data_encoding.Binary.(of_bytes_exn encoding bytes) type wallet = { - sk : Sapling.Core.Wallet.Spending_key.t; - vk : Sapling.Core.Wallet.Viewing_key.t; + sk : Tezos_sapling.Core.Wallet.Spending_key.t; + vk : Tezos_sapling.Core.Wallet.Viewing_key.t; } let wallet_gen () = let sk = - Sapling.Core.Wallet.Spending_key.of_seed (Tezos_crypto.Hacl.Rand.gen 32) + Tezos_sapling.Core.Wallet.Spending_key.of_seed + (Tezos_crypto.Hacl.Rand.gen 32) in - let vk = Sapling.Core.Wallet.Viewing_key.of_sk sk in + let vk = Tezos_sapling.Core.Wallet.Viewing_key.of_sk sk in {sk; vk} let gen_addr n vk = @@ -84,31 +85,33 @@ module Common = struct if Compare.Int.( <= ) n 0 then res else let (new_index, new_addr) = - Sapling.Core.Client.Viewing_key.new_address vk index + Tezos_sapling.Core.Client.Viewing_key.new_address vk index in aux (n - 1) new_index (new_addr :: res) in - aux n Sapling.Core.Client.Viewing_key.default_index [] + aux n Tezos_sapling.Core.Client.Viewing_key.default_index [] let gen_nf () = let {vk; _} = wallet_gen () in let addr = - snd @@ Sapling.Core.Wallet.Viewing_key.(new_address vk default_index) + snd + @@ Tezos_sapling.Core.Wallet.Viewing_key.(new_address vk default_index) in let amount = 10L in - let rcm = Sapling.Core.Client.Rcm.random () in + let rcm = Tezos_sapling.Core.Client.Rcm.random () in let position = 10L in - Sapling.Core.Client.Nullifier.compute addr vk ~amount rcm ~position + Tezos_sapling.Core.Client.Nullifier.compute addr vk ~amount rcm ~position |> TzOption.unopt_assert ~loc:__POS__ let gen_cm_cipher ~memo_size () = - let open Sapling.Core.Client in + let open Tezos_sapling.Core.Client in let {vk; _} = wallet_gen () in let addr = - snd @@ Sapling.Core.Wallet.Viewing_key.(new_address vk default_index) + snd + @@ Tezos_sapling.Core.Wallet.Viewing_key.(new_address vk default_index) in let amount = 10L in - let rcm = Sapling.Core.Client.Rcm.random () in + let rcm = Tezos_sapling.Core.Client.Rcm.random () in let cm = Commitment.compute addr ~amount rcm |> TzOption.unopt_assert ~loc:__POS__ in @@ -132,13 +135,13 @@ module Common = struct let client_state_of_diff ~memo_size (root, diff) = let open Alpha_context.Sapling in let cs = - Sapling.Storage.add - (Sapling.Storage.empty ~memo_size) + Tezos_sapling.Storage.add + (Tezos_sapling.Storage.empty ~memo_size) diff.commitments_and_ciphertexts in - assert (Sapling.Storage.get_root cs = root) ; + assert (Tezos_sapling.Storage.get_root cs = root) ; List.fold_left - (fun s nf -> Sapling.Storage.add_nullifier s nf) + (fun s nf -> Tezos_sapling.Storage.add_nullifier s nf) cs diff.nullifiers end @@ -231,29 +234,32 @@ module Alpha_context_helpers = struct >|=? fun ctx -> Some (ctx, id) let transfer_inputs_outputs w cs is = - (* Sapling.Storage.size cs *) + (* Tezos_sapling.Storage.size cs *) (* |> fun (a, b) -> *) (* Printf.printf "%Ld %Ld" a b ; *) let inputs = List.map (fun i -> - Sapling.Forge.Input.get cs (Int64.of_int i) w.vk + Tezos_sapling.Forge.Input.get cs (Int64.of_int i) w.vk |> Option.unopt_assert ~loc:__POS__ |> snd) is in let addr = - snd @@ Sapling.Core.Wallet.Viewing_key.(new_address w.vk default_index) + snd + @@ Tezos_sapling.Core.Wallet.Viewing_key.(new_address w.vk default_index) + in + let memo_size = Tezos_sapling.Storage.get_memo_size cs in + let o = + Tezos_sapling.Forge.make_output addr 1000000L (Bytes.create memo_size) in - let memo_size = Sapling.Storage.get_memo_size cs in - let o = Sapling.Forge.make_output addr 1000000L (Bytes.create memo_size) in (inputs, [o]) let transfer w cs is = let anti_replay = "anti-replay" in let (ins, outs) = transfer_inputs_outputs w cs is in (* change the wallet of this last line *) - Sapling.Forge.forge_transaction ins outs w.sk anti_replay cs + Tezos_sapling.Forge.forge_transaction ins outs w.sk anti_replay cs let client_state_alpha ctx id = Alpha_context.Sapling.get_diff ctx id () @@ -345,21 +351,31 @@ module Interpreter_helpers = struct (dst, b, anti_replay) let hex_shield ~memo_size wallet anti_replay = - let ps = Sapling.Storage.empty ~memo_size in + let ps = Tezos_sapling.Storage.empty ~memo_size in let addr = snd - @@ Sapling.Core.Wallet.Viewing_key.(new_address wallet.vk default_index) + @@ Tezos_sapling.Core.Wallet.Viewing_key.( + new_address wallet.vk default_index) + in + let output = + Tezos_sapling.Forge.make_output addr 15L (Bytes.create memo_size) in - let output = Sapling.Forge.make_output addr 15L (Bytes.create memo_size) in let pt = - Sapling.Forge.forge_transaction [] [output] wallet.sk anti_replay ps + Tezos_sapling.Forge.forge_transaction + [] + [output] + wallet.sk + anti_replay + ps in let hex_string = "0x" ^ Hex.show (Hex.of_bytes Data_encoding.Binary.( - to_bytes_exn Sapling.Core.Client.UTXO.transaction_encoding pt)) + to_bytes_exn + Tezos_sapling.Core.Client.UTXO.transaction_encoding + pt)) in hex_string @@ -393,23 +409,23 @@ module Interpreter_helpers = struct (* Returns a list of printed shield transactions and their total amount. *) let shield ~memo_size sk number_transac vk printer anti_replay = - let state = Sapling.Storage.empty ~memo_size in + let state = Tezos_sapling.Storage.empty ~memo_size in let rec aux number_transac number_outputs index amount_output total res = if Compare.Int.(number_transac <= 0) then (res, total) else let (new_index, new_addr) = - Sapling.Core.Wallet.Viewing_key.(new_address vk index) + Tezos_sapling.Core.Wallet.Viewing_key.(new_address vk index) in let outputs = List.init number_outputs (fun _ -> - Sapling.Forge.make_output + Tezos_sapling.Forge.make_output new_addr amount_output (Bytes.create memo_size)) in let tr_hex = to_hex - (Sapling.Forge.forge_transaction + (Tezos_sapling.Forge.forge_transaction ~number_dummy_inputs:0 ~number_dummy_outputs:0 [] @@ -417,7 +433,7 @@ module Interpreter_helpers = struct sk anti_replay state) - Sapling.Core.Client.UTXO.transaction_encoding + Tezos_sapling.Core.Client.UTXO.transaction_encoding in aux (number_transac - 1) @@ -427,7 +443,13 @@ module Interpreter_helpers = struct (total + (number_outputs * Int64.to_int amount_output)) (printer tr_hex :: res) in - aux number_transac 2 Sapling.Core.Wallet.Viewing_key.default_index 20L 0 [] + aux + number_transac + 2 + Tezos_sapling.Core.Wallet.Viewing_key.default_index + 20L + 0 + [] (* This fails if the operation is not correct wrt the block *) let next_block block operation = diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/test_tez.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/test_tez.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/test_tez.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/test_tez.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/testable.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/testable.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/testable.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/testable.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/tezos-008-PtEdoTez-test-helpers.opam b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/tezos-008-PtEdo2Zk-test-helpers.opam similarity index 83% rename from src/proto_008_PtEdoTez/lib_protocol/test/helpers/tezos-008-PtEdoTez-test-helpers.opam rename to src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/tezos-008-PtEdo2Zk-test-helpers.opam index d1f1bc952008423142e7a24e385b442c47ad1823..a1b02251fb42571860613b4f4bf3bed571a0854f 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/tezos-008-PtEdoTez-test-helpers.opam +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/helpers/tezos-008-PtEdo2Zk-test-helpers.opam @@ -11,9 +11,9 @@ depends: [ "tezos-stdlib-unix" "tezos-shell-services" "tezos-protocol-environment" - "tezos-protocol-008-PtEdoTez" - "tezos-protocol-008-PtEdoTez-parameters" - "tezos-client-008-PtEdoTez" + "tezos-protocol-008-PtEdo2Zk" + "tezos-protocol-008-PtEdo2Zk-parameters" + "tezos-client-008-PtEdo2Zk" "alcotest-lwt" ] build: [ diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/interpretation.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/interpretation.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/interpretation.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/interpretation.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/lazy_storage_diff.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/lazy_storage_diff.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/lazy_storage_diff.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/lazy_storage_diff.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/main.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/main.ml similarity index 99% rename from src/proto_008_PtEdoTez/lib_protocol/test/main.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/main.ml index 7e460f9aee0af0d393e7de579dbfa017b1008a47..7e35cd32676a2a5b0719cdcc620bb1f53818e5a7 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/main.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/main.ml @@ -25,7 +25,7 @@ let () = Alcotest_lwt.run - "protocol_008_PtEdoTez" + "protocol_008_PtEdo2Zk" [ ("transfer", Transfer.tests); ("origination", Origination.tests); ("activation", Activation.tests); diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/origination.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/origination.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/origination.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/origination.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/qty.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/qty.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/qty.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/qty.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/reveal.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/reveal.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/reveal.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/reveal.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/rolls.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/rolls.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/rolls.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/rolls.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/script_gas.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/script_gas.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/script_gas.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/script_gas.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/seed.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/seed.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/seed.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/seed.ml diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/test/test.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..23fae84aca246cca0c28e785619e57c105671bb0 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/test.ml @@ -0,0 +1,37 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Wraps an alcotest so that it prints correctly errors from the Error_monad. *) +let tztest name speed f = + Alcotest_lwt.test_case name speed (fun _sw () -> + f () + >>= function + | Ok () -> + Lwt.return_unit + | Error err -> + Tezos_stdlib_unix.Internal_event_unix.close () + >>= fun () -> + Format.printf "@.%a@." pp_print_error err ; + Lwt.fail Alcotest.Test_error) diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/test_helpers_rpcs.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/test_helpers_rpcs.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/test_helpers_rpcs.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/test_helpers_rpcs.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/test_sapling.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/test_sapling.ml similarity index 93% rename from src/proto_008_PtEdoTez/lib_protocol/test/test_sapling.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/test_sapling.ml index 9f6b6cac9621691bd5e0f2de661e2d91b7bbf9d9..e439f21c3048c8b5273b5f8c3be808fbbb9aaad7 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/test_sapling.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/test_sapling.ml @@ -42,7 +42,7 @@ module Raw_context_tests = struct ~fitness:b.header.shell.fitness >>= wrap >>=? fun ctx -> - let module H = Sapling.Core.Client.Hash in + let module H = Tezos_sapling.Core.Client.Hash in let cm = H.uncommitted ~height:0 in let expected_root = H.uncommitted ~height:32 in Lazy_storage_diff.fresh @@ -294,7 +294,7 @@ module Raw_context_tests = struct Then it adds 10 at the same level and check that only the last one is stored. *) let root_test () = - let open Sapling.Core in + let open Tezos_sapling.Core in let gen_root () = Data_encoding.Binary.of_bytes_exn Validator.Hash.encoding @@ -410,12 +410,13 @@ module Alpha_context_tests = struct init () >>=? fun ctx -> let sk = - Sapling.Core.Wallet.Spending_key.of_seed (Tezos_crypto.Hacl.Rand.gen 32) + Tezos_sapling.Core.Wallet.Spending_key.of_seed + (Tezos_crypto.Hacl.Rand.gen 32) in let vt = - let ps = Sapling.Storage.empty ~memo_size:0 in + let ps = Tezos_sapling.Storage.empty ~memo_size:0 in (* the dummy output will have memo_size 0 *) - Sapling.Forge.forge_transaction + Tezos_sapling.Forge.forge_transaction ~number_dummy_outputs:1 [] [] @@ -435,7 +436,7 @@ module Alpha_context_tests = struct let rounds = 5 in Printf.printf "\nrounds: %d\n" rounds ; let w = wallet_gen () in - let cs = Sapling.Storage.empty ~memo_size:8 in + let cs = Tezos_sapling.Storage.empty ~memo_size:8 in (* one verify_update to get the id *) let vt = transfer w cs [] in verify_update ctx vt |> assert_some @@ -477,7 +478,7 @@ module Alpha_context_tests = struct >>=? fun ctx -> let rounds = 5 in let w = wallet_gen () in - let cs = Sapling.Storage.empty ~memo_size:8 in + let cs = Tezos_sapling.Storage.empty ~memo_size:8 in (* one verify_update to get the id *) let vt = transfer w cs [] in verify_update ctx vt |> assert_some @@ -507,7 +508,7 @@ module Alpha_context_tests = struct init () >>=? fun ctx -> let w = wallet_gen () in - let cs = Sapling.Storage.empty ~memo_size:8 in + let cs = Tezos_sapling.Storage.empty ~memo_size:8 in (* one verify_update to get the id *) let vt = transfer w cs [] in verify_update ctx vt |> assert_some @@ -524,7 +525,7 @@ module Alpha_context_tests = struct init () >>=? fun ctx -> let w = wallet_gen () in - let cs = Sapling.Storage.empty ~memo_size:8 in + let cs = Tezos_sapling.Storage.empty ~memo_size:8 in let vt = transfer w cs [] in verify_update ctx vt |> assert_some >>=? fun (ctx, id) -> @@ -533,23 +534,24 @@ module Alpha_context_tests = struct let vt = transfer w cs [0] in (* fails sig check because of wrong balance *) let vt_broken = - Sapling.Core.Validator.UTXO.{vt with balance = Int64.(succ vt.balance)} + Tezos_sapling.Core.Validator.UTXO. + {vt with balance = Int64.(succ vt.balance)} in verify_update ctx ~id vt_broken |> assert_none >>=? fun () -> (* randomize one output to fail check outputs *) (* don't randomize the ciphertext as it is not part of the proof *) - let open Sapling.Core.Client.UTXO in + let open Tezos_sapling.Core.Client.UTXO in let o = List.hd vt.outputs in let o_wrong_cm = { o with - cm = randomized_byte o.cm Sapling.Core.Client.Commitment.encoding; + cm = randomized_byte o.cm Tezos_sapling.Core.Client.Commitment.encoding; } in let vt_broken = - Sapling.Core.Validator.UTXO.{vt with outputs = [o_wrong_cm]} + Tezos_sapling.Core.Validator.UTXO.{vt with outputs = [o_wrong_cm]} in verify_update ctx ~id vt_broken |> assert_none @@ -563,11 +565,11 @@ module Alpha_context_tests = struct randomized_byte ~pos o.ciphertext - Sapling.Core.Client.Ciphertext.encoding; + Tezos_sapling.Core.Client.Ciphertext.encoding; } in let vt_broken = - Sapling.Core.Validator.UTXO.{vt with outputs = [o_wrong_cv]} + Tezos_sapling.Core.Validator.UTXO.{vt with outputs = [o_wrong_cv]} in verify_update ctx ~id vt_broken |> assert_none @@ -575,7 +577,7 @@ module Alpha_context_tests = struct init () >>=? fun ctx -> let w = wallet_gen () in - let cs = Sapling.Storage.empty ~memo_size:8 in + let cs = Tezos_sapling.Storage.empty ~memo_size:8 in (* generate the first storage *) let vt = transfer w cs [] in verify_update ctx vt |> assert_some @@ -596,13 +598,15 @@ module Alpha_context_tests = struct >>=? fun () -> (* Swap the root so that it passes the root_mem check but fails the input check *) - let vt1_broken = Sapling.Core.Validator.UTXO.{vt2 with root = vt1.root} in + let vt1_broken = + Tezos_sapling.Core.Validator.UTXO.{vt2 with root = vt1.root} + in verify_update ctx ~id:id1 vt1_broken |> assert_none >>=? fun () -> (* fail the sig check *) let vt1_broken = - Sapling.Core.Validator.UTXO.{vt1 with outputs = vt2.outputs} + Tezos_sapling.Core.Validator.UTXO.{vt1 with outputs = vt2.outputs} in verify_update ctx ~id:id1 vt1_broken |> assert_none end @@ -667,19 +671,19 @@ module Interpreter_tests = struct let pos = Int64.of_int pos_int in let forge_input = snd - ( Sapling.Forge.Input.get state pos wa.vk + ( Tezos_sapling.Forge.Input.get state pos wa.vk |> Option.unopt_assert ~loc:__POS__ ) in forge_input) in let list_forge_output = List.map - (fun addr -> Sapling.Forge.make_output addr 1L (Bytes.create 8)) + (fun addr -> Tezos_sapling.Forge.make_output addr 1L (Bytes.create 8)) list_addr in let hex_transac = to_hex - (Sapling.Forge.forge_transaction + (Tezos_sapling.Forge.forge_transaction ~number_dummy_inputs:0 ~number_dummy_outputs:0 list_forge_input @@ -687,7 +691,7 @@ module Interpreter_tests = struct wa.sk anti_replay state) - Sapling.Core.Client.UTXO.transaction_encoding + Tezos_sapling.Core.Client.UTXO.transaction_encoding in let hex_pkh = to_hex @@ -719,21 +723,21 @@ module Interpreter_tests = struct let pos = Int64.of_int (i + 14 + 14) in let forge_input = snd - ( Sapling.Forge.Input.get state pos wb.vk + ( Tezos_sapling.Forge.Input.get state pos wb.vk |> Option.unopt_assert ~loc:__POS__ ) in forge_input) in let addr_a = snd - @@ Sapling.Core.Client.Viewing_key.new_address + @@ Tezos_sapling.Core.Client.Viewing_key.new_address wa.vk - Sapling.Core.Client.Viewing_key.default_index + Tezos_sapling.Core.Client.Viewing_key.default_index in - let output = Sapling.Forge.make_output addr_a 15L (Bytes.create 8) in + let output = Tezos_sapling.Forge.make_output addr_a 15L (Bytes.create 8) in let hex_transac = to_hex - (Sapling.Forge.forge_transaction + (Tezos_sapling.Forge.forge_transaction ~number_dummy_inputs:2 ~number_dummy_outputs:2 list_forge_input @@ -741,7 +745,7 @@ module Interpreter_tests = struct wb.sk anti_replay state) - Sapling.Core.Client.UTXO.transaction_encoding + Tezos_sapling.Core.Client.UTXO.transaction_encoding in let string = Format.sprintf "{Pair 0x%s None }" hex_transac in let parameters = @@ -835,7 +839,7 @@ module Interpreter_tests = struct List.exists (function | Environment.Ecoproto_error - (Tezos_raw_protocol_008_PtEdoTez.Script_tc_errors + (Tezos_raw_protocol_008_PtEdo2Zk.Script_tc_errors .Unexpected_forged_value _) -> true | _ -> @@ -860,23 +864,24 @@ module Interpreter_tests = struct in transac_and_sync ~memo_size block_start parameters_1 15 src dst baker >>=? fun (block_1, _ctx, state) -> - let intermediary_root = Sapling.Storage.get_root state in + let intermediary_root = Tezos_sapling.Storage.get_root state in let addr = - snd @@ Sapling.Core.Wallet.Viewing_key.(new_address vk default_index) + snd + @@ Tezos_sapling.Core.Wallet.Viewing_key.(new_address vk default_index) in - let output = Sapling.Forge.make_output addr 15L (Bytes.create 8) in + let output = Tezos_sapling.Forge.make_output addr 15L (Bytes.create 8) in let hex_transac_2 = "0x" ^ to_hex - (Sapling.Forge.forge_transaction + (Tezos_sapling.Forge.forge_transaction [ snd - ( Sapling.Forge.Input.get state 0L vk + ( Tezos_sapling.Forge.Input.get state 0L vk |> Option.unopt_assert ~loc:__POS__ ) ] [output] sk anti_replay state) - Sapling.Core.Client.UTXO.transaction_encoding + Tezos_sapling.Core.Client.UTXO.transaction_encoding in let string_2 = Format.sprintf "{Pair %s None }" hex_transac_2 in let parameters_2 = @@ -884,7 +889,7 @@ module Interpreter_tests = struct in transac_and_sync ~memo_size block_1 parameters_2 0 src dst baker >>=? fun (block_1, _ctx, state_1) -> - let final_root = Sapling.Storage.get_root state_1 in + let final_root = Tezos_sapling.Storage.get_root state_1 in Alpha_services.Contract.single_sapling_get_diff Block.rpc_ctxt block_1 @@ -1109,10 +1114,10 @@ module Interpreter_tests = struct local_state_from_disk state_2 ctx >|=? fun state_2 -> (* we check that first state contains 15 to addr_1 but not 15 to addr_2*) - assert (Option.is_some @@ Sapling.Forge.Input.get state_1 0L wa.vk) ; - assert (Option.is_some @@ Sapling.Forge.Input.get state_2 0L wa.vk) ; - assert (Option.is_none @@ Sapling.Forge.Input.get state_1 0L wb.vk) ; - assert (Option.is_none @@ Sapling.Forge.Input.get state_2 0L wb.vk) + assert (Option.is_some @@ Tezos_sapling.Forge.Input.get state_1 0L wa.vk) ; + assert (Option.is_some @@ Tezos_sapling.Forge.Input.get state_2 0L wa.vk) ; + assert (Option.is_none @@ Tezos_sapling.Forge.Input.get state_1 0L wb.vk) ; + assert (Option.is_none @@ Tezos_sapling.Forge.Input.get state_2 0L wb.vk) let test_state_as_arg () = init () diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/transfer.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/transfer.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/transfer.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/transfer.ml diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/typechecking.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/typechecking.ml similarity index 99% rename from src/proto_008_PtEdoTez/lib_protocol/test/typechecking.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/typechecking.ml index a32922b27065874b7e14c7e024b7e42a5a5cbe34..b8569ea496d5031e921c507616f713438000b881 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/typechecking.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/typechecking.ml @@ -485,7 +485,7 @@ let test_parse_data_fails loc ctxt ty node = | Ok _ -> Alcotest.failf "Unexpected typechecking success: %s" loc | Error - (Tezos_raw_protocol_008_PtEdoTez.Script_tc_errors.Invalid_constant _ + (Tezos_raw_protocol_008_PtEdo2Zk.Script_tc_errors.Invalid_constant _ :: _) -> return_unit | Error _ as res -> diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/voting.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/voting.ml similarity index 100% rename from src/proto_008_PtEdoTez/lib_protocol/test/voting.ml rename to src/proto_008_PtEdo2Zk/lib_protocol/test/voting.ml diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/tez_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/tez_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..f5a961c8ea5fd1c384a1167dc4cddecdab5a53b3 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/tez_repr.ml @@ -0,0 +1,261 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let id = "tez" + +let name = "mutez" + +include Compare.Int64 (* invariant: positive *) + +type error += + | Addition_overflow of t * t (* `Temporary *) + | Subtraction_underflow of t * t (* `Temporary *) + | Multiplication_overflow of t * int64 (* `Temporary *) + | Negative_multiplicator of t * int64 (* `Temporary *) + | Invalid_divisor of t * int64 + +(* `Temporary *) + +let zero = 0L + +(* all other constant are defined from the value of one micro tez *) +let one_mutez = 1L + +let one_cent = Int64.mul one_mutez 10_000L + +let fifty_cents = Int64.mul one_cent 50L + +(* 1 tez = 100 cents = 1_000_000 mutez *) +let one = Int64.mul one_cent 100L + +let of_string s = + let triplets = function + | hd :: tl -> + let len = String.length hd in + Compare.Int.( + len <= 3 && len > 0 && List.for_all (fun s -> String.length s = 3) tl) + | [] -> + false + in + let integers s = triplets (String.split_on_char ',' s) in + let decimals s = + let l = String.split_on_char ',' s in + if Compare.Int.(List.length l > 2) then false else triplets (List.rev l) + in + let parse left right = + let remove_commas s = String.concat "" (String.split_on_char ',' s) in + let pad_to_six s = + let len = String.length s in + String.init 6 (fun i -> if Compare.Int.(i < len) then s.[i] else '0') + in + Int64.of_string_opt (remove_commas left ^ pad_to_six (remove_commas right)) + in + match String.split_on_char '.' s with + | [left; right] -> + if String.contains s ',' then + if integers left && decimals right then parse left right else None + else if + Compare.Int.(String.length right > 0) + && Compare.Int.(String.length right <= 6) + then parse left right + else None + | [left] -> + if (not (String.contains s ',')) || integers left then parse left "" + else None + | _ -> + None + +let pp ppf amount = + let mult_int = 1_000_000L in + let rec left ppf amount = + let (d, r) = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in + if d > 0L then Format.fprintf ppf "%a%03Ld" left d r + else Format.fprintf ppf "%Ld" r + in + let right ppf amount = + let triplet ppf v = + if Compare.Int.(v mod 10 > 0) then Format.fprintf ppf "%03d" v + else if Compare.Int.(v mod 100 > 0) then + Format.fprintf ppf "%02d" (v / 10) + else Format.fprintf ppf "%d" (v / 100) + in + let (hi, lo) = (amount / 1000, amount mod 1000) in + if Compare.Int.(lo = 0) then Format.fprintf ppf "%a" triplet hi + else Format.fprintf ppf "%03d%a" hi triplet lo + in + let (ints, decs) = + (Int64.(div amount mult_int), Int64.(to_int (rem amount mult_int))) + in + left ppf ints ; + if Compare.Int.(decs > 0) then Format.fprintf ppf ".%a" right decs + +let to_string t = Format.asprintf "%a" pp t + +let ( -? ) t1 t2 = + if t2 <= t1 then ok (Int64.sub t1 t2) + else error (Subtraction_underflow (t1, t2)) + +let ( +? ) t1 t2 = + let t = Int64.add t1 t2 in + if t < t1 then error (Addition_overflow (t1, t2)) else ok t + +let ( *? ) t m = + let open Compare.Int64 in + let open Int64 in + let rec step cur pow acc = + if cur = 0L then ok acc + else + pow +? pow + >>? fun npow -> + if logand cur 1L = 1L then + acc +? pow >>? fun nacc -> step (shift_right_logical cur 1) npow nacc + else step (shift_right_logical cur 1) npow acc + in + if m < 0L then error (Negative_multiplicator (t, m)) + else + match step m t 0L with + | Ok res -> + Ok res + | Error ([Addition_overflow _] as errs) -> + Error (Multiplication_overflow (t, m) :: errs) + | Error errs -> + Error errs + +let ( /? ) t d = + if d <= 0L then error (Invalid_divisor (t, d)) else ok (Int64.div t d) + +let mul_exn t m = + match t *? Int64.(of_int m) with + | Ok v -> + v + | Error _ -> + invalid_arg "mul_exn" + +let of_mutez t = if t < 0L then None else Some t + +let of_mutez_exn x = + match of_mutez x with None -> invalid_arg "Tez.of_mutez" | Some v -> v + +let to_int64 t = t + +let to_mutez t = t + +let encoding = + let open Data_encoding in + Data_encoding.def + name + (check_size 10 (conv Z.of_int64 (Json.wrap_error Z.to_int64) n)) + +let () = + let open Data_encoding in + register_error_kind + `Temporary + ~id:(id ^ ".addition_overflow") + ~title:("Overflowing " ^ id ^ " addition") + ~pp:(fun ppf (opa, opb) -> + Format.fprintf + ppf + "Overflowing addition of %a %s and %a %s" + pp + opa + id + pp + opb + id) + ~description:("An addition of two " ^ id ^ " amounts overflowed") + (obj1 (req "amounts" (tup2 encoding encoding))) + (function Addition_overflow (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Addition_overflow (a, b)) ; + register_error_kind + `Temporary + ~id:(id ^ ".subtraction_underflow") + ~title:("Underflowing " ^ id ^ " subtraction") + ~pp:(fun ppf (opa, opb) -> + Format.fprintf + ppf + "Underflowing subtraction of %a %s and %a %s" + pp + opa + id + pp + opb + id) + ~description:("An subtraction of two " ^ id ^ " amounts underflowed") + (obj1 (req "amounts" (tup2 encoding encoding))) + (function Subtraction_underflow (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Subtraction_underflow (a, b)) ; + register_error_kind + `Temporary + ~id:(id ^ ".multiplication_overflow") + ~title:("Overflowing " ^ id ^ " multiplication") + ~pp:(fun ppf (opa, opb) -> + Format.fprintf + ppf + "Overflowing multiplication of %a %s and %Ld" + pp + opa + id + opb) + ~description: + ("A multiplication of a " ^ id ^ " amount by an integer overflowed") + (obj2 (req "amount" encoding) (req "multiplicator" int64)) + (function Multiplication_overflow (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Multiplication_overflow (a, b)) ; + register_error_kind + `Temporary + ~id:(id ^ ".negative_multiplicator") + ~title:("Negative " ^ id ^ " multiplicator") + ~pp:(fun ppf (opa, opb) -> + Format.fprintf + ppf + "Multiplication of %a %s by negative integer %Ld" + pp + opa + id + opb) + ~description:("Multiplication of a " ^ id ^ " amount by a negative integer") + (obj2 (req "amount" encoding) (req "multiplicator" int64)) + (function Negative_multiplicator (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Negative_multiplicator (a, b)) ; + register_error_kind + `Temporary + ~id:(id ^ ".invalid_divisor") + ~title:("Invalid " ^ id ^ " divisor") + ~pp:(fun ppf (opa, opb) -> + Format.fprintf + ppf + "Division of %a %s by non positive integer %Ld" + pp + opa + id + opb) + ~description: + ("Multiplication of a " ^ id ^ " amount by a non positive integer") + (obj2 (req "amount" encoding) (req "divisor" int64)) + (function Invalid_divisor (a, b) -> Some (a, b) | _ -> None) + (fun (a, b) -> Invalid_divisor (a, b)) + +type tez = t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/tez_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/tez_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..382439b10874bb2967278cf70c653ffdbcd5ca3b --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/tez_repr.mli @@ -0,0 +1,71 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type t + +type tez = t + +val zero : t + +val one_mutez : t + +val one_cent : t + +val fifty_cents : t + +val one : t + +val ( -? ) : t -> t -> t tzresult + +val ( +? ) : t -> t -> t tzresult + +val ( *? ) : t -> int64 -> t tzresult + +val ( /? ) : t -> int64 -> t tzresult + +val to_mutez : t -> int64 + +(** [of_mutez n] (micro tez) is None if n is negative *) +val of_mutez : int64 -> t option + +(** [of_mutez_exn n] fails if n is negative. + It should only be used at toplevel for constants. *) +val of_mutez_exn : int64 -> t + +(** It should only be used at toplevel for constants. *) +val mul_exn : t -> int -> t + +val encoding : t Data_encoding.t + +val to_int64 : t -> int64 + +include Compare.S with type t := t + +val pp : Format.formatter -> t -> unit + +val of_string : string -> t option + +val to_string : t -> string diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/tezos-embedded-protocol-008-PtEdo2Zk.opam b/src/proto_008_PtEdo2Zk/lib_protocol/tezos-embedded-protocol-008-PtEdo2Zk.opam new file mode 100644 index 0000000000000000000000000000000000000000..0ca565bd5e69451fe9676b24bad423a591e04048 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/tezos-embedded-protocol-008-PtEdo2Zk.opam @@ -0,0 +1,27 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "tezos-tooling" { with-test } + "dune" { >= "2.0" } + "tezos-base" + "tezos-protocol-008-PtEdo2Zk" + "tezos-protocol-compiler" + "tezos-protocol-updater" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "008_PtEdo2Zk" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: economic-protocol definition, embedded in `tezos-node`" diff --git a/src/proto_008_PtEdoTez/lib_protocol/tezos-protocol-008-PtEdoTez-tests.opam b/src/proto_008_PtEdo2Zk/lib_protocol/tezos-protocol-008-PtEdo2Zk-tests.opam similarity index 88% rename from src/proto_008_PtEdoTez/lib_protocol/tezos-protocol-008-PtEdoTez-tests.opam rename to src/proto_008_PtEdo2Zk/lib_protocol/tezos-protocol-008-PtEdo2Zk-tests.opam index b24fcb9aa124514371d9802113866ab7bd6b87a5..888f717645453b6c5a42e338482d87109262870c 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/tezos-protocol-008-PtEdoTez-tests.opam +++ b/src/proto_008_PtEdo2Zk/lib_protocol/tezos-protocol-008-PtEdo2Zk-tests.opam @@ -11,12 +11,12 @@ depends: [ "tezos-base" "tezos-protocol-compiler" "alcotest-lwt" { with-test & >= "1.1.0" } - "tezos-008-PtEdoTez-test-helpers" { with-test } + "tezos-008-PtEdo2Zk-test-helpers" { with-test } "tezos-stdlib-unix" { with-test } "tezos-protocol-environment" { with-test } "tezos-test-services" { with-test } "tezos-client-base" { with-test } - "tezos-protocol-008-PtEdoTez-parameters" { with-test } + "tezos-protocol-008-PtEdo2Zk-parameters" { with-test } "tezos-shell-services" { with-test } ] build: [ @@ -25,7 +25,7 @@ build: [ "%{tezos-protocol-compiler:lib}%/dune_protocol.template" "dune" "%{tezos-protocol-compiler:lib}%/final_protocol_versions" - "008_PtEdoTez" + "008_PtEdo2Zk" ] ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/tezos-protocol-008-PtEdo2Zk.opam b/src/proto_008_PtEdo2Zk/lib_protocol/tezos-protocol-008-PtEdo2Zk.opam new file mode 100644 index 0000000000000000000000000000000000000000..38b241b8f648f14a3082273143956112a88c29b6 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/tezos-protocol-008-PtEdo2Zk.opam @@ -0,0 +1,25 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "tezos-tooling" { with-test } + "dune" { >= "2.0" } + "tezos-base" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "008_PtEdo2Zk" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: economic-protocol definition" diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/tezos-protocol-functor-008-PtEdo2Zk.opam b/src/proto_008_PtEdo2Zk/lib_protocol/tezos-protocol-functor-008-PtEdo2Zk.opam new file mode 100644 index 0000000000000000000000000000000000000000..d74f08fca61975f8eaaffd2672b7f6ec3423a6e9 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/tezos-protocol-functor-008-PtEdo2Zk.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-008-PtEdo2Zk" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "008_PtEdo2Zk" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: economic-protocol definition parameterized by its environment implementation" diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/time_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/time_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..c9e529925772a7927e0131916b021e6ac4ac186a --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/time_repr.ml @@ -0,0 +1,64 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Time + +type time = t + +type error += Timestamp_add (* `Permanent *) + +type error += Timestamp_sub (* `Permanent *) + +let () = + register_error_kind + `Permanent + ~id:"timestamp_add" + ~title:"Timestamp add" + ~description:"Overflow when adding timestamps." + ~pp:(fun ppf () -> Format.fprintf ppf "Overflow when adding timestamps.") + Data_encoding.empty + (function Timestamp_add -> Some () | _ -> None) + (fun () -> Timestamp_add) ; + register_error_kind + `Permanent + ~id:"timestamp_sub" + ~title:"Timestamp sub" + ~description:"Subtracting timestamps resulted in negative period." + ~pp:(fun ppf () -> + Format.fprintf ppf "Subtracting timestamps resulted in negative period.") + Data_encoding.empty + (function Timestamp_sub -> Some () | _ -> None) + (fun () -> Timestamp_sub) + +let of_seconds_string s = Option.map of_seconds (Int64.of_string_opt s) + +let to_seconds_string s = Int64.to_string (to_seconds s) + +let pp = pp_hum + +let ( +? ) x y = + try ok (add x (Period_repr.to_seconds y)) with _exn -> error Timestamp_add + +let ( -? ) x y = record_trace Timestamp_sub (Period_repr.of_seconds (diff x y)) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/time_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/time_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..5a0a4c5d9f170a6c327afd776d29d81bd23af539 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/time_repr.mli @@ -0,0 +1,40 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include module type of struct + include Time +end + +type time = t + +val pp : Format.formatter -> t -> unit + +val of_seconds_string : string -> time option + +val to_seconds_string : time -> string + +val ( +? ) : time -> Period_repr.t -> time tzresult + +val ( -? ) : time -> time -> Period_repr.t tzresult diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/vote_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/vote_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..4fb0b82d9fefb8fd644a44e8792a0870f0418b53 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/vote_repr.ml @@ -0,0 +1,46 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type proposal = Protocol_hash.t + +type ballot = Yay | Nay | Pass + +let ballot_encoding = + let of_int8 = function + | 0 -> + Yay + | 1 -> + Nay + | 2 -> + Pass + | _ -> + invalid_arg "ballot_of_int8" + in + let to_int8 = function Yay -> 0 | Nay -> 1 | Pass -> 2 in + let open Data_encoding in + (* union *) + splitted + ~binary:(conv to_int8 of_int8 int8) + ~json:(string_enum [("yay", Yay); ("nay", Nay); ("pass", Pass)]) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/vote_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/vote_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..8a7d4a59b68574ae6bdf136ff45ca954e95bab2b --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/vote_repr.mli @@ -0,0 +1,33 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** a protocol change proposal *) +type proposal = Protocol_hash.t + +(** votes can be for, against or neutral. + Neutral serves to count towards a quorum *) +type ballot = Yay | Nay | Pass + +val ballot_encoding : ballot Data_encoding.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/vote_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/vote_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..3323febf4e892a2fd4cfedc8e2cbda989972b90a --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/vote_storage.ml @@ -0,0 +1,172 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let recorded_proposal_count_for_delegate ctxt proposer = + Storage.Vote.Proposals_count.get_option ctxt proposer + >|=? Option.value ~default:0 + +let record_proposal ctxt proposal proposer = + recorded_proposal_count_for_delegate ctxt proposer + >>=? fun count -> + Storage.Vote.Proposals_count.init_set ctxt proposer (count + 1) + >>= fun ctxt -> Storage.Vote.Proposals.add ctxt (proposal, proposer) >|= ok + +let get_proposals ctxt = + Storage.Vote.Proposals.fold + ctxt + ~init:(ok Protocol_hash.Map.empty) + ~f:(fun (proposal, delegate) acc -> + (* Assuming the same listings is used at votings *) + Storage.Vote.Listings.get ctxt delegate + >>=? fun weight -> + Lwt.return + ( acc + >|? fun acc -> + let previous = + match Protocol_hash.Map.find_opt proposal acc with + | None -> + 0l + | Some x -> + x + in + Protocol_hash.Map.add proposal (Int32.add weight previous) acc )) + +let clear_proposals ctxt = + Storage.Vote.Proposals_count.clear ctxt + >>= fun ctxt -> Storage.Vote.Proposals.clear ctxt + +type ballots = {yay : int32; nay : int32; pass : int32} + +let ballots_encoding = + let open Data_encoding in + conv + (fun {yay; nay; pass} -> (yay, nay, pass)) + (fun (yay, nay, pass) -> {yay; nay; pass}) + @@ obj3 (req "yay" int32) (req "nay" int32) (req "pass" int32) + +let has_recorded_ballot = Storage.Vote.Ballots.mem + +let record_ballot = Storage.Vote.Ballots.init + +let get_ballots ctxt = + Storage.Vote.Ballots.fold + ctxt + ~f:(fun delegate ballot (ballots : ballots tzresult) -> + (* Assuming the same listings is used at votings *) + Storage.Vote.Listings.get ctxt delegate + >>=? fun weight -> + let count = Int32.add weight in + Lwt.return + ( ballots + >|? fun ballots -> + match ballot with + | Yay -> + {ballots with yay = count ballots.yay} + | Nay -> + {ballots with nay = count ballots.nay} + | Pass -> + {ballots with pass = count ballots.pass} )) + ~init:(ok {yay = 0l; nay = 0l; pass = 0l}) + +let get_ballot_list = Storage.Vote.Ballots.bindings + +let clear_ballots = Storage.Vote.Ballots.clear + +let listings_encoding = + Data_encoding.( + list + (obj2 (req "pkh" Signature.Public_key_hash.encoding) (req "rolls" int32))) + +let update_listings ctxt = + Storage.Vote.Listings.clear ctxt + >>= fun ctxt -> + Roll_storage.fold ctxt (ctxt, 0l) ~f:(fun _roll delegate (ctxt, total) -> + (* TODO use snapshots *) + let delegate = Signature.Public_key.hash delegate in + Storage.Vote.Listings.get_option ctxt delegate + >|=? Option.value ~default:0l + >>=? fun count -> + Storage.Vote.Listings.init_set ctxt delegate (Int32.succ count) + >|= fun ctxt -> ok (ctxt, Int32.succ total)) + >>=? fun (ctxt, total) -> + Storage.Vote.Listings_size.init_set ctxt total >>= fun ctxt -> return ctxt + +let listing_size = Storage.Vote.Listings_size.get + +let in_listings = Storage.Vote.Listings.mem + +let get_listings = Storage.Vote.Listings.bindings + +let get_voting_power_free ctxt owner = + Storage.Vote.Listings.get_option ctxt owner >|=? Option.value ~default:0l + +(* This function bypasses the carbonated functors to account for gas consumption. + This is a temporary situation intended to be fixed by adding the right + carbonated functors in a future amendment *) +let get_voting_power ctxt owner = + let open Raw_context in + (* Always consume read access to memory *) + (* Accessing an int32 at /votes/listings/pkh *) + consume_gas ctxt (Storage_costs.read_access ~path_length:3 ~read_bytes:4) + >>?= fun ctxt -> + Storage.Vote.Listings.get_option ctxt owner + >|=? function None -> (ctxt, 0l) | Some power -> (ctxt, power) + +let get_total_voting_power_free = listing_size + +(* This function bypasses the carbonated functors to account for gas consumption. + This is a temporary situation intended to be fixed by adding the right + carbonated functors in a future amendment *) +let get_total_voting_power ctxt = + let open Raw_context in + (* Accessing an int32 at /votes/listings_size *) + consume_gas ctxt (Storage_costs.read_access ~path_length:2 ~read_bytes:4) + >>?= fun ctxt -> + get_total_voting_power_free ctxt + >|=? fun total_voting_power -> (ctxt, total_voting_power) + +let get_current_quorum ctxt = + Storage.Vote.Participation_ema.get ctxt + >|=? fun participation_ema -> + let quorum_min = Constants_storage.quorum_min ctxt in + let quorum_max = Constants_storage.quorum_max ctxt in + let quorum_diff = Int32.sub quorum_max quorum_min in + Int32.(add quorum_min (div (mul participation_ema quorum_diff) 100_00l)) + +let get_participation_ema = Storage.Vote.Participation_ema.get + +let set_participation_ema = Storage.Vote.Participation_ema.set + +let get_current_proposal = Storage.Vote.Current_proposal.get + +let init_current_proposal = Storage.Vote.Current_proposal.init + +let clear_current_proposal = Storage.Vote.Current_proposal.delete + +let init ctxt ~start_position = + (* participation EMA is in centile of a percentage *) + let participation_ema = Constants_storage.quorum_max ctxt in + Storage.Vote.Participation_ema.init ctxt participation_ema + >>=? fun ctxt -> Voting_period_storage.init_first_period ctxt ~start_position diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/vote_storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/vote_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..3aaa45e058d573faa084f969837074bfd6ad4cfd --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/vote_storage.mli @@ -0,0 +1,113 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Manages all the voting related storage in Storage.Vote. *) + +(** Records a protocol proposal with the delegate that proposed it. *) +val record_proposal : + Raw_context.t -> + Protocol_hash.t -> + Signature.Public_key_hash.t -> + Raw_context.t tzresult Lwt.t + +val recorded_proposal_count_for_delegate : + Raw_context.t -> Signature.Public_key_hash.t -> int tzresult Lwt.t + +(** Computes for each proposal how many delegates proposed it. *) +val get_proposals : Raw_context.t -> int32 Protocol_hash.Map.t tzresult Lwt.t + +val clear_proposals : Raw_context.t -> Raw_context.t Lwt.t + +(** Counts of the votes *) +type ballots = {yay : int32; nay : int32; pass : int32} + +val ballots_encoding : ballots Data_encoding.t + +val has_recorded_ballot : + Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t + +(** Records a vote for a delegate, returns a {!Storage_error Existing_key} if + the vote was already registered *) +val record_ballot : + Raw_context.t -> + Signature.Public_key_hash.t -> + Vote_repr.ballot -> + Raw_context.t tzresult Lwt.t + +(** Computes the sum of the current ballots weighted by stake. *) +val get_ballots : Raw_context.t -> ballots tzresult Lwt.t + +val get_ballot_list : + Raw_context.t -> (Signature.Public_key_hash.t * Vote_repr.ballot) list Lwt.t + +val clear_ballots : Raw_context.t -> Raw_context.t Lwt.t + +val listings_encoding : + (Signature.Public_key_hash.t * int32) list Data_encoding.t + +(** Populates [!Storage.Vote.Listings] using the currently existing rolls and + sets Listings_size. Delegates without rolls are not included in the listing. *) +val update_listings : Raw_context.t -> Raw_context.t tzresult Lwt.t + +(** Returns the sum of all rolls of all delegates. *) +val listing_size : Raw_context.t -> int32 tzresult Lwt.t + +(** Verifies the presence of a delegate in the listing. *) +val in_listings : Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t + +val get_listings : + Raw_context.t -> (Signature.Public_key_hash.t * int32) list Lwt.t + +val get_voting_power_free : + Raw_context.t -> Signature.public_key_hash -> int32 tzresult Lwt.t + +val get_voting_power : + Raw_context.t -> + Signature.public_key_hash -> + (Raw_context.t * int32) tzresult Lwt.t + +val get_total_voting_power_free : Raw_context.t -> int32 tzresult Lwt.t + +val get_total_voting_power : + Raw_context.t -> (Raw_context.t * int32) tzresult Lwt.t + +val get_current_quorum : Raw_context.t -> int32 tzresult Lwt.t + +val get_participation_ema : Raw_context.t -> int32 tzresult Lwt.t + +val set_participation_ema : + Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t + +val get_current_proposal : Raw_context.t -> Protocol_hash.t tzresult Lwt.t + +val init_current_proposal : + Raw_context.t -> Protocol_hash.t -> Raw_context.t tzresult Lwt.t + +val clear_current_proposal : Raw_context.t -> Raw_context.t tzresult Lwt.t + +(** Sets the initial quorum to 80% and period kind to proposal. *) +val init : + Raw_context.t -> start_position:Int32.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_repr.ml b/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..1b5ae045c13dc6ed1e12d35e1d4bb41fcceb3381 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_repr.ml @@ -0,0 +1,164 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type kind = Proposal | Testing_vote | Testing | Promotion_vote | Adoption + +let string_of_kind = function + | Proposal -> + "proposal" + | Testing_vote -> + "testing_vote" + | Testing -> + "testing" + | Promotion_vote -> + "promotion_vote" + | Adoption -> + "adoption" + +let pp_kind ppf kind = Format.fprintf ppf "%s" @@ string_of_kind kind + +let kind_encoding = + let open Data_encoding in + union + ~tag_size:`Uint8 + [ case + (Tag 0) + ~title:"Proposal" + (constant "proposal") + (function Proposal -> Some () | _ -> None) + (fun () -> Proposal); + case + (Tag 1) + ~title:"Testing_vote" + (constant "testing_vote") + (function Testing_vote -> Some () | _ -> None) + (fun () -> Testing_vote); + case + (Tag 2) + ~title:"Testing" + (constant "testing") + (function Testing -> Some () | _ -> None) + (fun () -> Testing); + case + (Tag 3) + ~title:"Promotion_vote" + (constant "promotion_vote") + (function Promotion_vote -> Some () | _ -> None) + (fun () -> Promotion_vote); + case + (Tag 4) + ~title:"Adoption" + (constant "adoption") + (function Adoption -> Some () | _ -> None) + (fun () -> Adoption) ] + +let succ_kind = function + | Proposal -> + Testing_vote + | Testing_vote -> + Testing + | Testing -> + Promotion_vote + | Promotion_vote -> + Adoption + | Adoption -> + Proposal + +type voting_period = {index : int32; kind : kind; start_position : int32} + +type t = voting_period + +type info = {voting_period : t; position : int32; remaining : int32} + +let root ~start_position = {index = 0l; kind = Proposal; start_position} + +let pp ppf {index; kind; start_position} = + Format.fprintf + ppf + "@[index: %ld@ ,kind:%a@, start_position: %ld@]" + index + pp_kind + kind + start_position + +let pp_info ppf {voting_period; position; remaining} = + Format.fprintf + ppf + "@[voting_period: %a@ ,position:%ld@, remaining: %ld@]" + pp + voting_period + position + remaining + +let encoding = + let open Data_encoding in + conv + (fun {index; kind; start_position} -> (index, kind, start_position)) + (fun (index, kind, start_position) -> {index; kind; start_position}) + (obj3 + (req + "index" + ~description: + "The voting period's index. Starts at 0 with the first block of \ + protocol alpha." + int32) + (req "kind" kind_encoding) + (req "start_position" int32)) + +let info_encoding = + let open Data_encoding in + conv + (fun {voting_period; position; remaining} -> + (voting_period, position, remaining)) + (fun (voting_period, position, remaining) -> + {voting_period; position; remaining}) + (obj3 + (req "voting_period" encoding) + (req "position" int32) + (req "remaining" int32)) + +include Compare.Make (struct + type nonrec t = t + + let compare p p' = Compare.Int32.compare p.index p'.index +end) + +let reset period ~start_position = + let index = Int32.succ period.index in + let kind = Proposal in + {index; kind; start_position} + +let succ period ~start_position = + let index = Int32.succ period.index in + let kind = succ_kind period.kind in + {index; kind; start_position} + +let position_since (level : Level_repr.t) (voting_period : t) = + Int32.(sub level.level_position voting_period.start_position) + +let remaining_blocks (level : Level_repr.t) (voting_period : t) + ~blocks_per_voting_period = + let position = position_since level voting_period in + Int32.(sub blocks_per_voting_period (succ position)) diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_repr.mli b/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..e324058404969c0774a7a12a60b36507002c9022 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_repr.mli @@ -0,0 +1,75 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** The voting period kinds are ordered as follows: + Proposal -> Testing_vote -> Testing -> Promotion_vote -> Adoption. + This order is the one used be the function [succ] below. + *) +type kind = + | Proposal (** protocols can be proposed *) + | Testing_vote (** a proposal can be voted *) + | Testing (** winning proposal is forked on a testnet *) + | Promotion_vote (** activation can be voted *) + | Adoption (** a delay before activation *) + +val kind_encoding : kind Data_encoding.t + +(** A voting period can be of 5 kinds and is uniquely identified by a counter + since the root. *) +type voting_period = {index : Int32.t; kind : kind; start_position : Int32.t} + +type t = voting_period + +type info = {voting_period : t; position : Int32.t; remaining : Int32.t} + +val root : start_position:Int32.t -> t + +include Compare.S with type t := voting_period + +val encoding : t Data_encoding.t + +val info_encoding : info Data_encoding.t + +val pp : Format.formatter -> t -> unit + +val pp_info : Format.formatter -> info -> unit + +val pp_kind : Format.formatter -> kind -> unit + +(** [reset period ~start_position] increment the index by one and set the kind + to Proposal which is the period kind that start the voting + process. [start_position] is the level at wich this voting_period started. +*) +val reset : t -> start_position:Int32.t -> t + +(** [succ period ~start_position] increment the index by one and set the kind to + its successor. [start_position] is the level at which this voting_period + started. *) +val succ : t -> start_position:Int32.t -> t + +val position_since : Level_repr.t -> t -> Int32.t + +val remaining_blocks : + Level_repr.t -> t -> blocks_per_voting_period:Int32.t -> Int32.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_storage.ml b/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_storage.ml new file mode 100644 index 0000000000000000000000000000000000000000..6206c42a5ee3b710366500a97c5db37c66fd5f0e --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_storage.ml @@ -0,0 +1,189 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* + The shell uses the convention that a context at level n is the resulting + context of the application of block n. + Therefore when using an RPC on the last level of a voting period, the context + that is inspected is the resulting one. + + However [Amendment.may_start_new_voting_period] is run at the end of voting + period and it has to prepare the context for validating operations of the next + period. This causes the counter-intuitive result that the info returned by RPCs + at last level of a voting period mention data of the next voting period. + + For example, when validating the last block of a proposal period at level n + we have: + - Input context: + + voting_period = { kind = Proposal; + index = i; + start_position = n - blocks_per_voting_period} + + - position = n - start_position = blocks_per_voting_period + - remaining = blocks_per_voting_period - (position + 1) = 0 + + - Output context: + + voting_period = { kind = Testing_vote; + index = i + 1; + start_position = n + 1} + + Now if we calculate position and remaining in the voting period we get + strange results: + - position = n - (n + 1) = -1 + - remaining = blocks_per_voting_period + + In order to have the correct value for the RPCs a fix has been applied in + [voting_service] by calling a specific function + [voting_period_storage.get_rpc_fixed_current_info]. + + This odd behaviour could be fixed if [Amendment.may_start_new_voting_period] + was called when we start validating a block instead that at the end. + This should be carefully done because the voting period listing depends on + the rolls and it might break some invariant. + + When this is implemented one should: + - remove the function [voting_period_storage.get_rpc_fixed_current_info] + - edit the function [reset_current] and [inc_current] to use the + current level and not the next one. + - remove the storage for pred_kind + - make Voting_period_repr.t abstract + + You can also look at the MR description here: + https://gitlab.com/metastatedev/tezos/-/merge_requests/333 + *) + +let set_current = Storage.Vote.Current_period.set + +let get_current = Storage.Vote.Current_period.get + +let init = Storage.Vote.Current_period.init + +let init_first_period ctxt ~start_position = + init ctxt @@ Voting_period_repr.root ~start_position + >>=? fun ctxt -> + Storage.Vote.Pred_period_kind.init ctxt Voting_period_repr.Proposal + +let common ctxt = + get_current ctxt + >>=? fun current_period -> + Storage.Vote.Pred_period_kind.set ctxt current_period.kind + >|=? fun ctxt -> + let start_position = + (* because we are preparing the voting period for the next block we need to + use the next level. *) + Int32.succ (Level_storage.current ctxt).level_position + in + (ctxt, current_period, start_position) + +let reset ctxt = + common ctxt + >>=? fun (ctxt, current_period, start_position) -> + Voting_period_repr.reset current_period ~start_position |> set_current ctxt + +let succ ctxt = + common ctxt + >>=? fun (ctxt, current_period, start_position) -> + Voting_period_repr.succ current_period ~start_position |> set_current ctxt + +let get_current_kind ctxt = get_current ctxt >|=? fun {kind; _} -> kind + +let get_current_info ctxt = + get_current ctxt + >|=? fun voting_period -> + let blocks_per_voting_period = + Constants_storage.blocks_per_voting_period ctxt + in + let level = Level_storage.current ctxt in + let position = Voting_period_repr.position_since level voting_period in + let remaining = + Voting_period_repr.remaining_blocks + level + voting_period + blocks_per_voting_period + in + Voting_period_repr.{voting_period; position; remaining} + +let get_current_remaining ctxt = + get_current ctxt + >|=? fun voting_period -> + let blocks_per_voting_period = + Constants_storage.blocks_per_voting_period ctxt + in + Voting_period_repr.remaining_blocks + (Level_storage.current ctxt) + voting_period + blocks_per_voting_period + +let is_last_block ctxt = + get_current_remaining ctxt + >|=? fun remaining -> Compare.Int32.(remaining = 0l) + +let get_rpc_fixed_current_info ctxt = + get_current_info ctxt + >>=? fun ({voting_period; position; _} as voting_period_info) -> + if Compare.Int32.(position = Int32.minus_one) then + let level = Level_storage.current ctxt in + let blocks_per_voting_period = + Constants_storage.blocks_per_voting_period ctxt + in + Storage.Vote.Pred_period_kind.get ctxt + >|=? fun pred_kind -> + let voting_period : Voting_period_repr.t = + { + index = Int32.pred voting_period.index; + kind = pred_kind; + start_position = + Int32.(sub voting_period.start_position blocks_per_voting_period); + } + in + let position = Voting_period_repr.position_since level voting_period in + let remaining = + Voting_period_repr.remaining_blocks + level + voting_period + ~blocks_per_voting_period + in + ({voting_period; remaining; position} : Voting_period_repr.info) + else return voting_period_info + +let get_rpc_fixed_succ_info ctxt = + get_current ctxt + >|=? fun voting_period -> + let blocks_per_voting_period = + Constants_storage.blocks_per_voting_period ctxt + in + let level = + Level_storage.from_raw ctxt ~offset:1l (Level_storage.current ctxt).level + in + let position = Voting_period_repr.position_since level voting_period in + let remaining = + Voting_period_repr.remaining_blocks + level + voting_period + blocks_per_voting_period + in + Voting_period_repr.{voting_period; position; remaining} diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_storage.mli b/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_storage.mli new file mode 100644 index 0000000000000000000000000000000000000000..b96c33e88e7b28c4b6943601373b3a138460e2ee --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/voting_period_storage.mli @@ -0,0 +1,70 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Metastate AG *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +val init : + Raw_context.t -> Voting_period_repr.t -> Raw_context.t tzresult Lwt.t + +(** Sets the initial period to [{voting_period = root; kind = Proposal; + start_position}]. *) +val init_first_period : + Raw_context.t -> start_position:Int32.t -> Raw_context.t tzresult Lwt.t + +(** Increment the index by one and set the kind to Proposal. *) +val reset : Raw_context.t -> Raw_context.t tzresult Lwt.t + +(** Increment the index by one and set the kind to its successor. *) +val succ : Raw_context.t -> Raw_context.t tzresult Lwt.t + +val get_current : Raw_context.t -> Voting_period_repr.t tzresult Lwt.t + +val get_current_kind : Raw_context.t -> Voting_period_repr.kind tzresult Lwt.t + +(** Returns true if the context level is the last of current voting period. *) +val is_last_block : Raw_context.t -> bool tzresult Lwt.t + +(* Given the issue explained in voting_period_storage.ml this function behaves + currectly during the validation of a block but returns inconsistent info if + called after the finalization of the block. + For this reason when used by the RPC `votes/current_period_kind` gives an + unintuitive result: after the validation of the last block of a voting period + (e.g. proposal), it returns the kind of the next period (e.g. testing_vote). + To fix this, at least part of the current vote finalization should be moved + at the beginning of the block validation. + For retro-compatibility, we keep this function but we provide two new fixed + functions to reply correctly to RPCs [get_rpc_fixed_current_info] and + [get_rpc_fixed_succ_info]. *) +val get_current_info : Raw_context.t -> Voting_period_repr.info tzresult Lwt.t + +(* In order to avoid the problem of `get_current_info` explained above, this + function provides the corrent behavior for the new RPC `votes/current_period`. +*) +val get_rpc_fixed_current_info : + Raw_context.t -> Voting_period_repr.info tzresult Lwt.t + +(* In order to avoid the problem of `get_current_info` explained above, this + function provides the corrent behavior for the new RPC `votes/successor_period`. +*) +val get_rpc_fixed_succ_info : + Raw_context.t -> Voting_period_repr.info tzresult Lwt.t diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/voting_services.ml b/src/proto_008_PtEdo2Zk/lib_protocol/voting_services.ml new file mode 100644 index 0000000000000000000000000000000000000000..8312fb33b9cb3053ce10ec6911f867ec4edbb902 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/voting_services.ml @@ -0,0 +1,164 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +module S = struct + let path = RPC_path.(open_root / "votes") + + let ballots = + RPC_service.get_service + ~description:"Sum of ballots casted so far during a voting period." + ~query:RPC_query.empty + ~output:Vote.ballots_encoding + RPC_path.(path / "ballots") + + let ballot_list = + RPC_service.get_service + ~description:"Ballots casted so far during a voting period." + ~query:RPC_query.empty + ~output: + Data_encoding.( + list + (obj2 + (req "pkh" Signature.Public_key_hash.encoding) + (req "ballot" Vote.ballot_encoding))) + RPC_path.(path / "ballot_list") + + let current_period = + RPC_service.get_service + ~description: + "Returns the voting period (index, kind, starting position) and \ + related information (position, remaining) of the interrogated block." + ~query:RPC_query.empty + ~output:Voting_period.info_encoding + RPC_path.(path / "current_period") + + let successor_period = + RPC_service.get_service + ~description: + "Returns the voting period (index, kind, starting position) and \ + related information (position, remaining) of the next block." + ~query:RPC_query.empty + ~output:Voting_period.info_encoding + RPC_path.(path / "successor_period") + + let current_period_kind_deprecated = + RPC_service.get_service + ~description: + "Current period kind. This RPC is DEPRECATED: use \ + `../votes/current_period` RPC instead." + ~query:RPC_query.empty + ~output:Voting_period.kind_encoding + RPC_path.(path / "current_period_kind") + + let current_quorum = + RPC_service.get_service + ~description:"Current expected quorum." + ~query:RPC_query.empty + ~output:Data_encoding.int32 + RPC_path.(path / "current_quorum") + + let listings = + RPC_service.get_service + ~description: + "List of delegates with their voting weight, in number of rolls." + ~query:RPC_query.empty + ~output:Vote.listings_encoding + RPC_path.(path / "listings") + + let proposals = + RPC_service.get_service + ~description:"List of proposals with number of supporters." + ~query:RPC_query.empty + ~output:(Protocol_hash.Map.encoding Data_encoding.int32) + RPC_path.(path / "proposals") + + let current_proposal = + RPC_service.get_service + ~description:"Current proposal under evaluation." + ~query:RPC_query.empty + ~output:(Data_encoding.option Protocol_hash.encoding) + RPC_path.(path / "current_proposal") + + let total_voting_power = + RPC_service.get_service + ~description: + "Total number of rolls for the delegates in the voting listings." + ~query:RPC_query.empty + ~output:Data_encoding.int32 + RPC_path.(path / "total_voting_power") +end + +let register () = + let open Services_registration in + register0 S.ballots (fun ctxt () () -> Vote.get_ballots ctxt) ; + register0 S.ballot_list (fun ctxt () () -> Vote.get_ballot_list ctxt >|= ok) ; + register0 S.current_period (fun ctxt () () -> + Voting_period.get_rpc_fixed_current_info ctxt) ; + register0 S.successor_period (fun ctxt () () -> + Voting_period.get_rpc_fixed_succ_info ctxt) ; + register0 S.current_period_kind_deprecated (fun ctxt () () -> + Voting_period.get_current_info ctxt + >|=? fun {voting_period; _} -> voting_period.kind) ; + register0 S.current_quorum (fun ctxt () () -> Vote.get_current_quorum ctxt) ; + register0 S.proposals (fun ctxt () () -> Vote.get_proposals ctxt) ; + register0 S.listings (fun ctxt () () -> Vote.get_listings ctxt >|= ok) ; + register0 S.current_proposal (fun ctxt () () -> + (* this would be better implemented using get_option in get_current_proposal *) + Vote.get_current_proposal ctxt + >|= function + | Ok p -> + ok_some p + | Error (Raw_context.Storage_error (Missing_key _) :: _) -> + ok_none + | Error _ as e -> + e) ; + register0 S.total_voting_power (fun ctxt () () -> + Vote.get_total_voting_power_free ctxt) + +let ballots ctxt block = RPC_context.make_call0 S.ballots ctxt block () () + +let ballot_list ctxt block = + RPC_context.make_call0 S.ballot_list ctxt block () () + +let current_period ctxt block = + RPC_context.make_call0 S.current_period ctxt block () () + +let successor_period ctxt block = + RPC_context.make_call0 S.successor_period ctxt block () () + +let current_quorum ctxt block = + RPC_context.make_call0 S.current_quorum ctxt block () () + +let listings ctxt block = RPC_context.make_call0 S.listings ctxt block () () + +let proposals ctxt block = RPC_context.make_call0 S.proposals ctxt block () () + +let current_proposal ctxt block = + RPC_context.make_call0 S.current_proposal ctxt block () () + +let total_voting_power ctxt block = + RPC_context.make_call0 S.total_voting_power ctxt block () () diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/voting_services.mli b/src/proto_008_PtEdo2Zk/lib_protocol/voting_services.mli new file mode 100644 index 0000000000000000000000000000000000000000..d56157aa6c1ae1631fab288debcdeb22c83373e0 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_protocol/voting_services.mli @@ -0,0 +1,60 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Alpha_context + +val ballots : 'a #RPC_context.simple -> 'a -> Vote.ballots shell_tzresult Lwt.t + +val ballot_list : + 'a #RPC_context.simple -> + 'a -> + (Signature.Public_key_hash.t * Vote.ballot) list shell_tzresult Lwt.t + +val current_period : + 'a #RPC_context.simple -> 'a -> Voting_period.info shell_tzresult Lwt.t + +val successor_period : + 'a #RPC_context.simple -> 'a -> Voting_period.info shell_tzresult Lwt.t + +val current_quorum : + 'a #RPC_context.simple -> 'a -> Int32.t shell_tzresult Lwt.t + +val listings : + 'a #RPC_context.simple -> + 'a -> + (Signature.Public_key_hash.t * int32) list shell_tzresult Lwt.t + +val proposals : + 'a #RPC_context.simple -> + 'a -> + Int32.t Protocol_hash.Map.t shell_tzresult Lwt.t + +val current_proposal : + 'a #RPC_context.simple -> 'a -> Protocol_hash.t option shell_tzresult Lwt.t + +val register : unit -> unit + +val total_voting_power : + 'a #RPC_context.simple -> 'a -> Int32.t shell_tzresult Lwt.t diff --git a/src/proto_008_PtEdoTez/lib_client_sapling/dune b/src/proto_008_PtEdoTez/lib_client_sapling/dune deleted file mode 100644 index 48569940d88567a36c2150cd9993cf31c865fc05..0000000000000000000000000000000000000000 --- a/src/proto_008_PtEdoTez/lib_client_sapling/dune +++ /dev/null @@ -1,23 +0,0 @@ -(library - (name tezos_client_sapling_008_PtEdoTez) - (public_name tezos-client-sapling-008-PtEdoTez) - (libraries tezos-base - tezos-crypto - tezos-client-base - tezos-signer-backends - tezos-client-008-PtEdoTez - tezos-client-008-PtEdoTez-commands - tezos-protocol-008-PtEdoTez) - (library_flags (:standard -linkall)) - (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_stdlib_unix - -open Tezos_client_base - -open Tezos_client_008_PtEdoTez - -open Tezos_client_008_PtEdoTez_commands - -open Tezos_protocol_008_PtEdoTez - -open Tezos_protocol_environment_008_PtEdoTez))) - -(alias - (name runtest_lint) - (deps (glob_files *.ml{,i})) - (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/proto_008_PtEdoTez/lib_mempool/dune b/src/proto_008_PtEdoTez/lib_mempool/dune deleted file mode 100644 index 487e93ce0b8183c611e515071e7a010f3027b937..0000000000000000000000000000000000000000 --- a/src/proto_008_PtEdoTez/lib_mempool/dune +++ /dev/null @@ -1,14 +0,0 @@ -(library - (name tezos_mempool_008_PtEdoTez) - (public_name tezos-mempool-008-PtEdoTez) - (libraries tezos-base - tezos-embedded-protocol-008-PtEdoTez - tezos-protocol-008-PtEdoTez) - (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_embedded_protocol_008_PtEdoTez - -open Tezos_protocol_008_PtEdoTez))) - -(rule - (alias runtest_lint) - (deps (glob_files *.ml{,i})) - (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/proto_008_PtEdoTez/lib_mempool/filter.ml b/src/proto_008_PtEdoTez/lib_mempool/filter.ml deleted file mode 100644 index 2be62780706129518b13e181044c6eb10b25e809..0000000000000000000000000000000000000000 --- a/src/proto_008_PtEdoTez/lib_mempool/filter.ml +++ /dev/null @@ -1,224 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Nomadic Development. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context -module Proto = Registerer.Registered - -type nanotez = Q.t - -let nanotez_enc : nanotez Data_encoding.t = - let open Data_encoding in - def - "nanotez" - ~title:"A thousandth of a mutez" - ~description:"One thousand nanotez make a mutez (1 tez = 1e9 nanotez)" - (conv - (fun q -> (q.Q.num, q.Q.den)) - (fun (num, den) -> {Q.num; den}) - (tup2 z z)) - -type config = { - minimal_fees : Tez.t; - minimal_nanotez_per_gas_unit : nanotez; - minimal_nanotez_per_byte : nanotez; - allow_script_failure : bool; -} - -let default_minimal_fees = - match Tez.of_mutez 100L with None -> assert false | Some t -> t - -let default_minimal_nanotez_per_gas_unit = Q.of_int 100 - -let default_minimal_nanotez_per_byte = Q.of_int 1000 - -let config_encoding : config Data_encoding.t = - let open Data_encoding in - conv - (fun { minimal_fees; - minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte; - allow_script_failure } -> - ( minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - allow_script_failure )) - (fun ( minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - allow_script_failure ) -> - { - minimal_fees; - minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte; - allow_script_failure; - }) - (obj4 - (dft "minimal_fees" Tez.encoding default_minimal_fees) - (dft - "minimal_nanotez_per_gas_unit" - nanotez_enc - default_minimal_nanotez_per_gas_unit) - (dft - "minimal_nanotez_per_byte" - nanotez_enc - default_minimal_nanotez_per_byte) - (dft "allow_script_failure" bool true)) - -let default_config = - { - minimal_fees = default_minimal_fees; - minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte = default_minimal_nanotez_per_byte; - allow_script_failure = true; - } - -let get_manager_operation_gas_and_fee contents = - let open Operation in - let l = to_list (Contents_list contents) in - List.fold_left - (fun acc -> function - | Contents (Manager_operation {fee; gas_limit; _}) -> ( - match acc with - | Error _ as e -> - e - | Ok (total_fee, total_gas) -> ( - match Tez.(total_fee +? fee) with - | Ok total_fee -> - Ok (total_fee, Gas.Arith.add total_gas gas_limit) - | Error _ as e -> - e ) ) | _ -> acc) - (Ok (Tez.zero, Gas.Arith.zero)) - l - -let pre_filter_manager : - type t. config -> t Kind.manager contents_list -> int -> bool = - fun config op size -> - match get_manager_operation_gas_and_fee op with - | Error _ -> - false - | Ok (fee, gas) -> - let fees_in_nanotez = - Q.mul (Q.of_int64 (Tez.to_mutez fee)) (Q.of_int 1000) - in - let minimal_fees_in_nanotez = - Q.mul (Q.of_int64 (Tez.to_mutez config.minimal_fees)) (Q.of_int 1000) - in - let minimal_fees_for_gas_in_nanotez = - Q.mul - config.minimal_nanotez_per_gas_unit - (Q.of_bigint @@ Gas.Arith.integral_to_z gas) - in - let minimal_fees_for_size_in_nanotez = - Q.mul config.minimal_nanotez_per_byte (Q.of_int size) - in - Q.compare - fees_in_nanotez - (Q.add - minimal_fees_in_nanotez - (Q.add - minimal_fees_for_gas_in_nanotez - minimal_fees_for_size_in_nanotez)) - >= 0 - -let pre_filter config - (Operation_data {contents; _} as op : Operation.packed_protocol_data) = - let bytes = - Data_encoding.Binary.fixed_length_exn - Tezos_base.Operation.shell_header_encoding - + Data_encoding.Binary.length Operation.protocol_data_encoding op - in - match contents with - | Single (Endorsement _) -> - true - | Single (Seed_nonce_revelation _) -> - true - | Single (Double_endorsement_evidence _) -> - true - | Single (Double_baking_evidence _) -> - true - | Single (Activate_account _) -> - true - | Single (Proposals _) -> - true - | Single (Ballot _) -> - true - | Single (Manager_operation _) as op -> - pre_filter_manager config op bytes - | Cons (Manager_operation _, _) as op -> - pre_filter_manager config op bytes - -open Apply_results - -let rec post_filter_manager : - type t. - Alpha_context.t -> - t Kind.manager contents_result_list -> - config -> - bool Lwt.t = - fun ctxt op config -> - match op with - | Single_result (Manager_operation_result {operation_result; _}) -> ( - match operation_result with - | Applied _ -> - Lwt.return_true - | Skipped _ | Failed _ | Backtracked _ -> - Lwt.return config.allow_script_failure ) - | Cons_result (Manager_operation_result res, rest) -> ( - post_filter_manager - ctxt - (Single_result (Manager_operation_result res)) - config - >>= function - | false -> - Lwt.return_false - | true -> - post_filter_manager ctxt rest config ) - -let post_filter config ~validation_state_before:_ - ~validation_state_after:({ctxt; _} : validation_state) (_op, receipt) = - match receipt with - | No_operation_metadata -> - assert false (* only for multipass validator *) - | Operation_metadata {contents} -> ( - match contents with - | Single_result (Endorsement_result _) -> - Lwt.return_true - | Single_result (Seed_nonce_revelation_result _) -> - Lwt.return_true - | Single_result (Double_endorsement_evidence_result _) -> - Lwt.return_true - | Single_result (Double_baking_evidence_result _) -> - Lwt.return_true - | Single_result (Activate_account_result _) -> - Lwt.return_true - | Single_result Proposals_result -> - Lwt.return_true - | Single_result Ballot_result -> - Lwt.return_true - | Single_result (Manager_operation_result _) as op -> - post_filter_manager ctxt op config - | Cons_result (Manager_operation_result _, _) as op -> - post_filter_manager ctxt op config ) diff --git a/src/proto_008_PtEdoTez/lib_protocol/dune.inc b/src/proto_008_PtEdoTez/lib_protocol/dune.inc index 212bb5641bb410ee2cf1d26a4f449ac84b4d70eb..4eb08a6ec9ab3bdebf7013c0ef597d235badfcf7 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/dune.inc +++ b/src/proto_008_PtEdoTez/lib_protocol/dune.inc @@ -285,7 +285,7 @@ include Tezos_raw_protocol_008_PtEdoTez.Main (libraries tezos_protocol_environment_008_PtEdoTez) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_008_PtEdoTez__Environment -open Pervasives @@ -380,19 +380,19 @@ include Tezos_raw_protocol_008_PtEdoTez.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_008_PtEdoTez) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_008_PtEdoTez_functor) - (public_name tezos-protocol-008-PtEdoTez.functor) + (public_name tezos-protocol-functor-008-PtEdoTez) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_008_PtEdoTez) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-008-PtEdoTez.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -404,7 +404,7 @@ include Tezos_raw_protocol_008_PtEdoTez.Main (libraries tezos-protocol-008-PtEdoTez tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) @@ -488,7 +488,7 @@ include Tezos_raw_protocol_008_PtEdoTez.Main alpha_services.mli alpha_services.ml main.mli main.ml (:src_dir TEZOS_PROTOCOL)) - (action (run %{bin:tezos-protocol-compiler} -no-hash-check .))) + (action (run %{bin:tezos-protocol-compiler} .))) (rule (alias runtest_sandbox) diff --git a/src/proto_008_PtEdoTez/lib_protocol/tezos-embedded-protocol-008-PtEdoTez.opam b/src/proto_008_PtEdoTez/lib_protocol/tezos-embedded-protocol-008-PtEdoTez.opam index ddf370dc0f8e98410dbc7f00a3ea85706433af50..eda54364e1225acc0e2f270a0bf064af4c30e897 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/tezos-embedded-protocol-008-PtEdoTez.opam +++ b/src/proto_008_PtEdoTez/lib_protocol/tezos-embedded-protocol-008-PtEdoTez.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-008-PtEdoTez" "tezos-protocol-compiler" "tezos-protocol-updater" @@ -22,6 +20,5 @@ build: [ "008_PtEdoTez" ] ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] synopsis: "Tezos/Protocol: economic-protocol definition, embedded in `tezos-node`" diff --git a/src/proto_008_PtEdoTez/lib_protocol/tezos-protocol-008-PtEdoTez.opam b/src/proto_008_PtEdoTez/lib_protocol/tezos-protocol-008-PtEdoTez.opam index 5f41cc6d319f0e6ee58a7733ae69a65a6b04c51c..92d0ded9245ee9124a3f58965d51ea9e08748e92 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/tezos-protocol-008-PtEdoTez.opam +++ b/src/proto_008_PtEdoTez/lib_protocol/tezos-protocol-008-PtEdoTez.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" ] build: [ @@ -20,6 +18,5 @@ build: [ "008_PtEdoTez" ] ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] synopsis: "Tezos/Protocol: economic-protocol definition" diff --git a/src/proto_008_PtEdoTez/lib_protocol/tezos-protocol-functor-008-PtEdoTez.opam b/src/proto_008_PtEdoTez/lib_protocol/tezos-protocol-functor-008-PtEdoTez.opam new file mode 100644 index 0000000000000000000000000000000000000000..906b6d1080ab54b1c0658b20db101755476fb3a4 --- /dev/null +++ b/src/proto_008_PtEdoTez/lib_protocol/tezos-protocol-functor-008-PtEdoTez.opam @@ -0,0 +1,23 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-008-PtEdoTez" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "008_PtEdoTez" + ] + ["dune" "build" "-p" name "-j" jobs] +] +synopsis: "Tezos/Protocol: economic-protocol definition parameterized by its environment implementation" diff --git a/src/proto_alpha/lib_mempool/dune b/src/proto_alpha/lib_mempool/dune deleted file mode 100644 index 8b07c25bf98e194a1d4ef90fc181470ef4fa364b..0000000000000000000000000000000000000000 --- a/src/proto_alpha/lib_mempool/dune +++ /dev/null @@ -1,14 +0,0 @@ -(library - (name tezos_mempool_alpha) - (public_name tezos-mempool-alpha) - (libraries tezos-base - tezos-embedded-protocol-alpha - tezos-protocol-alpha) - (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_embedded_protocol_alpha - -open Tezos_protocol_alpha))) - -(rule - (alias runtest_lint) - (deps (glob_files *.ml{,i})) - (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/proto_alpha/lib_mempool/filter.ml b/src/proto_alpha/lib_mempool/filter.ml deleted file mode 100644 index 2be62780706129518b13e181044c6eb10b25e809..0000000000000000000000000000000000000000 --- a/src/proto_alpha/lib_mempool/filter.ml +++ /dev/null @@ -1,224 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Nomadic Development. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context -module Proto = Registerer.Registered - -type nanotez = Q.t - -let nanotez_enc : nanotez Data_encoding.t = - let open Data_encoding in - def - "nanotez" - ~title:"A thousandth of a mutez" - ~description:"One thousand nanotez make a mutez (1 tez = 1e9 nanotez)" - (conv - (fun q -> (q.Q.num, q.Q.den)) - (fun (num, den) -> {Q.num; den}) - (tup2 z z)) - -type config = { - minimal_fees : Tez.t; - minimal_nanotez_per_gas_unit : nanotez; - minimal_nanotez_per_byte : nanotez; - allow_script_failure : bool; -} - -let default_minimal_fees = - match Tez.of_mutez 100L with None -> assert false | Some t -> t - -let default_minimal_nanotez_per_gas_unit = Q.of_int 100 - -let default_minimal_nanotez_per_byte = Q.of_int 1000 - -let config_encoding : config Data_encoding.t = - let open Data_encoding in - conv - (fun { minimal_fees; - minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte; - allow_script_failure } -> - ( minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - allow_script_failure )) - (fun ( minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - allow_script_failure ) -> - { - minimal_fees; - minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte; - allow_script_failure; - }) - (obj4 - (dft "minimal_fees" Tez.encoding default_minimal_fees) - (dft - "minimal_nanotez_per_gas_unit" - nanotez_enc - default_minimal_nanotez_per_gas_unit) - (dft - "minimal_nanotez_per_byte" - nanotez_enc - default_minimal_nanotez_per_byte) - (dft "allow_script_failure" bool true)) - -let default_config = - { - minimal_fees = default_minimal_fees; - minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte = default_minimal_nanotez_per_byte; - allow_script_failure = true; - } - -let get_manager_operation_gas_and_fee contents = - let open Operation in - let l = to_list (Contents_list contents) in - List.fold_left - (fun acc -> function - | Contents (Manager_operation {fee; gas_limit; _}) -> ( - match acc with - | Error _ as e -> - e - | Ok (total_fee, total_gas) -> ( - match Tez.(total_fee +? fee) with - | Ok total_fee -> - Ok (total_fee, Gas.Arith.add total_gas gas_limit) - | Error _ as e -> - e ) ) | _ -> acc) - (Ok (Tez.zero, Gas.Arith.zero)) - l - -let pre_filter_manager : - type t. config -> t Kind.manager contents_list -> int -> bool = - fun config op size -> - match get_manager_operation_gas_and_fee op with - | Error _ -> - false - | Ok (fee, gas) -> - let fees_in_nanotez = - Q.mul (Q.of_int64 (Tez.to_mutez fee)) (Q.of_int 1000) - in - let minimal_fees_in_nanotez = - Q.mul (Q.of_int64 (Tez.to_mutez config.minimal_fees)) (Q.of_int 1000) - in - let minimal_fees_for_gas_in_nanotez = - Q.mul - config.minimal_nanotez_per_gas_unit - (Q.of_bigint @@ Gas.Arith.integral_to_z gas) - in - let minimal_fees_for_size_in_nanotez = - Q.mul config.minimal_nanotez_per_byte (Q.of_int size) - in - Q.compare - fees_in_nanotez - (Q.add - minimal_fees_in_nanotez - (Q.add - minimal_fees_for_gas_in_nanotez - minimal_fees_for_size_in_nanotez)) - >= 0 - -let pre_filter config - (Operation_data {contents; _} as op : Operation.packed_protocol_data) = - let bytes = - Data_encoding.Binary.fixed_length_exn - Tezos_base.Operation.shell_header_encoding - + Data_encoding.Binary.length Operation.protocol_data_encoding op - in - match contents with - | Single (Endorsement _) -> - true - | Single (Seed_nonce_revelation _) -> - true - | Single (Double_endorsement_evidence _) -> - true - | Single (Double_baking_evidence _) -> - true - | Single (Activate_account _) -> - true - | Single (Proposals _) -> - true - | Single (Ballot _) -> - true - | Single (Manager_operation _) as op -> - pre_filter_manager config op bytes - | Cons (Manager_operation _, _) as op -> - pre_filter_manager config op bytes - -open Apply_results - -let rec post_filter_manager : - type t. - Alpha_context.t -> - t Kind.manager contents_result_list -> - config -> - bool Lwt.t = - fun ctxt op config -> - match op with - | Single_result (Manager_operation_result {operation_result; _}) -> ( - match operation_result with - | Applied _ -> - Lwt.return_true - | Skipped _ | Failed _ | Backtracked _ -> - Lwt.return config.allow_script_failure ) - | Cons_result (Manager_operation_result res, rest) -> ( - post_filter_manager - ctxt - (Single_result (Manager_operation_result res)) - config - >>= function - | false -> - Lwt.return_false - | true -> - post_filter_manager ctxt rest config ) - -let post_filter config ~validation_state_before:_ - ~validation_state_after:({ctxt; _} : validation_state) (_op, receipt) = - match receipt with - | No_operation_metadata -> - assert false (* only for multipass validator *) - | Operation_metadata {contents} -> ( - match contents with - | Single_result (Endorsement_result _) -> - Lwt.return_true - | Single_result (Seed_nonce_revelation_result _) -> - Lwt.return_true - | Single_result (Double_endorsement_evidence_result _) -> - Lwt.return_true - | Single_result (Double_baking_evidence_result _) -> - Lwt.return_true - | Single_result (Activate_account_result _) -> - Lwt.return_true - | Single_result Proposals_result -> - Lwt.return_true - | Single_result Ballot_result -> - Lwt.return_true - | Single_result (Manager_operation_result _) as op -> - post_filter_manager ctxt op config - | Cons_result (Manager_operation_result _, _) as op -> - post_filter_manager ctxt op config ) diff --git a/src/proto_alpha/lib_protocol/dune.inc b/src/proto_alpha/lib_protocol/dune.inc index bdc4c1689731f8b6f1701f9c0d4082605b91bdc1..9924dc908f872289f7cae20d0c604b1ee159946b 100644 --- a/src/proto_alpha/lib_protocol/dune.inc +++ b/src/proto_alpha/lib_protocol/dune.inc @@ -270,7 +270,7 @@ include Tezos_raw_protocol_alpha.Main (libraries tezos_protocol_environment_alpha) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_alpha__Environment -open Pervasives @@ -360,19 +360,19 @@ include Tezos_raw_protocol_alpha.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_alpha) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_alpha_functor) - (public_name tezos-protocol-alpha.functor) + (public_name tezos-protocol-functor-alpha) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_alpha) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-alpha.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -384,7 +384,7 @@ include Tezos_raw_protocol_alpha.Main (libraries tezos-protocol-alpha tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_alpha/lib_protocol/test/main.ml b/src/proto_alpha/lib_protocol/test/main.ml index 9b7bd926818e94eeffda40634f72e58715d8c5a9..eb9953d58b1811b59cf96b96409a573d2549b670 100644 --- a/src/proto_alpha/lib_protocol/test/main.ml +++ b/src/proto_alpha/lib_protocol/test/main.ml @@ -44,5 +44,6 @@ let () = ("typechecking", Typechecking.tests); ("gas properties", Gas_properties.tests); ("fixed point computation", Fixed_point.tests); - ("gas cost functions", Gas_costs.tests) ] + ("gas cost functions", Gas_costs.tests); + ("opcodes", Michelson_opcodes.tests) ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/michelson_opcodes.ml b/src/proto_alpha/lib_protocol/test/michelson_opcodes.ml new file mode 100644 index 0000000000000000000000000000000000000000..50e67ef86a339a2cef3bea65c50fe00e173dbcbe --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/michelson_opcodes.ml @@ -0,0 +1,87 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + + +let test_contracts_path = "../../../../../../tests_python/contracts/opcodes/" (* Working directory should be `tezos/_build/default/src/proto_alpha/lib_protocol/test` *) + +let add_badly () = + let contract = {|{ +parameter unit; +storage unit; +code + { + CAR; + + PUSH int 2; PUSH int 2; ADD; PUSH int 5; ASSERT_CMPEQ; + + # Offset a timestamp by 60 seconds + PUSH int 60; PUSH timestamp "2019-09-09T12:08:37Z"; ADD; + PUSH timestamp "2019-09-09T12:09:37Z"; ASSERT_CMPEQ; + + PUSH timestamp "2019-09-09T12:08:37Z"; PUSH int 60; ADD; + PUSH timestamp "2019-09-09T12:09:37Z"; ASSERT_CMPEQ; + + PUSH mutez 1000; PUSH mutez 1000; ADD; + PUSH mutez 2000; ASSERT_CMPEQ; + + NIL operation; + PAIR; + } +}|} in + (* Run and compare against desired output *) + Interpretation.test_context () + >>=? fun ctx -> + Interpretation.run_script + ctx + contract + ~storage:"Unit" + ~parameter:"Unit" + () + >>= function + | Ok _ -> + (* The real assertion demonstrating that the addition was correct is in the contract itself, via ASSERT_CMPEQ *) + Alcotest.failf "ASSERT_CMPEQ failed to cause the contract to evaluate to an error" + | Error _ -> + return_unit + +let test_contract_runs_without_error filename () = + Interpretation.test_context () + >>=? fun ctx -> + let contract_unfixed = Typechecking.read_file (Filename.concat test_contracts_path filename) in + let contract = String.concat "" ["{"; contract_unfixed; "}"] in + Interpretation.run_script + ctx + contract + ~storage:"Unit" + ~parameter:"Unit" + () + >>= function + | Ok _ -> + (* The real assertion demonstrating that the addition was correct is in the contract itself, via ASSERT_CMPEQ *) + return_unit + | Error errs -> + Alcotest.failf "Unexpected error: %a" Error_monad.pp_print_error errs + +let tests = [Test.tztest "ASSERT_CMPEQ" `Quick add_badly; Test.tztest "add" `Quick (test_contract_runs_without_error "add.tz")] \ No newline at end of file diff --git a/src/proto_alpha/lib_protocol/tezos-embedded-protocol-alpha.opam b/src/proto_alpha/lib_protocol/tezos-embedded-protocol-alpha.opam index 0f3de2dcb3a36873975b4c01a752ea80f59a0aec..e898d2585f02fb34c0177be6bccd2ef2c2054151 100644 --- a/src/proto_alpha/lib_protocol/tezos-embedded-protocol-alpha.opam +++ b/src/proto_alpha/lib_protocol/tezos-embedded-protocol-alpha.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-alpha" "tezos-protocol-compiler" "tezos-protocol-updater" diff --git a/src/proto_alpha/lib_protocol/tezos-protocol-alpha-tests.opam b/src/proto_alpha/lib_protocol/tezos-protocol-alpha-tests.opam index 56c945860b452ce523b41b526b97af17af9cad38..d1264b69911c59890f350fb5c8536af5dd5267cf 100644 --- a/src/proto_alpha/lib_protocol/tezos-protocol-alpha-tests.opam +++ b/src/proto_alpha/lib_protocol/tezos-protocol-alpha-tests.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" "alcotest-lwt" { with-test & >= "1.1.0" } "tezos-alpha-test-helpers" { with-test } diff --git a/src/proto_alpha/lib_protocol/tezos-protocol-alpha.opam b/src/proto_alpha/lib_protocol/tezos-protocol-alpha.opam index de6f47137667e8e62461e1cdc25d15d126c0afde..f185b0fc7626d1672cb8d19f6021c7ffd0a4fb4c 100644 --- a/src/proto_alpha/lib_protocol/tezos-protocol-alpha.opam +++ b/src/proto_alpha/lib_protocol/tezos-protocol-alpha.opam @@ -6,9 +6,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } - "tezos-base" "tezos-protocol-compiler" ] build: [ diff --git a/src/proto_alpha/lib_protocol/tezos-protocol-functor-alpha.opam b/src/proto_alpha/lib_protocol/tezos-protocol-functor-alpha.opam new file mode 100644 index 0000000000000000000000000000000000000000..c22a21e31097c3e6faedee8273d10f162cd7c939 --- /dev/null +++ b/src/proto_alpha/lib_protocol/tezos-protocol-functor-alpha.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-alpha" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "alpha" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: economic-protocol definition parameterized by its environment implementation" diff --git a/src/proto_demo_counter/lib_protocol/dune.inc b/src/proto_demo_counter/lib_protocol/dune.inc index 742060e4a2db038d67d5f784b1cbb5e4bb903a8a..a23bc4f7f4b7f52e8b3ddc5a03db5ac76fcf5e1e 100644 --- a/src/proto_demo_counter/lib_protocol/dune.inc +++ b/src/proto_demo_counter/lib_protocol/dune.inc @@ -84,7 +84,7 @@ include Tezos_raw_protocol_demo_counter.Main (libraries tezos_protocol_environment_demo_counter) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_demo_counter__Environment -open Pervasives @@ -112,19 +112,19 @@ include Tezos_raw_protocol_demo_counter.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_demo_counter) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_demo_counter_functor) - (public_name tezos-protocol-demo-counter.functor) + (public_name tezos-protocol-functor-demo-counter) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_demo_counter) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-demo-counter.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -136,7 +136,7 @@ include Tezos_raw_protocol_demo_counter.Main (libraries tezos-protocol-demo-counter tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_demo_counter/lib_protocol/tezos-embedded-protocol-demo-counter.opam b/src/proto_demo_counter/lib_protocol/tezos-embedded-protocol-demo-counter.opam index 851a038bdc3845bc4d0c6464fe92ffecb1dfa226..4ffb9678a2d2ddeb606181fb2c5a98c39aa61b17 100644 --- a/src/proto_demo_counter/lib_protocol/tezos-embedded-protocol-demo-counter.opam +++ b/src/proto_demo_counter/lib_protocol/tezos-embedded-protocol-demo-counter.opam @@ -6,7 +6,6 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-protocol-demo-counter" "tezos-protocol-compiler" diff --git a/src/proto_demo_counter/lib_protocol/tezos-protocol-demo-counter.opam b/src/proto_demo_counter/lib_protocol/tezos-protocol-demo-counter.opam index 3a4e58362bee761447d28fc89c682e4d9dcd1536..2f5c5624dbfb0aa083dac2e841a1f5174b57a496 100644 --- a/src/proto_demo_counter/lib_protocol/tezos-protocol-demo-counter.opam +++ b/src/proto_demo_counter/lib_protocol/tezos-protocol-demo-counter.opam @@ -6,7 +6,6 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-protocol-compiler" ] diff --git a/src/proto_demo_counter/lib_protocol/tezos-protocol-functor-demo-counter.opam b/src/proto_demo_counter/lib_protocol/tezos-protocol-functor-demo-counter.opam new file mode 100644 index 0000000000000000000000000000000000000000..98fb27edcdf03ec2ca1e5c7c2dd030203a9b5b6a --- /dev/null +++ b/src/proto_demo_counter/lib_protocol/tezos-protocol-functor-demo-counter.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-demo-counter" + "tezos-protocol-compiler" +] +build: [ + [ "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "demo_counter" ] + [ "dune" "build" "-p" name "-j" jobs ] +] +run-test: [ + [ "dune" "runtest" "-p" name "-j" jobs ] +] +synopsis: "Tezos/Protocol: demo_counter (economic-protocol definition parameterized by its environment implementation)" diff --git a/src/proto_demo_noops/lib_protocol/dune.inc b/src/proto_demo_noops/lib_protocol/dune.inc index 68ab3e80e6d13de48373012ca5c7787798f2938c..5e7f88cc8c530efaeb2bf39686240804c9a37c3f 100644 --- a/src/proto_demo_noops/lib_protocol/dune.inc +++ b/src/proto_demo_noops/lib_protocol/dune.inc @@ -60,7 +60,7 @@ include Tezos_raw_protocol_demo_noops.Main (libraries tezos_protocol_environment_demo_noops) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_demo_noops__Environment -open Pervasives @@ -80,19 +80,19 @@ include Tezos_raw_protocol_demo_noops.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_demo_noops) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_demo_noops_functor) - (public_name tezos-protocol-demo-noops.functor) + (public_name tezos-protocol-functor-demo-noops) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_demo_noops) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-demo-noops.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -104,7 +104,7 @@ include Tezos_raw_protocol_demo_noops.Main (libraries tezos-protocol-demo-noops tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_demo_noops/lib_protocol/tezos-embedded-protocol-demo-noops.opam b/src/proto_demo_noops/lib_protocol/tezos-embedded-protocol-demo-noops.opam index d6e31647c1c771e9372869f0e03ce80cb3486b6a..20f0cb1916870d75a63c1341a8e453ecb9ea832e 100644 --- a/src/proto_demo_noops/lib_protocol/tezos-embedded-protocol-demo-noops.opam +++ b/src/proto_demo_noops/lib_protocol/tezos-embedded-protocol-demo-noops.opam @@ -6,7 +6,6 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-protocol-demo-noops" "tezos-protocol-compiler" diff --git a/src/proto_demo_noops/lib_protocol/tezos-protocol-demo-noops.opam b/src/proto_demo_noops/lib_protocol/tezos-protocol-demo-noops.opam index 398678a68b83fab22833c112c0936952f64f1250..71e006af5558834f1a2131c8c024239344f1cc8f 100644 --- a/src/proto_demo_noops/lib_protocol/tezos-protocol-demo-noops.opam +++ b/src/proto_demo_noops/lib_protocol/tezos-protocol-demo-noops.opam @@ -6,7 +6,6 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-protocol-compiler" ] diff --git a/src/proto_demo_noops/lib_protocol/tezos-protocol-functor-demo-noops.opam b/src/proto_demo_noops/lib_protocol/tezos-protocol-functor-demo-noops.opam new file mode 100644 index 0000000000000000000000000000000000000000..d8396e5dfa8718fd51d30fbecd0ba7eabc99c143 --- /dev/null +++ b/src/proto_demo_noops/lib_protocol/tezos-protocol-functor-demo-noops.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-demo-noops" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "demo_noops" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: demo_noops (economic-protocol definition parameterized by its environment implementation)" diff --git a/src/proto_genesis/lib_protocol/dune.inc b/src/proto_genesis/lib_protocol/dune.inc index 6867c7e2c871e401a431d3f91c302eaca5e563b1..603d7a5909dacb4c0f90507dde8025f4a1cd6e0b 100644 --- a/src/proto_genesis/lib_protocol/dune.inc +++ b/src/proto_genesis/lib_protocol/dune.inc @@ -66,7 +66,7 @@ include Tezos_raw_protocol_genesis.Main (libraries tezos_protocol_environment_genesis) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_genesis__Environment -open Pervasives @@ -88,19 +88,19 @@ include Tezos_raw_protocol_genesis.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_genesis) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_genesis_functor) - (public_name tezos-protocol-genesis.functor) + (public_name tezos-protocol-functor-genesis) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_genesis) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-genesis.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -112,7 +112,7 @@ include Tezos_raw_protocol_genesis.Main (libraries tezos-protocol-genesis tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_genesis/lib_protocol/tezos-embedded-protocol-genesis.opam b/src/proto_genesis/lib_protocol/tezos-embedded-protocol-genesis.opam index b2f9cf101f512a4788ab049530b6389208030555..a7d3d043cca9dce2ad160dbe43878ddbcda30394 100644 --- a/src/proto_genesis/lib_protocol/tezos-embedded-protocol-genesis.opam +++ b/src/proto_genesis/lib_protocol/tezos-embedded-protocol-genesis.opam @@ -6,7 +6,6 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-protocol-genesis" "tezos-protocol-updater" diff --git a/src/proto_genesis/lib_protocol/tezos-protocol-functor-genesis.opam b/src/proto_genesis/lib_protocol/tezos-protocol-functor-genesis.opam new file mode 100644 index 0000000000000000000000000000000000000000..fc590d2f522938aa80ef709490d7bfef019c4c88 --- /dev/null +++ b/src/proto_genesis/lib_protocol/tezos-protocol-functor-genesis.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-genesis" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "genesis" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: genesis (economic-protocol definition parameterized by its environment implementation)" diff --git a/src/proto_genesis/lib_protocol/tezos-protocol-genesis.opam b/src/proto_genesis/lib_protocol/tezos-protocol-genesis.opam index 722c74ebe10f73814c0447494e21786482face70..2c542ae1a938ccc0ce5c26f507b3aa00ccbc325f 100644 --- a/src/proto_genesis/lib_protocol/tezos-protocol-genesis.opam +++ b/src/proto_genesis/lib_protocol/tezos-protocol-genesis.opam @@ -6,7 +6,6 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-protocol-compiler" ] diff --git a/src/proto_genesis_carthagenet/lib_protocol/dune.inc b/src/proto_genesis_carthagenet/lib_protocol/dune.inc index c6f10e04eaa0c0648b4e35acf05de916cc11673f..cbc85bfdde7e2c8dd7c35330b8af551612afba5c 100644 --- a/src/proto_genesis_carthagenet/lib_protocol/dune.inc +++ b/src/proto_genesis_carthagenet/lib_protocol/dune.inc @@ -66,7 +66,7 @@ include Tezos_raw_protocol_genesis_carthagenet.Main (libraries tezos_protocol_environment_genesis_carthagenet) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib - -w +a-4-6-7-9-29-32-40..42-44-45-48 + -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a -open Tezos_protocol_environment_genesis_carthagenet__Environment -open Pervasives @@ -88,19 +88,19 @@ include Tezos_raw_protocol_genesis_carthagenet.Main tezos-protocol-environment tezos-protocol-environment-sigs tezos_raw_protocol_genesis_carthagenet) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Protocol)) (library (name tezos_protocol_genesis_carthagenet_functor) - (public_name tezos-protocol-genesis-carthagenet.functor) + (public_name tezos-protocol-functor-genesis-carthagenet) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_genesis_carthagenet) - (flags -w "+a-4-6-7-9-29-40..42-44-45-48" + tezos-protocol-genesis-carthagenet.raw) + (flags -w "+a-4-6-7-9-29-40..42-44-45-48-60-67" -warn-error "+a" -nopervasives) (modules Functor)) @@ -112,7 +112,7 @@ include Tezos_raw_protocol_genesis_carthagenet.Main (libraries tezos-protocol-genesis-carthagenet tezos-protocol-updater tezos-protocol-environment) - (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 + (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48-60-67 -warn-error +a)) (modules Registerer)) diff --git a/src/proto_genesis_carthagenet/lib_protocol/tezos-embedded-protocol-genesis-carthagenet.opam b/src/proto_genesis_carthagenet/lib_protocol/tezos-embedded-protocol-genesis-carthagenet.opam index 6b946e874cab276da653f808817cb8611dc60c87..f3dfd315eaa2f2114b69db4c7a104dd660576456 100644 --- a/src/proto_genesis_carthagenet/lib_protocol/tezos-embedded-protocol-genesis-carthagenet.opam +++ b/src/proto_genesis_carthagenet/lib_protocol/tezos-embedded-protocol-genesis-carthagenet.opam @@ -6,7 +6,6 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-protocol-genesis-carthagenet" "tezos-protocol-updater" diff --git a/src/proto_genesis_carthagenet/lib_protocol/tezos-protocol-functor-genesis-carthagenet.opam b/src/proto_genesis_carthagenet/lib_protocol/tezos-protocol-functor-genesis-carthagenet.opam new file mode 100644 index 0000000000000000000000000000000000000000..70c788f39f5dc81643e27aa16281d9db9fc69cae --- /dev/null +++ b/src/proto_genesis_carthagenet/lib_protocol/tezos-protocol-functor-genesis-carthagenet.opam @@ -0,0 +1,24 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "dune" { >= "2.0" } + "tezos-protocol-genesis-carthagenet" + "tezos-protocol-compiler" +] +build: [ + [ + "%{tezos-protocol-compiler:lib}%/replace" + "%{tezos-protocol-compiler:lib}%/dune_protocol.template" + "dune" + "%{tezos-protocol-compiler:lib}%/final_protocol_versions" + "genesis_carthagenet" + ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos/Protocol: genesis_carthagenet (economic-protocol definition parameterized by its environment implementation)" diff --git a/src/proto_genesis_carthagenet/lib_protocol/tezos-protocol-genesis-carthagenet.opam b/src/proto_genesis_carthagenet/lib_protocol/tezos-protocol-genesis-carthagenet.opam index 02c27e8f675e601b5ef7fc701a104711b99d3b68..4515601c40e22b1ecc1f7918a2e80bd65aaa2ac3 100644 --- a/src/proto_genesis_carthagenet/lib_protocol/tezos-protocol-genesis-carthagenet.opam +++ b/src/proto_genesis_carthagenet/lib_protocol/tezos-protocol-genesis-carthagenet.opam @@ -6,7 +6,6 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-protocol-compiler" ] diff --git a/src/tooling/test/dune b/src/tooling/test/dune index facce523f3e3f314e61ec79ecc87fb30a4e4fd3c..f888216ed38642b6f9a4114d333bcab1020318dc 100644 --- a/src/tooling/test/dune +++ b/src/tooling/test/dune @@ -2,26 +2,31 @@ ;; are expected to be ignored. (rule (alias runtest) + (package tezos-tooling) (deps test_well_formatted.ml) (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) (rule (alias runtest) + (package tezos-tooling) (deps test_well_formatted.mli) (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) (rule (alias runtest) + (package tezos-tooling) (deps test.pp.mli) (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) (rule (alias runtest) + (package tezos-tooling) (deps test.pp.ml) (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) (rule (alias runtest) + (package tezos-tooling) (deps test_well_formatted.ml test_well_formatted.mli test.pp.mli test.pp.ml) (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) @@ -29,10 +34,12 @@ ;; with the exit code 1. (rule (alias runtest) + (package tezos-tooling) (deps test_not_well_formatted.ml) (action (with-accepted-exit-codes 1 (run %{lib:tezos-tooling:lint.sh} %{deps})))) (rule (alias runtest) + (package tezos-tooling) (deps test_not_well_formatted.mli) (action (with-accepted-exit-codes 1 (run %{lib:tezos-tooling:lint.sh} %{deps})))) diff --git a/tests_python/client/client.py b/tests_python/client/client.py index d979fbe86e99ce95adc463b97be125fb1b5c6e15..840efb5ac35d7b0bd4b315df06e939b0ea4f0ca3 100644 --- a/tests_python/client/client.py +++ b/tests_python/client/client.py @@ -345,6 +345,30 @@ class Client: def pack(self, data: str, typ: str) -> str: return self.hash(data, typ).packed + def normalize( + self, data: str, typ: str, mode: str = None, legacy: bool = False + ) -> str: + cmd = ['normalize', 'data', data, 'of', 'type', typ] + if mode is not None: + cmd += ['--unparsing-mode', mode] + if legacy: + cmd += ['--legacy'] + return self.run(cmd) + + def normalize_script( + self, script: str, mode: str = None, file: bool = True + ) -> str: + if file: + assert os.path.isfile(script), f'{script} is not a file' + cmd = ['normalize', 'script', script] + if mode is not None: + cmd += ['--unparsing-mode', mode] + return self.run(cmd) + + def normalize_type(self, typ: str) -> str: + cmd = ['normalize', 'type', typ] + return self.run(cmd) + def sign(self, data: str, identity: str) -> str: cmd = ['sign', 'bytes', data, 'for', identity] return client_output.SignatureResult(self.run(cmd)).sig diff --git a/tests_python/tests/test_contract_opcodes.py b/tests_python/tests/test_contract_opcodes.py index 3b0300025d35d70e3c57d96bcf554f0c33db42b7..d480f373cca5a68d7af53b648e1b302f3368616c 100644 --- a/tests_python/tests/test_contract_opcodes.py +++ b/tests_python/tests/test_contract_opcodes.py @@ -410,7 +410,7 @@ class TestContractOpcodes: '(Some (Pair 3320000 1300000))'), # Test various additions - ('add.tz', 'Unit', 'Unit', 'Unit'), + ('add.tz', 'Unit', 'Unit', 'Unit'), # Now replicated in src/proto_alpha/lib_protocol/test/michelson_opcodes.ml # Test ABS ('abs.tz', 'Unit', '12039123919239192312931', 'Unit'), diff --git a/vendors/ocaml-bls12-381/src/dune b/vendors/ocaml-bls12-381/src/dune index f96be60579543b97186891f0843bf7548ae9271b..6b876ac0e4169692d0d311d1f6082ce93e77f0dd 100644 --- a/vendors/ocaml-bls12-381/src/dune +++ b/vendors/ocaml-bls12-381/src/dune @@ -9,7 +9,7 @@ (foreign_stubs (language c) (names rustc_bls12_381_ctypes_c_stubs ) - (flags (-I%{env:OPAM_SWITCH_PREFIX=}/include/rustc-bls12-381)) + (flags (-I%{env:OPAM_SWITCH_PREFIX=}/lib/tezos-rust-libs)) ) - (c_library_flags (-L%{env:OPAM_SWITCH_PREFIX=}/lib/rustc-bls12-381 -lrustc_bls12_381 -lpthread)) + (c_library_flags (-L%{env:OPAM_SWITCH_PREFIX=}/lib/tezos-rust-libs -lrustc_bls12_381 -lpthread)) )