From 1f3ed5fc59c0ccae8fe3fc9087aa8064c380ce47 Mon Sep 17 00:00:00 2001 From: Killian Delarue Date: Mon, 27 Jan 2025 15:03:23 +0100 Subject: [PATCH 1/7] ParisC: Add [dal_proto_client] to [lib_sc_rollup_node] --- .../lib_sc_rollup_node/dal_proto_client.ml | 77 +++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100644 src/proto_020_PsParisC/lib_sc_rollup_node/dal_proto_client.ml diff --git a/src/proto_020_PsParisC/lib_sc_rollup_node/dal_proto_client.ml b/src/proto_020_PsParisC/lib_sc_rollup_node/dal_proto_client.ml new file mode 100644 index 000000000000..b9e6f6253c41 --- /dev/null +++ b/src/proto_020_PsParisC/lib_sc_rollup_node/dal_proto_client.ml @@ -0,0 +1,77 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2024 Functori, *) +(* Copyright (c) 2024 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 Protocol.Alpha_context +open Tezos_rpc + +type cctxt = Dal_node_client.cctxt + +type 'rpc service = + ('meth, 'prefix, 'params, 'query, 'input, 'output) Service.service + constraint + 'rpc = + < meth : 'meth + ; prefix : 'prefix + ; params : 'params + ; query : 'query + ; input : 'input + ; output : 'output > + +let cell_hash_arg : Dal.Slots_history.Pointer_hash.t Arg.t = + Arg.make + ~descr:"The hash of a DAL skip list cell" + ~name:"skip_list_cell_hash" + ~construct:Dal.Slots_history.Pointer_hash.to_b58check + ~destruct:(fun h -> + match Dal.Slots_history.Pointer_hash.of_b58check_opt h with + | Some b -> Ok b + | None -> Error "Cannot parse skip list cell hash") + () + +let hash_content : + < meth : [`GET] + ; input : unit + ; output : Dal.Slots_history.t + ; prefix : unit + ; params : unit * Dal.Slots_history.Pointer_hash.t + ; query : unit > + service = + Service.get_service + ~description:"Returns the DAL skip list cell of the given hash" + ~query:Query.empty + ~output:Dal.Slots_history.encoding + Path.( + open_root + / Protocol_hash.to_b58check Protocol.hash + / "commitments_history" / "hash" /: cell_hash_arg) + +let get_commitments_history_hash_content (cctxt : cctxt) hash = + Dal_node_client.call + cctxt + (Tezos_rpc.Service.prefix Tezos_rpc.Path.(root / "plugin") hash_content) + ((), hash) + () + () -- GitLab From cf2191122f225a1a39104f2c5d960d95a1106070 Mon Sep 17 00:00:00 2001 From: Killian Delarue Date: Mon, 27 Jan 2025 14:22:14 +0100 Subject: [PATCH 2/7] Paris: Freeze --- contrib/octez_injector_server/dune | 4 - devtools/get_contracts/dune | 2 - .../get_contracts_020_PsParisC.ml | 315 ---- devtools/testnet_experiment_tools/dune | 6 +- .../tool_020_PsParisC.ml | 998 ----------- devtools/yes_wallet/dune | 1 - .../yes_wallet/get_delegates_020_PsParisC.ml | 130 -- docs/doc_gen/dune | 1 - dune-project | 4 - manifest/product_octez.ml | 24 +- opam/octez-accuser-PsParisC.opam | 26 - opam/octez-baker-PsParisC.opam | 26 - opam/octez-client.opam | 3 +- opam/octez-dal-node.opam | 1 - opam/octez-injector-server.opam | 2 - opam/octez-node.opam | 6 +- opam/octez-protocol-020-PsParisC-libs.opam | 7 - opam/octez-smart-rollup-node.opam | 3 +- ...benchmark-type-inference-020-PsParisC.opam | 24 - opam/tezos-injector-020-PsParisC.opam | 25 - opam/tezos-sc-rollup-node-test.opam | 5 +- opam/tezos-smart-rollup-node-lib-test.opam | 2 +- script-inputs/active_protocol_versions | 1 - .../active_protocol_versions_without_number | 1 - script-inputs/ci-opam-package-tests | 26 +- script-inputs/released-executables | 2 - script-inputs/slim-mode-dune | 3 +- src/bin_client/dune | 11 +- src/bin_dal_node/dune | 1 - src/bin_node/dune | 10 +- src/bin_smart_rollup_node/dune | 5 +- src/lib_smart_rollup_node/test/helpers/dune | 5 +- src/proto_020_PsParisC/bin_accuser/dune | 32 - .../bin_accuser/main_accuser_020_PsParisC.ml | 39 - src/proto_020_PsParisC/bin_baker/dune | 32 - .../bin_baker/main_baker_020_PsParisC.ml | 54 - .../lib_benchmark/README.md | 42 - .../lib_benchmark/autocomp.ml | 380 ----- .../lib_benchmark/execution_context.ml | 103 -- .../lib_benchmark/kernel.ml | 39 - .../lib_benchmark_type_inference/dune | 23 - .../lib_benchmark_type_inference/inference.ml | 1150 ------------- .../inference.mli | 145 -- .../lib_benchmark_type_inference/int_map.ml | 26 - .../mikhailsky.ml | 422 ----- .../mikhailsky.mli | 331 ---- .../mikhailsky_prim.ml | 575 ------- .../lib_benchmark_type_inference/monads.ml | 83 - .../lib_benchmark_type_inference/stores.ml | 85 - .../lib_benchmark_type_inference/type.ml | 200 --- .../lib_benchmark_type_inference/type.mli | 111 -- .../lib_benchmark_type_inference/uf.ml | 99 -- .../lib_benchmark/micheline_sampler.ml | 110 -- .../lib_benchmark/micheline_sampler.mli | 70 - .../lib_benchmark/michelson_mcmc_samplers.ml | 341 ---- .../lib_benchmark/michelson_mcmc_samplers.mli | 115 -- .../lib_benchmark/michelson_samplers.ml | 824 --------- .../lib_benchmark/michelson_samplers.mli | 172 -- .../lib_benchmark/michelson_samplers_base.ml | 139 -- .../lib_benchmark/michelson_samplers_base.mli | 67 - .../lib_benchmark/mikhailsky_to_michelson.ml | 229 --- src/proto_020_PsParisC/lib_benchmark/rules.ml | 975 ----------- .../lib_benchmark/sampling_helpers.ml | 41 - .../lib_benchmark/state_space.ml | 78 - .../lib_benchmark/type_helpers.ml | 88 - .../lib_benchmark/type_helpers.mli | 57 - .../lib_dal/RPC_directory.ml | 40 - .../lib_dal/RPC_directory.mli | 11 - .../lib_dal/dal_plugin_registration.ml | 365 ---- .../lib_dal/dal_proto_client.ml | 37 - .../lib_dal/dal_proto_client.mli | 30 - .../lib_dal/dal_services.ml | 51 - .../lib_dal/dal_services.mli | 32 - .../lib_dal/dal_slot_frame_encoding.ml | 257 --- .../lib_dal/dal_slot_frame_encoding.mli | 182 -- src/proto_020_PsParisC/lib_dal/dune | 38 - .../lib_delegate/abstract_context_index.ml | 38 - .../lib_delegate/abstract_context_index.mli | 33 - .../lib_delegate/baking_actions.ml | 1205 -------------- .../lib_delegate/baking_actions.mli | 121 -- .../lib_delegate/baking_cache.ml | 84 - .../lib_delegate/baking_commands.ml | 879 ---------- .../lib_delegate/baking_commands.mli | 33 - .../baking_commands_registration.ml | 29 - .../lib_delegate/baking_configuration.ml | 376 ----- .../lib_delegate/baking_configuration.mli | 142 -- .../lib_delegate/baking_errors.ml | 437 ----- .../lib_delegate/baking_events.ml | 1472 ----------------- .../lib_delegate/baking_files.ml | 41 - .../lib_delegate/baking_files.mli | 35 - .../lib_delegate/baking_highwatermarks.ml | 264 --- .../lib_delegate/baking_highwatermarks.mli | 105 -- .../lib_delegate/baking_lib.ml | 807 --------- .../lib_delegate/baking_lib.mli | 84 - .../lib_delegate/baking_nonces.ml | 672 -------- .../lib_delegate/baking_nonces.mli | 80 - .../lib_delegate/baking_pow.ml | 134 -- .../lib_delegate/baking_pow.mli | 40 - .../lib_delegate/baking_profiler.ml | 40 - .../lib_delegate/baking_scheduling.ml | 1120 ------------- .../lib_delegate/baking_scheduling.mli | 114 -- .../lib_delegate/baking_simulator.ml | 172 -- .../lib_delegate/baking_simulator.mli | 81 - .../lib_delegate/baking_state.ml | 1468 ---------------- .../lib_delegate/baking_state.mli | 436 ----- .../lib_delegate/baking_vdf.ml | 503 ------ .../lib_delegate/baking_vdf.mli | 33 - .../lib_delegate/block_forge.ml | 533 ------ .../lib_delegate/block_forge.mli | 64 - .../lib_delegate/client_baking_blocks.ml | 219 --- .../lib_delegate/client_baking_blocks.mli | 68 - .../client_baking_denunciation.ml | 639 ------- .../client_baking_denunciation.mli | 31 - .../lib_delegate/client_baking_scheduling.ml | 33 - .../lib_delegate/client_baking_scheduling.mli | 54 - .../lib_delegate/client_daemon.ml | 236 --- .../lib_delegate/client_daemon.mli | 68 - .../lib_delegate/delegate_events.ml | 256 --- src/proto_020_PsParisC/lib_delegate/dune | 111 -- .../lib_delegate/forge_worker.ml | 238 --- .../lib_delegate/forge_worker.mli | 71 - .../lib_delegate/node_rpc.ml | 414 ----- .../lib_delegate/node_rpc.mli | 110 -- .../lib_delegate/operation_pool.ml | 402 ----- .../lib_delegate/operation_pool.mli | 168 -- .../lib_delegate/operation_selection.ml | 426 ----- .../lib_delegate/operation_selection.mli | 72 - .../lib_delegate/operation_worker.ml | 771 --------- .../lib_delegate/operation_worker.mli | 91 - .../lib_delegate/per_block_vote_file.ml | 154 -- .../lib_delegate/per_block_vote_file.mli | 77 - .../lib_delegate/state_transitions.ml | 1348 --------------- .../lib_delegate/state_transitions.mli | 90 - .../lib_delegate/vdf_helpers.ml | 31 - .../lib_delegate/vdf_helpers.mli | 35 - src/proto_020_PsParisC/lib_injector/dune | 23 - .../lib_injector/injector_plugin.ml | 457 ----- src/proto_020_PsParisC/lib_plugin/index.mld | 3 - .../lib_sc_rollup_node/dune | 2 - .../lib_sc_rollup_node/test/dune | 49 - .../test/serialized_proofs.ml | 121 -- .../test/serialized_proofs.mli | 27 - .../test/test_octez_conversions.ml | 490 ------ tezt/tests/dune | 1 - teztale/bin_teztale_archiver/dune | 14 - 145 files changed, 60 insertions(+), 29015 deletions(-) delete mode 100644 devtools/get_contracts/get_contracts_020_PsParisC.ml delete mode 100644 devtools/testnet_experiment_tools/tool_020_PsParisC.ml delete mode 100644 devtools/yes_wallet/get_delegates_020_PsParisC.ml delete mode 100644 opam/octez-accuser-PsParisC.opam delete mode 100644 opam/octez-baker-PsParisC.opam delete mode 100644 opam/tezos-benchmark-type-inference-020-PsParisC.opam delete mode 100644 opam/tezos-injector-020-PsParisC.opam delete mode 100644 src/proto_020_PsParisC/bin_accuser/dune delete mode 100644 src/proto_020_PsParisC/bin_accuser/main_accuser_020_PsParisC.ml delete mode 100644 src/proto_020_PsParisC/bin_baker/dune delete mode 100644 src/proto_020_PsParisC/bin_baker/main_baker_020_PsParisC.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/README.md delete mode 100644 src/proto_020_PsParisC/lib_benchmark/autocomp.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/execution_context.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/kernel.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/dune delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/inference.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/inference.mli delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/int_map.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky.mli delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky_prim.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/monads.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/stores.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/type.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/type.mli delete mode 100644 src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/uf.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/micheline_sampler.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/micheline_sampler.mli delete mode 100644 src/proto_020_PsParisC/lib_benchmark/michelson_mcmc_samplers.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/michelson_mcmc_samplers.mli delete mode 100644 src/proto_020_PsParisC/lib_benchmark/michelson_samplers.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/michelson_samplers.mli delete mode 100644 src/proto_020_PsParisC/lib_benchmark/michelson_samplers_base.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/michelson_samplers_base.mli delete mode 100644 src/proto_020_PsParisC/lib_benchmark/mikhailsky_to_michelson.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/rules.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/sampling_helpers.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/state_space.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/type_helpers.ml delete mode 100644 src/proto_020_PsParisC/lib_benchmark/type_helpers.mli delete mode 100644 src/proto_020_PsParisC/lib_dal/RPC_directory.ml delete mode 100644 src/proto_020_PsParisC/lib_dal/RPC_directory.mli delete mode 100644 src/proto_020_PsParisC/lib_dal/dal_plugin_registration.ml delete mode 100644 src/proto_020_PsParisC/lib_dal/dal_proto_client.ml delete mode 100644 src/proto_020_PsParisC/lib_dal/dal_proto_client.mli delete mode 100644 src/proto_020_PsParisC/lib_dal/dal_services.ml delete mode 100644 src/proto_020_PsParisC/lib_dal/dal_services.mli delete mode 100644 src/proto_020_PsParisC/lib_dal/dal_slot_frame_encoding.ml delete mode 100644 src/proto_020_PsParisC/lib_dal/dal_slot_frame_encoding.mli delete mode 100644 src/proto_020_PsParisC/lib_dal/dune delete mode 100644 src/proto_020_PsParisC/lib_delegate/abstract_context_index.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/abstract_context_index.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_actions.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_actions.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_cache.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_commands.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_commands.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_commands_registration.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_configuration.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_configuration.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_errors.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_events.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_files.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_files.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_highwatermarks.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_highwatermarks.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_lib.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_lib.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_nonces.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_nonces.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_pow.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_pow.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_profiler.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_scheduling.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_simulator.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_simulator.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_state.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_state.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_vdf.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/baking_vdf.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/block_forge.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/block_forge.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/client_baking_blocks.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/client_baking_blocks.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/client_baking_denunciation.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/client_baking_denunciation.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/client_baking_scheduling.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/client_baking_scheduling.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/client_daemon.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/client_daemon.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/delegate_events.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/dune delete mode 100644 src/proto_020_PsParisC/lib_delegate/forge_worker.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/forge_worker.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/node_rpc.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/node_rpc.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/operation_pool.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/operation_pool.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/operation_selection.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/operation_selection.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/operation_worker.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/operation_worker.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/per_block_vote_file.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/per_block_vote_file.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/state_transitions.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/state_transitions.mli delete mode 100644 src/proto_020_PsParisC/lib_delegate/vdf_helpers.ml delete mode 100644 src/proto_020_PsParisC/lib_delegate/vdf_helpers.mli delete mode 100644 src/proto_020_PsParisC/lib_injector/dune delete mode 100644 src/proto_020_PsParisC/lib_injector/injector_plugin.ml delete mode 100644 src/proto_020_PsParisC/lib_sc_rollup_node/test/dune delete mode 100644 src/proto_020_PsParisC/lib_sc_rollup_node/test/serialized_proofs.ml delete mode 100644 src/proto_020_PsParisC/lib_sc_rollup_node/test/serialized_proofs.mli delete mode 100644 src/proto_020_PsParisC/lib_sc_rollup_node/test/test_octez_conversions.ml diff --git a/contrib/octez_injector_server/dune b/contrib/octez_injector_server/dune index 3d6b53bd2270..450fb1e94e0d 100644 --- a/contrib/octez_injector_server/dune +++ b/contrib/octez_injector_server/dune @@ -17,9 +17,6 @@ octez-shell-libs.client-base octez-shell-libs.client-base-unix octez-libs.data-encoding - (select void_for_linking-octez_injector_PsParisC from - (octez_injector_PsParisC -> void_for_linking-octez_injector_PsParisC.empty) - (-> void_for_linking-octez_injector_PsParisC.empty)) (select void_for_linking-octez_injector_PsQuebec from (octez_injector_PsQuebec -> void_for_linking-octez_injector_PsQuebec.empty) (-> void_for_linking-octez_injector_PsQuebec.empty)) @@ -44,6 +41,5 @@ (rule (action (progn - (write-file void_for_linking-octez_injector_PsParisC.empty "") (write-file void_for_linking-octez_injector_PsQuebec.empty "") (write-file void_for_linking-octez_injector_alpha.empty "")))) diff --git a/devtools/get_contracts/dune b/devtools/get_contracts/dune index 844b43c61dd9..85ef01aa8fe6 100644 --- a/devtools/get_contracts/dune +++ b/devtools/get_contracts/dune @@ -7,8 +7,6 @@ octez-libs.micheline octez-libs.base octez-shell-libs.store - tezos-protocol-020-PsParisC.protocol - octez-protocol-020-PsParisC-libs.client tezos-protocol-021-PsQuebec.protocol octez-protocol-021-PsQuebec-libs.client tezos-protocol-alpha.protocol diff --git a/devtools/get_contracts/get_contracts_020_PsParisC.ml b/devtools/get_contracts/get_contracts_020_PsParisC.ml deleted file mode 100644 index 7c6f960823d9..000000000000 --- a/devtools/get_contracts/get_contracts_020_PsParisC.ml +++ /dev/null @@ -1,315 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 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 Tezos_protocol_020_PsParisC -open Tezos_client_020_PsParisC -open Protocol - -module Proto = struct - let hash = hash - - let wrap_tzresult = Environment.wrap_tzresult - - module Context = struct - type t = Raw_context.t - - let prepare ~level ~predecessor_timestamp ~timestamp ctxt = - let open Lwt_result_syntax in - let+ ctxt = - Lwt.map wrap_tzresult - @@ Raw_context.prepare - ~level - ~predecessor_timestamp - ~timestamp - ~adaptive_issuance_enable:false - ctxt - in - Raw_context.set_gas_limit - ctxt - (Gas_limit_repr.fp_of_milligas_int (max_int - 1)) - end - - type context = Context.t - - module Contract = struct - type repr = Contract_repr.t - - let pp = Contract_repr.pp - - let is_implicit = function - | Contract_repr.Implicit _ -> true - | Contract_repr.Originated _ -> false - - let get_code ctxt contract = - Lwt.map wrap_tzresult @@ Storage.Contract.Code.get ctxt contract - - let get_storage ctxt contract = - Lwt.map wrap_tzresult @@ Storage.Contract.Storage.get ctxt contract - - let fold ctxt ~init ~f = - Storage.Contract.fold ctxt ~order:`Undefined ~init ~f - end - - module Script = struct - include Alpha_context.Script - module Hash = Script_expr_hash - - let print_expr = Michelson_v1_printer.print_expr - - let decode_and_costs lazy_expr = - let open Result_syntax in - let decode_cost = Script_repr.stable_force_decode_cost lazy_expr in - let+ expr = wrap_tzresult @@ Script_repr.force_decode lazy_expr in - let encode_cost = - let decoded_lazy_expr = Script_repr.lazy_expr expr in - Script_repr.force_bytes_cost decoded_lazy_expr - in - (expr, (decode_cost :> int), (encode_cost :> int)) - end - - module Translator = struct - type toplevel = Script_ir_translator.toplevel - - type ('a, 'b) ty = ('a, 'b) Script_typed_ir.ty - - type ex_ty = Ex_ty : ('a, 'b) ty -> ex_ty - - type ex_code = Script_ir_translator.ex_code - - let expected_code_size Script_ir_translator.(Ex_code (Code {code_size; _})) - = - (code_size :> int) - - let actual_code_size Script_ir_translator.(Ex_code (Code {code; _})) = - 8 * Obj.(reachable_words @@ repr code) - - let parse_ty (raw_ctxt : Raw_context.t) ~allow_lazy_storage ~allow_operation - ~allow_contract ~allow_ticket script = - let open Result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ Script_typed_ir.Ex_ty ty, updated_ctxt = - wrap_tzresult - @@ Script_ir_translator.parse_ty - ctxt - ~legacy:true - ~allow_lazy_storage - ~allow_operation - ~allow_contract - ~allow_ticket - script - in - let consumed = - (Alpha_context.Gas.consumed ~since:ctxt ~until:updated_ctxt :> int) - in - assert (consumed > 0) ; - (Ex_ty ty, consumed) - - let parse_data (raw_ctxt : Raw_context.t) ~allow_forged ty expr = - let open Lwt_result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ data, updated_ctxt = - Lwt.map wrap_tzresult - @@ Script_ir_translator.parse_data - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) - ctxt - ~allow_forged_tickets:allow_forged - ~allow_forged_lazy_storage_id:allow_forged - ty - expr - in - let consumed = - (Alpha_context.Gas.consumed ~since:ctxt ~until:updated_ctxt :> int) - in - assert (consumed > 0) ; - (data, consumed) - - let unparse_data_cost (raw_ctxt : Raw_context.t) ty data = - let open Lwt_result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ _expr, updated_ctxt = - Lwt.map wrap_tzresult - @@ Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Optimized - ty - data - in - let consumed = - (Alpha_context.Gas.consumed ~since:ctxt ~until:updated_ctxt :> int) - in - assert (consumed > 0) ; - consumed - - let unparse_ty (raw_ctxt : Raw_context.t) (Ex_ty ty) = - let open Result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ expr, _ = - wrap_tzresult @@ Script_ir_unparser.unparse_ty ~loc:0 ctxt ty - in - expr - - let parse_toplevel (raw_ctxt : Raw_context.t) expr = - let open Lwt_result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ toplevel, updated_ctxt = - Lwt.map wrap_tzresult @@ Script_ir_translator.parse_toplevel ctxt expr - in - let consumed = - (Alpha_context.Gas.consumed ~since:ctxt ~until:updated_ctxt :> int) - in - assert (consumed > 0) ; - (toplevel, consumed) - - let parse_code (raw_ctxt : Raw_context.t) code = - let open Lwt_result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ parsed_code, _ = - Lwt.map wrap_tzresult - @@ Script_ir_translator.parse_code - ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) - ~code - in - parsed_code - end - - module Storage = struct - type big_map_id = Storage.Big_map.id - - let id_to_z = Lazy_storage_kind.Big_map.Id.unparse_to_z - - let list_values ?offset ?length (ctxt, id) = - let open Lwt_result_syntax in - let* ctxt, key_values = - Lwt.map wrap_tzresult - @@ Storage.Big_map.Contents.list_key_values ?offset ?length (ctxt, id) - in - let values = List.map snd key_values in - return (ctxt, values) - - let get ctxt id = - Lwt.map wrap_tzresult @@ Storage.Big_map.Value_type.get ctxt id - - let fold ctxt ~init ~f = - Storage.Big_map.fold ctxt ~order:`Undefined ~init ~f - end - - module Lambda = struct - type ex_lambda = - | Ex_lambda : - (('a, 'b) Script_typed_ir.lambda, _) Script_typed_ir.ty - * ('a, 'b) Script_typed_ir.lambda - -> ex_lambda - - type ex_ty_lambdas = - | Ex_ty_lambdas : - ('a, _) Script_typed_ir.ty * ('a -> ex_lambda list) list - -> ex_ty_lambdas - - let lam_node node = - match node with - | Ex_lambda (_, Lam (_, node)) | Ex_lambda (_, LamRec (_, node)) -> node - - let rec find_lambda_tys : - type a c. (a, c) Script_typed_ir.ty -> (a -> ex_lambda list) list = - fun ty -> - let open Script_typed_ir in - match ty with - | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t - | Key_hash_t | Key_t | Timestamp_t | Address_t | Bool_t | Set_t _ - | Big_map_t _ | Contract_t _ | Operation_t | Sapling_transaction_t _ - | Sapling_transaction_deprecated_t _ | Sapling_state_t _ | Never_t - | Bls12_381_g1_t | Bls12_381_g2_t | Bls12_381_fr_t | Ticket_t _ - | Chain_id_t | Chest_key_t | Chest_t -> - [] - | Pair_t (t1, t2, _, _) -> - let g1 = List.map (fun g (v, _) -> g v) @@ find_lambda_tys t1 in - let g2 = List.map (fun g (_, v) -> g v) @@ find_lambda_tys t2 in - g1 @ g2 - | Or_t (t1, t2, _, _) -> - let g1 = - List.map (fun g -> function L v -> g v | R _ -> []) - @@ find_lambda_tys t1 - in - let g2 = - List.map (fun g -> function L _ -> [] | R v -> g v) - @@ find_lambda_tys t2 - in - g1 @ g2 - | Lambda_t _ -> [(fun g -> [Ex_lambda (ty, g)])] - | Option_t (t, _, _) -> - List.map (fun g -> function None -> [] | Some v -> g v) - @@ find_lambda_tys t - | List_t (t, _) -> - List.map (fun g l -> - List.flatten @@ List.map g @@ Script_list.to_list l) - @@ find_lambda_tys t - | Map_t (_, tv, _) -> find_lambda_tys_map tv - - and find_lambda_tys_map : - type tk tv c. - (tv, c) Script_typed_ir.ty -> - ((tk, tv) Script_typed_ir.map -> ex_lambda list) list = - fun tv -> - let open Script_typed_ir in - List.map (fun g (Map_tag (module Box) : (tk, tv) map) -> - Box.OPS.fold (fun _k v acc -> g v @ acc) Box.boxed []) - @@ find_lambda_tys tv - - let collect_lambda_tys (Translator.Ex_ty ty) = - match find_lambda_tys ty with - | [] -> None - | lams -> Some (Ex_ty_lambdas (ty, lams)) - - let fold_ex_ty_lambdas (type a) ~(ctxt : Context.t) ~(expr : Script.node) - ~(f : a -> Script.node -> ex_lambda list -> a) ~(acc : a) - (Ex_ty_lambdas (ty, getters)) = - let open Lwt_syntax in - let+ parse_result = - Translator.parse_data ctxt ~allow_forged:true ty expr - in - match parse_result with - | Error _ -> acc - | Ok (data, _cost) -> ( - match Script_ir_unparser.unparse_ty ~loc:0 (Obj.magic ctxt) ty with - | Error _ -> assert false - | Ok (ty_expr, _) -> - List.fold_left (fun acc g -> f acc ty_expr @@ g data) acc getters) - end - - let is_unpack = function - | Michelson_v1_primitives.I_UNPACK -> true - | _ -> false - - let code_storage_type ({storage_type; _} : Translator.toplevel) = storage_type - - module Global_constants = struct - let expand ctxt (expr : Script.expr) = - let open Lwt_syntax in - let+ res = Global_constants_storage.expand ctxt expr in - match res with Error _ -> (ctxt, expr) | Ok x -> x - end -end - -let () = Known_protocols.register (module Proto) diff --git a/devtools/testnet_experiment_tools/dune b/devtools/testnet_experiment_tools/dune index be336d5bd3ac..5d72bdd52727 100644 --- a/devtools/testnet_experiment_tools/dune +++ b/devtools/testnet_experiment_tools/dune @@ -40,10 +40,6 @@ octez-shell-libs.store octez-shell-libs.store.shared octez-shell-libs.context-ops - octez-protocol-020-PsParisC-libs.baking - octez-protocol-020-PsParisC-libs.client - octez-protocol-020-PsParisC-libs.client.commands - tezos-protocol-020-PsParisC.protocol octez-protocol-021-PsQuebec-libs.baking octez-protocol-021-PsQuebec-libs.client octez-protocol-021-PsQuebec-libs.client.commands @@ -63,7 +59,7 @@ -open Tezos_store -open Tezos_store_shared -open Tezos_context_ops) - (modules sigs tool_020_PsParisC tool_021_PsQuebec tool_alpha)) + (modules sigs tool_021_PsQuebec tool_alpha)) (executable (name simulation_scenario) diff --git a/devtools/testnet_experiment_tools/tool_020_PsParisC.ml b/devtools/testnet_experiment_tools/tool_020_PsParisC.ml deleted file mode 100644 index 73cca88386fc..000000000000 --- a/devtools/testnet_experiment_tools/tool_020_PsParisC.ml +++ /dev/null @@ -1,998 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 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_result_syntax -open Tezos_shell_services -open Tezos_client_020_PsParisC -open Tezos_baking_020_PsParisC -open Tezos_protocol_020_PsParisC -open Protocol -open Alpha_context - -(** Sync node *) - -class wrap_silent_memory_client (t : Client_context.full) : - Protocol_client_context.full = - object - inherit Protocol_client_context.wrap_full t - - method! message : type a. (a, unit) Client_context.lwt_format -> a = - fun x -> Format.kasprintf (fun _msg -> Lwt.return_unit) x - - method! last_modification_time _ = return_some 0. - - (* We rely on the client's cache mechanism to store in memory the - extracted delegate keys. *) - method! load _ ~default _ = return default - - method! write _ _ _ = return_unit - - method! with_lock f = f () - end - -module Sorted_baker_map = Map.Make (struct - type t = Signature.Public_key_hash.t * Tez.t - - let compare (h, x) (h', x') = - (* Descending order *) - let v = Tez.compare x' x in - if v <> 0 then v else Signature.Public_key_hash.compare h h' -end) - -module Consensus_key_set = Set.Make (struct - type t = Signature.Public_key.t * Signature.Public_key_hash.t - - let compare = compare -end) - -type ctxt_kind = - | Wrapped of Protocol_client_context.full - | Generic of Client_context.full - -let load_client_context (cctxt : ctxt_kind) = - let cctxt = - match cctxt with - | Wrapped x -> x - | Generic cctxt -> new Protocol_client_context.wrap_full cctxt - in - let open Lwt_result_syntax in - let open Protocol_client_context in - let* (b : Tezos_shell_services.Block_services.Proof.raw_context) = - Alpha_block_services.Context.read - cctxt - ["active_delegate_with_one_roll"; "current"] - in - let rec get_pkhs (p : string -> Signature.Public_key_hash.t) - (d : Tezos_shell_services.Block_services.Proof.raw_context) acc = - match d with - | Key _b -> assert false - | Dir m -> - String.Map.fold - (function - | "ed25519" -> - get_pkhs (fun s -> - Signature.( - Ed25519 (Ed25519.Public_key_hash.of_hex_exn (`Hex s)))) - | "p256" -> - get_pkhs (fun s -> - Signature.(P256 (P256.Public_key_hash.of_hex_exn (`Hex s)))) - | "secp256k1" -> - get_pkhs (fun s -> - Signature.( - Secp256k1 (Secp256k1.Public_key_hash.of_hex_exn (`Hex s)))) - | s -> fun _v acc -> p s :: acc) - m - acc - | _ -> assert false - in - let delegates = get_pkhs (fun _ -> assert false) b [] |> List.rev in - let* sorted_bakers = - List.fold_left_es - (fun acc delegate -> - let*! r = - Alpha_services.Delegate.consensus_key cctxt (`Main, `Head 0) delegate - in - let* delegate_frozen_deposits = - Alpha_services.Delegate.frozen_deposits - cctxt - (`Main, `Head 0) - delegate - in - let k = (delegate, delegate_frozen_deposits) in - match r with - | Error _ -> return (Sorted_baker_map.add k Consensus_key_set.empty acc) - | Ok ck_info -> - let open Alpha_services.Delegate in - let cks = - let pendings = - List.map - (fun (_, ck) -> (ck.consensus_key_pk, ck.consensus_key_pkh)) - ck_info.pendings - in - if - Signature.Public_key_hash.( - ck_info.active.consensus_key_pkh = delegate) - then pendings - else - ( ck_info.active.consensus_key_pk, - ck_info.active.consensus_key_pkh ) - :: pendings - in - let cks_set = Consensus_key_set.of_list cks in - return (Sorted_baker_map.add k cks_set acc)) - Sorted_baker_map.empty - delegates - in - let mk_unencrypted f x = - Uri.of_string (Format.sprintf "unencrypted:%s" (f x)) - in - let random_sk = - let b = Bytes.create 32 in - fun (pk : Signature.public_key) : Signature.secret_key -> - let open Signature in - let algo : algo = - match pk with - | Ed25519 _ -> Ed25519 - | Secp256k1 _ -> Secp256k1 - | P256 _ -> P256 - | _ -> assert false - in - let i = Random.bits () |> Int32.of_int in - Bytes.set_int32_be b 0 i ; - let _, _, sk = V_latest.generate_key ~algo ~seed:b () in - sk - in - let* delegates_l = - List.mapi_es - (fun i ((pkh, _), cks) -> - let alias = Format.sprintf "baker_%d" i in - let make ?pk alias pkh = - let* pk_opt = - match pk with - | None -> - Alpha_services.Contract.manager_key cctxt (`Main, `Head 0) pkh - | Some pk -> return_some pk - in - let pk = WithExceptions.Option.get ~loc:__LOC__ pk_opt in - let pk_uri = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Client_keys.make_pk_uri - (mk_unencrypted Signature.Public_key.to_b58check pk) - in - let sk_uri = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Client_keys.make_sk_uri - (mk_unencrypted - Signature.Secret_key.to_b58check - (random_sk pk)) - in - return (alias, pkh, pk, pk_uri, sk_uri) - in - let* baker = make alias pkh in - let* cks = - List.mapi_es - (fun i (ck_pk, ck_pkh) -> - make ~pk:ck_pk (Printf.sprintf "%s_ck_%d" alias i) ck_pkh) - (Consensus_key_set.elements cks) - in - return (baker :: cks)) - (Sorted_baker_map.bindings sorted_bakers) - in - let delegates = List.flatten delegates_l in - let* () = Client_keys.register_keys cctxt delegates in - return_unit - -let get_delegates (cctxt : Protocol_client_context.full) = - let proj_delegate (alias, public_key_hash, public_key, secret_key_uri) = - { - Baking_state.alias = Some alias; - public_key_hash; - public_key; - secret_key_uri; - } - in - let* keys = Client_keys.get_keys cctxt in - let delegates = List.map proj_delegate keys in - - let* () = - Tezos_signer_backends.Encrypted.decrypt_list - cctxt - (List.filter_map - (function - | {Baking_state.alias = Some alias; _} -> Some alias | _ -> None) - delegates) - in - let delegates_no_duplicates = List.sort_uniq compare delegates in - let*! () = - if List.compare_lengths delegates delegates_no_duplicates <> 0 then - cctxt#warning - "Warning: the list of public key hash aliases contains duplicate \ - hashes, which are ignored" - else Lwt.return_unit - in - return delegates_no_duplicates - -let get_current_proposal cctxt ?cache () = - let* block_stream, block_stream_stopper = - Node_rpc.monitor_heads cctxt ?cache ~chain:cctxt#chain () - in - let*! stream_head = Lwt_stream.get block_stream in - match stream_head with - | Some current_head -> - return (block_stream, current_head, block_stream_stopper) - | None -> failwith "head stream unexpectedly ended" - -let create_state cctxt ?synchronize ?monitor_node_mempool ~config - ~current_proposal delegates = - let open Lwt_result_syntax in - let chain = cctxt#chain in - let monitor_node_operations = monitor_node_mempool in - let* chain_id = Shell_services.Chain.chain_id cctxt ~chain () in - let* constants = - Protocol.Alpha_services.Constants.all cctxt (`Hash chain_id, `Head 0) - in - let*! operation_worker = - Operation_worker.create ?monitor_node_operations ~constants cctxt - in - Baking_scheduling.create_initial_state - cctxt - ?synchronize - ~chain - config - operation_worker - ~current_proposal - delegates - -let compute_current_round_duration round_durations - ~(predecessor : Baking_state.block_info) round = - let open Result_syntax in - let* start = - Round.timestamp_of_round - round_durations - ~predecessor_timestamp:predecessor.shell.timestamp - ~predecessor_round:predecessor.round - ~round - in - let start = Timestamp.to_seconds start in - let* _end = - Round.timestamp_of_round - round_durations - ~predecessor_timestamp:predecessor.shell.timestamp - ~predecessor_round:predecessor.round - ~round:(Round.succ round) - in - let _end = Timestamp.to_seconds _end in - Ok (Ptime.Span.of_int_s Int64.(sub _end start |> to_int)) - -let one_minute = Ptime.Span.of_int_s 60 - -let wait_next_block block_stream current_proposal = - let open Baking_state in - let open Lwt_syntax in - Lwt.catch - (fun () -> - Lwt_unix.with_timeout 10. @@ fun () -> - let* () = - Lwt_stream.junk_while_s - (fun proposal -> - Lwt.return - (Compare.Int32.( - current_proposal.block.shell.level = proposal.block.shell.level) - && Round.(current_proposal.block.round = proposal.block.round))) - block_stream - in - let* new_block_opt = Lwt_stream.get block_stream in - WithExceptions.Option.get ~loc:__LOC__ new_block_opt |> Lwt.return) - (function - | Lwt_unix.Timeout -> - Format.printf - "Failed to receive expected block, continuing anyway...@." ; - Lwt.return current_proposal - | exn -> Lwt.fail exn) - -let check_round_duration cctxt ?round_duration_target () = - let open Lwt_result_syntax in - let* param = Alpha_services.Constants.parametric cctxt (`Main, `Head 0) in - match round_duration_target with - | None -> - let*? r = - Period.mult 4l param.minimal_block_delay |> Environment.wrap_tzresult - in - let r = Period.to_seconds r |> Int64.to_int |> Ptime.Span.of_int_s in - Format.printf "Default round duration target set to %a@." Ptime.Span.pp r ; - return r - | Some target -> - let minimal_proto_period = - Period.add param.delay_increment_per_round param.minimal_block_delay - |> WithExceptions.Result.get_ok ~loc:__LOC__ - in - let minimal_round_target = - max 5L (Period.to_seconds minimal_proto_period) |> Int64.to_int - in - if target < minimal_round_target then - failwith - "Invalid round duration target, the minimal accepted round duration \ - target for this chain is %a" - Ptime.Span.pp - (Ptime.Span.of_int_s minimal_round_target) - else return (Ptime.Span.of_int_s target) - -let sync_node (cctxt : Client_context.full) ?round_duration_target () = - let open Lwt_result_syntax in - let*! () = Tezos_base_unix.Internal_event_unix.close () in - let cctxt = new wrap_silent_memory_client cctxt in - let* round_duration_target = - check_round_duration cctxt ?round_duration_target () - in - Format.printf "Loading faked delegate keys@." ; - let* () = load_client_context (Wrapped cctxt) in - let* delegates = get_delegates cctxt in - let* block_stream, current_proposal, stopper = - get_current_proposal cctxt () - in - let* is_pred_metadata_present = - let*! r = - Protocol_client_context.Alpha_block_services.metadata - cctxt - ~block:(`Hash (current_proposal.predecessor.hash, 0)) - () - in - match r with Ok _protocols -> return_true | Error _err -> return_false - in - let* current_proposal = - if not is_pred_metadata_present then ( - Format.printf - "Predecessor's metadata are not present: baking a dummy block@." ; - let* () = - Baking_lib.bake cctxt ~minimal_timestamp:true ~force:true delegates - in - (* Waiting next block... *) - let*! new_proposal = Lwt_stream.get block_stream in - return (WithExceptions.Option.get ~loc:__LOC__ new_proposal)) - else return current_proposal - in - let config = Baking_configuration.make ~force:true () in - let rec loop current_proposal = - let* state = create_state cctxt ~config ~current_proposal delegates in - let*? current_round_duration = - Environment.wrap_tzresult - @@ compute_current_round_duration - state.global_state.round_durations - ~predecessor:state.level_state.latest_proposal.predecessor - state.round_state.current_round - in - Format.printf - "Current head level: %ld, current head round: %a@." - state.level_state.latest_proposal.block.shell.level - Round.pp - state.level_state.latest_proposal.block.round ; - Format.printf - "Current round %a. Duration: %a@." - Round.pp - state.round_state.current_round - Ptime.Span.pp - current_round_duration ; - if Ptime.Span.(compare current_round_duration round_duration_target) > 0 - then ( - Format.printf - "Current round duration is higher than %a, retrying...@." - Ptime.Span.pp - round_duration_target ; - let pred_round = - Result.value - ~default:Round.zero - (Round.pred state.round_state.current_round) - in - Format.printf "Proposing at previous round: %a@." Round.pp pred_round ; - let* () = - Baking_lib.repropose cctxt delegates ~force:true ~force_round:pred_round - in - let*! new_block = wait_next_block block_stream current_proposal in - Format.printf "Baking at next level with minimal round@." ; - let* () = - Baking_lib.bake cctxt delegates ~force:true ~minimal_timestamp:true - in - let*! new_block = wait_next_block block_stream new_block in - loop new_block) - else ( - Format.printf - "Current round duration is %a which is less than %a. Bakers may now be \ - started@." - Ptime.Span.pp - current_round_duration - Ptime.Span.pp - round_duration_target ; - return_unit) - in - let* () = loop current_proposal in - stopper () ; - let*! () = - Tezos_base_unix.Internal_event_unix.( - init ~config:(make_with_defaults ()) ()) - in - return_unit - -(** Manager injector *) - -module ManagerMap = Signature.Public_key_hash.Map -module ManagerSet = Signature.Public_key_hash.Set - -type injected_operation = { - original_hash : Operation_hash.t; - modified_hash : Operation_hash.t; -} - -type t = { - last_injected_op_per_manager : injected_operation ManagerMap.t; - operation_queues : (Operation_hash.t * packed_operation) Queue.t ManagerMap.t; -} - -let pp_state fmt {last_injected_op_per_manager; operation_queues} = - Format.fprintf - fmt - "%d injected operations pending, %d manager queues left" - (ManagerMap.cardinal last_injected_op_per_manager) - (ManagerMap.cardinal operation_queues) - -let pp_initial_state fmt {operation_queues; _} = - Format.( - fprintf - fmt - "@[%d manager queues:@ %a@]@." - (ManagerMap.cardinal operation_queues) - (pp_print_list ~pp_sep:pp_print_cut (fun fmt (manager, queue) -> - Format.fprintf - fmt - "%a: %d" - Signature.Public_key_hash.pp - manager - (Queue.length queue))) - (ManagerMap.bindings operation_queues)) - -let init ~operations_file_path = - Format.printf "Parsing operations file@." ; - let op_encoding = Protocol.Alpha_context.Operation.encoding in - let buffer = Bytes.create (10 * 1024 * 1024) (* 10mb *) in - let*! ic = Lwt_io.open_file ~mode:Input operations_file_path in - let rec loop acc = - let*! op_len = - Lwt.catch - (fun () -> - let*! op_len = Lwt_io.BE.read_int32 ic in - let*! () = - Lwt_io.read_into_exactly ic buffer 0 (Int32.to_int op_len) - in - Lwt.return_ok (`Op_len op_len)) - (function - | End_of_file -> Lwt.return_ok `EOF - | exn -> failwith "%s" (Printexc.to_string exn)) - in - match op_len with - | Error x -> Lwt.return_error x - | Ok `EOF -> return (List.rev acc) - | Ok (`Op_len op_len) -> - let op = - Data_encoding.Binary.of_bytes_exn - op_encoding - (Bytes.sub buffer 0 (Int32.to_int op_len)) - in - loop (op :: acc) - in - let total = ref 0 in - let* all_ops = loop [] in - let*! () = Lwt_io.close ic in - Format.printf "Loading operations file@." ; - let rec loop - (acc : (Operation_hash.t * packed_operation) Queue.t ManagerMap.t) : - packed_operation list -> - (Operation_hash.t * packed_operation) Queue.t ManagerMap.t = function - | [] -> acc - | ({ - protocol_data = - Operation_data {contents = Single (Manager_operation {source; _}); _}; - _; - } as op) - :: r - | ({ - protocol_data = - Operation_data - {contents = Cons (Manager_operation {source; _}, _); _}; - _; - } as op) - :: r -> - incr total ; - let oph = Operation.hash_packed op in - let acc = - ManagerMap.update - source - (function - | None -> - let q = Queue.create () in - Queue.add (oph, op) q ; - Some q - | Some q -> - Queue.add (oph, op) q ; - Some q) - acc - in - loop acc r - | _non_manager_op :: r -> loop acc r - in - let operation_queues = loop ManagerMap.empty all_ops in - Format.printf "%d manager operations loaded@." !total ; - return - { - last_injected_op_per_manager = Signature.Public_key_hash.Map.empty; - operation_queues; - } - -let choose_new_operations state prohibited_managers n = - (* Prioritize large operations queues *) - let sorted_queues = - ManagerMap.bindings state.operation_queues - |> List.sort (fun (_, q) (_, q') -> - Int.compare (Queue.length q') (Queue.length q)) - in - let ops = ref [] in - let cpt = ref 0 in - let updated_operation_queues = ref state.operation_queues in - let selected_ops = - let exception End in - try - List.iter - (fun (manager, op_q) -> - if !cpt = n then raise End ; - if not (ManagerSet.mem manager prohibited_managers) then - match Queue.take_opt op_q with - | Some op -> - incr cpt ; - ops := (manager, op) :: !ops - | None -> - updated_operation_queues := - ManagerMap.remove manager !updated_operation_queues) - sorted_queues ; - !ops - with End -> !ops - in - let state = {state with operation_queues = !updated_operation_queues} in - (selected_ops, state) - -let choose_and_inject_operations cctxt state prohibited_managers n = - let* finalized_head = Shell_services.Blocks.hash cctxt ~block:(`Head 2) () in - let cpt = ref 0 in - let errors = ref 0 in - let updated_state = ref state in - let exception End in - let* nb_injected, nb_erroneous, new_state = - Lwt.catch - (fun () -> - let* () = - ManagerMap.iter_es - (fun manager op_q -> - let* () = if !cpt = n then raise End else return_unit in - if ManagerSet.mem manager prohibited_managers then return_unit - else - match Queue.take_opt op_q with - | None -> - updated_state := - { - !updated_state with - operation_queues = - ManagerMap.remove - manager - !updated_state.operation_queues; - } ; - return_unit - | Some (original_hash, op) -> ( - let modified_op = - {op with shell = {branch = finalized_head}} - in - let modified_hash = Operation.hash_packed modified_op in - let op = {modified_hash; original_hash} in - let*! injection_result = - Shell_services.Injection.operation - cctxt - (Data_encoding.Binary.to_bytes_exn - Operation.encoding - modified_op) - in - match injection_result with - | Ok _h -> - incr cpt ; - updated_state := - { - !updated_state with - last_injected_op_per_manager = - ManagerMap.add - manager - op - !updated_state.last_injected_op_per_manager; - } ; - return_unit - | Error _err -> - incr errors ; - updated_state := - { - !updated_state with - operation_queues = - ManagerMap.remove - manager - !updated_state.operation_queues; - } ; - return_unit)) - state.operation_queues - in - return (!cpt, !errors, !updated_state)) - (function - | End -> return (!cpt, !errors, !updated_state) | exn -> Lwt.fail exn) - in - Format.printf - "%d new manager operations injected, %d erroneous operation manager queues \ - discarded@." - nb_injected - nb_erroneous ; - return new_state - -let start_injector cctxt ~op_per_mempool ~min_manager_queues - ~operations_file_path = - let* state = init ~operations_file_path in - Format.printf "Starting injector@." ; - let* head_stream, _stopper = Monitor_services.heads cctxt `Main in - let block_stream = - Lwt_stream.map_s - (fun (bh, header) -> - let*! opl = - Protocol_client_context.Alpha_block_services.Operations - .operations_in_pass - cctxt - ~metadata:`Always - ~block:(`Hash (bh, 0)) - Operation_repr.manager_pass - in - let opl = WithExceptions.Result.get_ok ~loc:__LOC__ opl in - Lwt.return (header, opl)) - head_stream - in - let*! current_head_opt = Lwt_stream.get block_stream in - let ((header, _mopl) as _current_head) = - WithExceptions.Option.get ~loc:__LOC__ current_head_opt - in - let current_level = header.shell.level in - let rec loop state current_level = - let*! r = Lwt_stream.get block_stream in - match r with - | None -> failwith "Head stream ended: lost connection with node?" - | Some (header, _opll) - when Compare.Int32.(header.shell.level <= current_level) -> - (* reorg *) - Format.printf "New head with non-increasing level: ignoring@." ; - loop state current_level - | Some (_header, mopl) as _new_head -> - Format.printf - "New increasing head received with %d included operations@." - (List.length mopl) ; - let* mempool = - Protocol_client_context.Alpha_block_services.Mempool - .pending_operations - cctxt - ~validated:true - ~refused:false - ~outdated:false - ~branch_refused:false - ~branch_delayed:false - ~validation_passes:[Operation_repr.manager_pass] - () - in - let live_operations = - Operation_hash.Set.( - union - (of_list - (List.map - fst - (Operation_hash.Map.bindings mempool.unprocessed))) - (of_list (List.map fst mempool.validated))) - in - Format.printf - "%d manager operations still live in the mempool@." - (Operation_hash.Set.cardinal live_operations) ; - let new_last_injected, prohibited_managers = - let last_injected_op_per_manager = - state.last_injected_op_per_manager - in - ManagerMap.fold - (fun manager {modified_hash; _} (new_last_injected, acc) -> - if Operation_hash.Set.mem modified_hash live_operations then - (new_last_injected, ManagerSet.add manager acc) - else (ManagerMap.remove manager new_last_injected, acc)) - last_injected_op_per_manager - (last_injected_op_per_manager, ManagerSet.empty) - in - let state = - {state with last_injected_op_per_manager = new_last_injected} - in - let nb_missing_operations = - op_per_mempool - - ManagerMap.cardinal state.last_injected_op_per_manager - in - Format.printf - "Injecting %d new manager operations...@." - nb_missing_operations ; - let* state = - choose_and_inject_operations - cctxt - state - prohibited_managers - nb_missing_operations - in - let remaining_manager_queues = - ManagerMap.cardinal state.operation_queues - in - Format.printf "Current state: %a@." pp_state state ; - (* Stop when there the number of manager operation queues left is lower - than `min_manager_queues`. *) - if remaining_manager_queues < min_manager_queues then ( - Format.printf - "Not enough manager operation queues left to continue the \ - experiment (%d left, %d required). Terminating.@. " - remaining_manager_queues - min_manager_queues ; - return_unit) - else loop state header.shell.level - in - loop state current_level - -(* Block time "hot-patch" *) - -type cycle_era = { - first_level : Raw_level_repr.t; - first_cycle : Cycle_repr.t; - blocks_per_cycle : int32; - blocks_per_commitment : int32; -} - -(* Copy-paste of the protocol abstracted cycle_eras type and - encoding *) - -type cycle_eras = cycle_era list - -let cycle_eras_encoding = - let open Result_syntax in - let create_cycle_eras cycle_eras = - match cycle_eras with - | [] -> assert false - | newest_era :: older_eras -> - let rec aux {first_level; first_cycle; _} older_eras = - match older_eras with - | ({ - first_level = first_level_of_previous_era; - first_cycle = first_cycle_of_previous_era; - _; - } as previous_era) - :: even_older_eras -> - if - Raw_level_repr.(first_level > first_level_of_previous_era) - && Cycle_repr.(first_cycle > first_cycle_of_previous_era) - then aux previous_era even_older_eras - else assert false - | [] -> return_unit - in - let* () = aux newest_era older_eras in - return cycle_eras - in - let cycle_era_encoding = - let open Data_encoding in - conv - (fun {first_level; first_cycle; blocks_per_cycle; blocks_per_commitment} -> - (first_level, first_cycle, blocks_per_cycle, blocks_per_commitment)) - (fun (first_level, first_cycle, blocks_per_cycle, blocks_per_commitment) -> - {first_level; first_cycle; blocks_per_cycle; blocks_per_commitment}) - (obj4 - (req - "first_level" - ~description:"The first level of a new cycle era." - Raw_level_repr.encoding) - (req - "first_cycle" - ~description:"The first cycle of a new cycle era." - Cycle_repr.encoding) - (req - "blocks_per_cycle" - ~description: - "The value of the blocks_per_cycle constant used during the \ - cycle era starting with first_level." - int32) - (req - "blocks_per_commitment" - ~description: - "The value of the blocks_per_commitment constant used during the \ - cycle era starting with first_level." - int32)) - in - Data_encoding.conv_with_guard - (fun eras -> eras) - (fun eras -> - match create_cycle_eras eras with - | Ok eras -> Ok eras - | Error _ -> Error "Invalid cycle eras") - (Data_encoding.list cycle_era_encoding) - -let patch_block_time ctxt ~head_level ~block_time_target ~patch_max_op_ttl = - let pf = Format.printf in - let open Environment in - let patch_flag_key = ["patch_flag"] in - let* () = - let*! opt = Context.find ctxt patch_flag_key in - match opt with - | Some _ -> - failwith - "The context was already patched with a custom block time. The patch \ - must be applied on a fresh context." - | None -> return_unit - in - let constants_key = ["v1"; "constants"] in - let* (constants : Constants_parametric_repr.t) = - let*! opt = Context.find ctxt constants_key in - match opt with - | None -> failwith "Internal error: cannot read constants in context." - | Some bytes -> ( - match - Data_encoding.Binary.of_bytes_opt - Constants_parametric_repr.encoding - bytes - with - | None -> failwith "Internal error: cannot parse constants in context." - | Some constants -> return constants) - in - let current_block_time = - Int64.to_int @@ Period_repr.to_seconds constants.minimal_block_delay - in - let speedup_ratio = float current_block_time /. float block_time_target in - let blocks_per_cycle = - float (Int32.to_int constants.blocks_per_cycle) *. speedup_ratio - |> int_of_float |> Int32.of_int - in - let hard_gas_limit_per_block = - let patched_block_gas_limit = - let b_gas_lim_f = - Gas_limit_repr.Arith.integral_to_z constants.hard_gas_limit_per_block - |> Z.to_int |> float - in - b_gas_lim_f /. speedup_ratio - |> int_of_float |> Gas_limit_repr.Arith.integral_of_int_exn - in - Gas_limit_repr.Arith.max - constants.hard_gas_limit_per_operation - patched_block_gas_limit - in - let proof_of_work_threshold = - Int64.shift_right - constants.proof_of_work_threshold - (max 0 (log speedup_ratio /. log 2. |> int_of_float)) - in - let max_operations_time_to_live = - if patch_max_op_ttl then - float constants.max_operations_time_to_live *. speedup_ratio - |> int_of_float - else constants.max_operations_time_to_live - in - let minimal_block_delay = - Period_repr.of_seconds_exn (Int64.of_int block_time_target) - in - let delay_increment_per_round = - Period_repr.of_seconds_exn (Int64.of_int (max 1 (block_time_target / 2))) - in - let blocks_per_commitment = constants.blocks_per_commitment in - pf "Block time speed up ratio: %.2f%%@." (speedup_ratio *. 100.) ; - pf - "Minimal block delay: %a -> %a@." - Period_repr.pp - constants.minimal_block_delay - Period_repr.pp - minimal_block_delay ; - pf - "Delay increment per round: %a -> %a@." - Period_repr.pp - constants.delay_increment_per_round - Period_repr.pp - delay_increment_per_round ; - pf "Block per cycle: %ld -> %ld@." constants.blocks_per_cycle blocks_per_cycle ; - pf - "Hard gas limit per block: %a -> %a (minimum = hard gas limit per op. = \ - %a)@." - Gas_limit_repr.Arith.pp - constants.hard_gas_limit_per_block - Gas_limit_repr.Arith.pp - hard_gas_limit_per_block - Gas_limit_repr.Arith.pp - constants.hard_gas_limit_per_operation ; - pf - "Proof of work difficulty: %.1f -> %.1f@." - (log (float (Int64.to_int constants.proof_of_work_threshold))) - (log (float (Int64.to_int proof_of_work_threshold))) ; - pf - "Max operations time to live: %d -> %d@." - constants.max_operations_time_to_live - max_operations_time_to_live ; - let patched_constants = - { - constants with - Constants_parametric_repr.minimal_block_delay; - delay_increment_per_round; - blocks_per_cycle; - hard_gas_limit_per_block; - proof_of_work_threshold; - max_operations_time_to_live; - } - |> Data_encoding.Binary.to_bytes_exn Constants_parametric_repr.encoding - in - let cycle_eras_key = ["v1"; "cycle_eras"] in - let* patched_cycle_eras = - let*! opt = Context.find ctxt cycle_eras_key in - match opt with - | None -> failwith "Internal error: cannot read cycle eras in context." - | Some bytes -> ( - match Data_encoding.Binary.of_bytes_opt cycle_eras_encoding bytes with - | Some (latest_era :: _rest as l) -> - let head_level = Raw_level_repr.of_int32_exn head_level in - let cycle = - let level_position_in_era = - Raw_level_repr.diff head_level latest_era.first_level - in - let cycles_since_era_start = - Int32.div level_position_in_era latest_era.blocks_per_cycle - in - Cycle_repr.add - latest_era.first_cycle - (Int32.to_int cycles_since_era_start) - in - let cycle_eras = - { - first_level = head_level; - first_cycle = cycle; - blocks_per_cycle; - blocks_per_commitment; - } - :: l - in - return - (Data_encoding.Binary.to_bytes_exn cycle_eras_encoding cycle_eras) - | _ -> failwith "Internal error: cannot parse cycle eras in context.") - in - let*! ctxt = Context.add ctxt constants_key patched_constants in - let*! ctxt = Context.add ctxt cycle_eras_key patched_cycle_eras in - let*! ctxt = Context.add ctxt patch_flag_key Bytes.empty in - return ctxt - -module Tool : Sigs.PROTO_TOOL = struct - let extract_client_context cctxt = load_client_context (Generic cctxt) - - let sync_node = sync_node - - let start_injector = start_injector - - let patch_block_time = patch_block_time -end - -let () = Sigs.register Protocol.hash (module Tool) diff --git a/devtools/yes_wallet/dune b/devtools/yes_wallet/dune index 3ef19a3b67e2..d4e814c7d464 100644 --- a/devtools/yes_wallet/dune +++ b/devtools/yes_wallet/dune @@ -10,7 +10,6 @@ ezjsonm octez-node-config octez-shell-libs.store - tezos-protocol-020-PsParisC.protocol tezos-protocol-021-PsQuebec.protocol tezos-protocol-alpha.protocol) (library_flags (:standard -linkall)) diff --git a/devtools/yes_wallet/get_delegates_020_PsParisC.ml b/devtools/yes_wallet/get_delegates_020_PsParisC.ml deleted file mode 100644 index 2d0ebf260639..000000000000 --- a/devtools/yes_wallet/get_delegates_020_PsParisC.ml +++ /dev/null @@ -1,130 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 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 Get_delegates = struct - open Tezos_protocol_020_PsParisC - open Protocol - - type context = Alpha_context.t - - type contract = Alpha_context.Contract.t - - let hash = hash - - module Tez = struct - include Alpha_context.Tez - - let ( +? ) a b = Environment.wrap_tzresult (a +? b) - end - - module Signature = struct - include Tezos_crypto.Signature.V1 - module To_latest = Tezos_crypto.Signature.Of_V1 - module Of_latest = Tezos_crypto.Signature.Of_V_latest - end - - module Contract = struct - open Alpha_context.Contract - - let get_manager_key context public_key_hash = - Alpha_context.Contract.get_manager_key context public_key_hash - |> Lwt.map Environment.wrap_tzresult - - let fold context ~init ~f = - let open Lwt_syntax in - let* l = list context in - Lwt_list.fold_left_s f init l - - let balance ctxt t = get_balance ctxt t |> Lwt.map Environment.wrap_tzresult - - let frozen_bonds ctxt t = - get_frozen_bonds ctxt t |> Lwt.map Environment.wrap_tzresult - - let get_staked_balance ctxt t = - For_RPC.get_staked_balance ctxt t |> Lwt.map Environment.wrap_tzresult - - let get_unstaked_frozen_balance ctxt t = - For_RPC.get_unstaked_frozen_balance ctxt t - |> Lwt.map Environment.wrap_tzresult - - let get_unstaked_finalizable_balance ctxt t = - For_RPC.get_unstaked_finalizable_balance ctxt t - |> Lwt.map Environment.wrap_tzresult - - let get_full_balance ctxt t = - For_RPC.get_full_balance ctxt t |> Lwt.map Environment.wrap_tzresult - - let contract_address contract = Alpha_context.Contract.to_b58check contract - - let total_supply ctxt = - Alpha_context.Contract.get_total_supply ctxt - |> Lwt.map Environment.wrap_tzresult - end - - module Commitment = struct - include Alpha_context.Commitment - - type t = Blinded_public_key_hash.t - - let fold ctxt ~order ~init ~f = - fold ctxt ~order ~init ~f:(fun c t acc -> f c (Tez_repr.to_mutez t) acc) - end - - module Delegate = struct - open Alpha_context.Delegate - - let fold ctxt ~order ~init ~f = fold ctxt ~order ~init ~f - - let pubkey ctxt pkh = - Alpha_context.Contract.get_manager_key ctxt pkh - |> Lwt.map Environment.wrap_tzresult - - let staking_balance ctxt pkh = - For_RPC.staking_balance ctxt pkh |> Lwt.map Environment.wrap_tzresult - - let current_frozen_deposits ctxt pkh = - current_frozen_deposits ctxt pkh |> Lwt.map Environment.wrap_tzresult - - let unstaked_frozen_deposits ctxt pkh = - Alpha_context.Unstaked_frozen_deposits.balance - ctxt - pkh - Alpha_context.Level.(current ctxt).cycle - |> Lwt.map Environment.wrap_tzresult - - let deactivated ctxt pkh = - deactivated ctxt pkh |> Lwt.map Environment.wrap_tzresult - end - - let prepare_context ctxt ~level ~predecessor_timestamp ~timestamp = - let open Lwt_result_syntax in - let+ ctxt, _, _ = - Alpha_context.prepare ctxt ~level ~predecessor_timestamp ~timestamp - |> Lwt.map Environment.wrap_tzresult - in - ctxt -end - -let () = Known_protocols.register (module Get_delegates) diff --git a/docs/doc_gen/dune b/docs/doc_gen/dune index 6b2e26e76201..1701668939db 100644 --- a/docs/doc_gen/dune +++ b/docs/doc_gen/dune @@ -17,7 +17,6 @@ octez-libs.data-encoding re tezos-protocol-genesis.embedded-protocol - tezos-protocol-020-PsParisC.embedded-protocol tezos-protocol-021-PsQuebec.embedded-protocol tezos-protocol-alpha.embedded-protocol) (link_flags diff --git a/dune-project b/dune-project index 8262a4caa12e..d8a8e417049e 100644 --- a/dune-project +++ b/dune-project @@ -14,11 +14,9 @@ (package (name internal-devtools_proto-context-du)) (package (name kaitai)) (package (name kaitai-of-data-encoding)) -(package (name octez-accuser-PsParisC)) (package (name octez-accuser-PsQuebec)) (package (name octez-accuser-alpha)) (package (name octez-alcotezt)) -(package (name octez-baker-PsParisC)) (package (name octez-baker-PsQuebec)) (package (name octez-baker-alpha)) (package (name octez-client)) @@ -100,7 +98,6 @@ (package (name tezos-benchmark-alpha)) (package (name tezos-benchmark-examples)) (package (name tezos-benchmark-tests)(allow_empty)) -(package (name tezos-benchmark-type-inference-020-PsParisC)) (package (name tezos-benchmark-type-inference-021-PsQuebec)) (package (name tezos-benchmark-type-inference-alpha)) (package (name tezos-benchmarks-proto-021-PsQuebec)) @@ -109,7 +106,6 @@ (package (name tezos-client-genesis)) (package (name tezos-dal-node-lib)) (package (name tezos-dal-node-services)) -(package (name tezos-injector-020-PsParisC)(allow_empty)) (package (name tezos-injector-021-PsQuebec)(allow_empty)) (package (name tezos-injector-alpha)(allow_empty)) (package (name tezos-lazy-containers-tests)(allow_empty)) diff --git a/manifest/product_octez.ml b/manifest/product_octez.ml index cf17d7bb62fd..6aed7f9acb11 100644 --- a/manifest/product_octez.ml +++ b/manifest/product_octez.ml @@ -6501,7 +6501,7 @@ let hash = Protocol.hash ~linkall:true in let test_helpers = - only_if (active && not N.(number == 020)) @@ fun () -> + only_if active @@ fun () -> octez_protocol_lib "test-helpers" ~path:(path // "lib_protocol/test/helpers") @@ -6532,7 +6532,7 @@ let hash = Protocol.hash in let _plugin_tests = opt_map (both plugin test_helpers) @@ fun (plugin, test_helpers) -> - only_if (active && not N.(number == 020)) @@ fun () -> + only_if active @@ fun () -> tezt [ "helpers"; @@ -6563,7 +6563,7 @@ let hash = Protocol.hash ] in let _client_tests = - only_if (active && not N.(number == 020)) @@ fun () -> + only_if active @@ fun () -> tezt [ "test_michelson_v1_macros"; @@ -6724,7 +6724,7 @@ let hash = Protocol.hash else ["Baking_commands"; "Baking_commands_registration"]) in let tenderbrute = - only_if (active && not N.(number == 020)) @@ fun () -> + only_if active @@ fun () -> octez_protocol_lib "baking.tenderbrute" ~internal_name:(sf "tenderbrute_%s" name_underscore) @@ -6743,8 +6743,7 @@ let hash = Protocol.hash ~bisect_ppx:No in let _tenderbrute_exe = - only_if (active && N.(number >= 013) && not N.(number == 020)) - @@ fun () -> + only_if (active && N.(number >= 013)) @@ fun () -> test "tenderbrute_main" ~alias:"" @@ -6767,7 +6766,7 @@ let hash = Protocol.hash in let _baking_tests = opt_map (both baking test_helpers) @@ fun (baking, test_helpers) -> - only_if (active && not N.(number == 020)) @@ fun () -> + only_if active @@ fun () -> let mockup_simulator = only_if N.(number >= 012) @@ fun () -> octez_protocol_lib @@ -6948,8 +6947,7 @@ let hash = Protocol.hash ~linkall:true in let _dal_tests = - only_if (active && N.(number >= 016) && not N.(number == 020)) - @@ fun () -> + only_if (active && N.(number >= 016)) @@ fun () -> tezt ["test_dal_slot_frame_encoding"; "test_helpers"] ~path:(path // "lib_dal/test") @@ -7103,7 +7101,7 @@ let hash = Protocol.hash ] in let _benchmark_type_inference_tests = - only_if (active && not N.(number == 020)) @@ fun () -> + only_if active @@ fun () -> tests ["test_uf"; "test_inference"] ~path:(path // "lib_benchmark/lib_benchmark_type_inference/test") @@ -7152,7 +7150,7 @@ let hash = Protocol.hash in let _benchmark_tests = opt_map (both benchmark test_helpers) @@ fun (benchmark, test_helpers) -> - only_if (active && not N.(number == 020)) @@ fun () -> + only_if active @@ fun () -> (* Note: to enable gprof profiling, manually add the following stanza to lib_benchmark/test/dune: (ocamlopt_flags (:standard -p -ccopt -no-pie)) *) @@ -7226,7 +7224,7 @@ let hash = Protocol.hash ~linkall:true in let _ = - if active && not N.(number == 020) then + if active then Lib_protocol.make_tests ?test_helpers ?parameters @@ -7329,7 +7327,7 @@ let hash = Protocol.hash let _019_PtParisB = frozen (Name.v "PtParisB" 019) - let _020_PsParisC = active (Name.v "PsParisC" 020) + let _020_PsParisC = frozen (Name.v "PsParisC" 020) let _021_PsQuebec = active (Name.v "PsQuebec" 021) diff --git a/opam/octez-accuser-PsParisC.opam b/opam/octez-accuser-PsParisC.opam deleted file mode 100644 index 6f44f8e9a9fd..000000000000 --- a/opam/octez-accuser-PsParisC.opam +++ /dev/null @@ -1,26 +0,0 @@ -# This file was automatically generated, do not edit. -# Edit file manifest/main.ml instead. -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" { >= "3.11.1" } - "ocaml" { >= "4.14" } - "octez-rustzcash-deps" { = version } - "bls12-381" { = version } - "octez-libs" { = version } - "tezos-protocol-020-PsParisC" { = version } - "octez-protocol-020-PsParisC-libs" { = version } - "octez-shell-libs" { = version } -] -build: [ - ["rm" "-r" "vendors" "contrib"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -available: os-family != "windows" -synopsis: "Tezos/Protocol: accuser binary" diff --git a/opam/octez-baker-PsParisC.opam b/opam/octez-baker-PsParisC.opam deleted file mode 100644 index b4360ad40547..000000000000 --- a/opam/octez-baker-PsParisC.opam +++ /dev/null @@ -1,26 +0,0 @@ -# This file was automatically generated, do not edit. -# Edit file manifest/main.ml instead. -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" { >= "3.11.1" } - "ocaml" { >= "4.14" } - "octez-rustzcash-deps" { = version } - "bls12-381" { = version } - "octez-libs" { = version } - "tezos-protocol-020-PsParisC" { = version } - "octez-protocol-020-PsParisC-libs" { = version } - "octez-shell-libs" { = version } -] -build: [ - ["rm" "-r" "vendors" "contrib"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -available: os-family != "windows" -synopsis: "Tezos/Protocol: baker binary" diff --git a/opam/octez-client.opam b/opam/octez-client.opam index 29b295dcfb65..d6f8cf800b4d 100644 --- a/opam/octez-client.opam +++ b/opam/octez-client.opam @@ -15,7 +15,6 @@ depends: [ "octez-libs" { = version } "octez-shell-libs" { = version } "uri" { >= "3.1.0" } - "octez-protocol-020-PsParisC-libs" { = version } "octez-protocol-021-PsQuebec-libs" { = version } ] depopts: [ @@ -41,6 +40,7 @@ depopts: [ "octez-protocol-017-PtNairob-libs" "octez-protocol-018-Proxford-libs" "octez-protocol-019-PtParisB-libs" + "octez-protocol-020-PsParisC-libs" "octez-protocol-alpha-libs" ] conflicts: [ @@ -66,6 +66,7 @@ conflicts: [ "octez-protocol-017-PtNairob-libs" { != version } "octez-protocol-018-Proxford-libs" { != version } "octez-protocol-019-PtParisB-libs" { != version } + "octez-protocol-020-PsParisC-libs" { != version } "octez-protocol-alpha-libs" { != version } ] build: [ diff --git a/opam/octez-dal-node.opam b/opam/octez-dal-node.opam index 27e20cc39ec0..42843a6bccc8 100644 --- a/opam/octez-dal-node.opam +++ b/opam/octez-dal-node.opam @@ -21,7 +21,6 @@ depends: [ "opentelemetry" "octez-crawler" { = version } "memtrace" - "octez-protocol-020-PsParisC-libs" { = version } "octez-protocol-021-PsQuebec-libs" { = version } ] depopts: [ diff --git a/opam/octez-injector-server.opam b/opam/octez-injector-server.opam index e1401cccced7..c0ce0a4842fc 100644 --- a/opam/octez-injector-server.opam +++ b/opam/octez-injector-server.opam @@ -17,12 +17,10 @@ depends: [ "octez-shell-libs" { = version } ] depopts: [ - "tezos-injector-020-PsParisC" "tezos-injector-021-PsQuebec" "tezos-injector-alpha" ] conflicts: [ - "tezos-injector-020-PsParisC" { != version } "tezos-injector-021-PsQuebec" { != version } "tezos-injector-alpha" { != version } ] diff --git a/opam/octez-node.opam b/opam/octez-node.opam index 3c747129061a..a8c48935476b 100644 --- a/opam/octez-node.opam +++ b/opam/octez-node.opam @@ -23,8 +23,6 @@ depends: [ "lwt-exit" "uri" { >= "3.1.0" } "tezos-protocol-000-Ps9mPmXa" { = version } - "tezos-protocol-020-PsParisC" { = version } - "octez-protocol-020-PsParisC-libs" { = version } "tezos-protocol-021-PsQuebec" { = version } "octez-protocol-021-PsQuebec-libs" { = version } ] @@ -66,6 +64,8 @@ depopts: [ "octez-protocol-018-Proxford-libs" "tezos-protocol-019-PtParisB" "octez-protocol-019-PtParisB-libs" + "tezos-protocol-020-PsParisC" + "octez-protocol-020-PsParisC-libs" "tezos-protocol-alpha" "octez-protocol-alpha-libs" ] @@ -107,6 +107,8 @@ conflicts: [ "octez-protocol-018-Proxford-libs" { != version } "tezos-protocol-019-PtParisB" { != version } "octez-protocol-019-PtParisB-libs" { != version } + "tezos-protocol-020-PsParisC" { != version } + "octez-protocol-020-PsParisC-libs" { != version } "tezos-protocol-alpha" { != version } "octez-protocol-alpha-libs" { != version } ] diff --git a/opam/octez-protocol-020-PsParisC-libs.opam b/opam/octez-protocol-020-PsParisC-libs.opam index 67a362499c4d..23c9a96f1f9e 100644 --- a/opam/octez-protocol-020-PsParisC-libs.opam +++ b/opam/octez-protocol-020-PsParisC-libs.opam @@ -19,13 +19,6 @@ depends: [ "uri" { >= "3.1.0" } "octez-rustzcash-deps" { with-test & = version } "octez-proto-libs" { = version } - "octez-version" { = version } - "octez-node-config" { = version } - "tezos-dal-node-services" { = version } - "lwt-canceler" { >= "0.3" & < "0.4" } - "lwt-exit" - "octez-protocol-compiler" { = version } - "tezos-dal-node-lib" { = version } "octez-injector" { = version } "octez-l2-libs" { = version } ] diff --git a/opam/octez-smart-rollup-node.opam b/opam/octez-smart-rollup-node.opam index 2f2a8323d622..2463aef43fdf 100644 --- a/opam/octez-smart-rollup-node.opam +++ b/opam/octez-smart-rollup-node.opam @@ -16,19 +16,20 @@ depends: [ "octez-shell-libs" { = version } "octez-l2-libs" { = version } "octez-smart-rollup-node-lib" { = version } - "octez-smart-rollup-node-PsParisC" { = version } "octez-smart-rollup-node-PsQuebec" { = version } ] depopts: [ "octez-smart-rollup-node-PtNairob" "octez-smart-rollup-node-Proxford" "octez-smart-rollup-node-PtParisB" + "octez-smart-rollup-node-PsParisC" "octez-smart-rollup-node-alpha" ] conflicts: [ "octez-smart-rollup-node-PtNairob" { != version } "octez-smart-rollup-node-Proxford" { != version } "octez-smart-rollup-node-PtParisB" { != version } + "octez-smart-rollup-node-PsParisC" { != version } "octez-smart-rollup-node-alpha" { != version } ] build: [ diff --git a/opam/tezos-benchmark-type-inference-020-PsParisC.opam b/opam/tezos-benchmark-type-inference-020-PsParisC.opam deleted file mode 100644 index 00f9a9eb383b..000000000000 --- a/opam/tezos-benchmark-type-inference-020-PsParisC.opam +++ /dev/null @@ -1,24 +0,0 @@ -# This file was automatically generated, do not edit. -# Edit file manifest/main.ml instead. -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" { >= "3.11.1" } - "ocaml" { >= "4.14" } - "octez-libs" { = version } - "tezos-micheline-rewriting" { = version } - "tezos-protocol-020-PsParisC" { = version } - "hashcons" -] -build: [ - ["rm" "-r" "vendors" "contrib"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -available: os-family != "windows" -synopsis: "Tezos: type inference for partial Michelson expressions" diff --git a/opam/tezos-injector-020-PsParisC.opam b/opam/tezos-injector-020-PsParisC.opam deleted file mode 100644 index 2897b16805c9..000000000000 --- a/opam/tezos-injector-020-PsParisC.opam +++ /dev/null @@ -1,25 +0,0 @@ -# This file was automatically generated, do not edit. -# Edit file manifest/main.ml instead. -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" { >= "3.11.1" } - "ocaml" { >= "4.14" } - "octez-libs" { = version } - "tezos-protocol-020-PsParisC" { = version } - "octez-injector" { = version } - "octez-protocol-020-PsParisC-libs" { = version } - "octez-shell-libs" { = version } -] -build: [ - ["rm" "-r" "vendors" "contrib"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -available: os-family != "windows" -synopsis: "Tezos/Protocol: protocol-specific library for the injector binary" diff --git a/opam/tezos-sc-rollup-node-test.opam b/opam/tezos-sc-rollup-node-test.opam index 8e7fcf779a16..ddba8c193f9d 100644 --- a/opam/tezos-sc-rollup-node-test.opam +++ b/opam/tezos-sc-rollup-node-test.opam @@ -14,13 +14,10 @@ depends: [ "bls12-381" {with-test} "octez-rust-deps" {with-test} "octez-libs" {with-test} - "tezos-protocol-020-PsParisC" {with-test} - "octez-protocol-020-PsParisC-libs" {with-test} - "octez-smart-rollup-node-PsParisC" {with-test} - "octez-alcotezt" {with-test} "tezos-protocol-021-PsQuebec" {with-test} "octez-protocol-021-PsQuebec-libs" {with-test} "octez-smart-rollup-node-PsQuebec" {with-test} + "octez-alcotezt" {with-test} "tezos-protocol-alpha" {with-test} "octez-protocol-alpha-libs" {with-test} "octez-smart-rollup-node-alpha" {with-test} diff --git a/opam/tezos-smart-rollup-node-lib-test.opam b/opam/tezos-smart-rollup-node-lib-test.opam index 3dc077fd9f27..ba6bbe4864a9 100644 --- a/opam/tezos-smart-rollup-node-lib-test.opam +++ b/opam/tezos-smart-rollup-node-lib-test.opam @@ -21,13 +21,13 @@ depends: [ "logs" {with-test} "octez-alcotezt" {with-test} "octez-shell-libs" {with-test} - "octez-smart-rollup-node-PsParisC" {with-test} "octez-smart-rollup-node-PsQuebec" {with-test} ] depopts: [ "octez-smart-rollup-node-PtNairob" {with-test} "octez-smart-rollup-node-Proxford" {with-test} "octez-smart-rollup-node-PtParisB" {with-test} + "octez-smart-rollup-node-PsParisC" {with-test} "octez-smart-rollup-node-alpha" {with-test} ] build: [ diff --git a/script-inputs/active_protocol_versions b/script-inputs/active_protocol_versions index 72810c16fcaa..35f685082e55 100644 --- a/script-inputs/active_protocol_versions +++ b/script-inputs/active_protocol_versions @@ -1,3 +1,2 @@ -020-PsParisC 021-PsQuebec alpha diff --git a/script-inputs/active_protocol_versions_without_number b/script-inputs/active_protocol_versions_without_number index d60f304201e6..426b42112ce0 100644 --- a/script-inputs/active_protocol_versions_without_number +++ b/script-inputs/active_protocol_versions_without_number @@ -1,3 +1,2 @@ -PsParisC PsQuebec alpha diff --git a/script-inputs/ci-opam-package-tests b/script-inputs/ci-opam-package-tests index e82292736fcd..03ef22e847f0 100644 --- a/script-inputs/ci-opam-package-tests +++ b/script-inputs/ci-opam-package-tests @@ -1,31 +1,29 @@ -bls12-381 all 7 +bls12-381 all 6 dal_node_migrations all 6 efunc_core all 6 -octez-accuser-PsParisC exec 1 octez-accuser-PsQuebec exec 1 octez-alcotezt all 7 -octez-baker-PsParisC exec 1 octez-baker-PsQuebec exec 1 octez-client exec 1 octez-codec exec 1 -octez-crawler all 4 +octez-crawler all 3 octez-dal-node exec 1 octez-distributed-internal all 7 octez-distributed-lwt-internal all 7 octez-injector all 2 octez-internal-libs all 7 octez-l2-libs all 6 -octez-libs all 7 +octez-libs all 6 octez-node exec 1 -octez-node-config all 4 +octez-node-config all 3 octez-performance-metrics all 6 octez-proto-libs all 6 octez-protocol-000-Ps9mPmXa-libs all 2 octez-protocol-001-PtCJ7pwo-libs all 2 octez-protocol-002-PsYLVpVv-libs all 2 octez-protocol-003-PsddFKi3-libs all 2 -octez-protocol-004-Pt24m4xi-libs all 3 -octez-protocol-005-PsBabyM1-libs all 3 +octez-protocol-004-Pt24m4xi-libs all 2 +octez-protocol-005-PsBabyM1-libs all 2 octez-protocol-006-PsCARTHA-libs all 3 octez-protocol-007-PsDELPH1-libs all 3 octez-protocol-008-PtEdo2Zk-libs all 3 @@ -58,10 +56,10 @@ octez-smart-rollup-node-PsParisC all 1 octez-smart-rollup-node-PsQuebec all 1 octez-smart-rollup-node-PtNairob all 1 octez-smart-rollup-node-PtParisB all 1 -octez-smart-rollup-node-alpha all 2 +octez-smart-rollup-node-alpha all 1 octez-smart-rollup-node-lib all 2 octez-smart-rollup-wasm-debugger exec 1 -octez-smart-rollup-wasm-debugger-lib all 2 +octez-smart-rollup-wasm-debugger-lib all 1 octez-smart-rollup-wasm-debugger-plugin all 7 octez-version exec 6 tezos-benchmark all 6 @@ -81,8 +79,8 @@ tezos-protocol-006-PsCARTHA all 4 tezos-protocol-007-PsDELPH1 all 4 tezos-protocol-008-PtEdo2Zk all 4 tezos-protocol-008-PtEdoTez all 4 -tezos-protocol-009-PsFLoren all 5 -tezos-protocol-010-PtGRANAD all 5 +tezos-protocol-009-PsFLoren all 4 +tezos-protocol-010-PtGRANAD all 4 tezos-protocol-011-PtHangz2 all 5 tezos-protocol-012-Psithaca all 5 tezos-protocol-013-PtJakart all 5 @@ -96,6 +94,6 @@ tezos-protocol-020-PsParisC all 5 tezos-protocol-021-PsQuebec all 5 tezos-protocol-alpha all 5 tezos-protocol-demo-counter all 5 -tezos-protocol-demo-noops all 6 -tezos-protocol-genesis all 6 +tezos-protocol-demo-noops all 5 +tezos-protocol-genesis all 5 tezt-tezos all 6 diff --git a/script-inputs/released-executables b/script-inputs/released-executables index ec79445bb064..fb30eb72d633 100644 --- a/script-inputs/released-executables +++ b/script-inputs/released-executables @@ -8,5 +8,3 @@ octez-admin-client octez-node octez-accuser-PsQuebec octez-baker-PsQuebec -octez-accuser-PsParisC -octez-baker-PsParisC diff --git a/script-inputs/slim-mode-dune b/script-inputs/slim-mode-dune index 53220cdbdfc1..205e71bfa895 100644 --- a/script-inputs/slim-mode-dune +++ b/script-inputs/slim-mode-dune @@ -27,4 +27,5 @@ proto_016_PtMumbai proto_017_PtNairob proto_018_Proxford - proto_019_PtParisB) \ No newline at end of file + proto_019_PtParisB + proto_020_PsParisC) \ No newline at end of file diff --git a/src/bin_client/dune b/src/bin_client/dune index cd388f6703fd..b5a925364cac 100644 --- a/src/bin_client/dune +++ b/src/bin_client/dune @@ -127,9 +127,12 @@ (select void_for_linking-octez-protocol-019-PtParisB-libs-plugin from (octez-protocol-019-PtParisB-libs.plugin -> void_for_linking-octez-protocol-019-PtParisB-libs-plugin.empty) (-> void_for_linking-octez-protocol-019-PtParisB-libs-plugin.empty)) - octez-protocol-020-PsParisC-libs.client.commands-registration - octez-protocol-020-PsParisC-libs.baking-commands.registration - octez-protocol-020-PsParisC-libs.plugin + (select void_for_linking-octez-protocol-020-PsParisC-libs-client-commands-registration from + (octez-protocol-020-PsParisC-libs.client.commands-registration -> void_for_linking-octez-protocol-020-PsParisC-libs-client-commands-registration.empty) + (-> void_for_linking-octez-protocol-020-PsParisC-libs-client-commands-registration.empty)) + (select void_for_linking-octez-protocol-020-PsParisC-libs-plugin from + (octez-protocol-020-PsParisC-libs.plugin -> void_for_linking-octez-protocol-020-PsParisC-libs-plugin.empty) + (-> void_for_linking-octez-protocol-020-PsParisC-libs-plugin.empty)) octez-protocol-021-PsQuebec-libs.client.commands-registration octez-protocol-021-PsQuebec-libs.baking-commands.registration octez-protocol-021-PsQuebec-libs.plugin @@ -196,6 +199,8 @@ (write-file void_for_linking-octez-protocol-018-Proxford-libs-plugin.empty "") (write-file void_for_linking-octez-protocol-019-PtParisB-libs-client-commands-registration.empty "") (write-file void_for_linking-octez-protocol-019-PtParisB-libs-plugin.empty "") + (write-file void_for_linking-octez-protocol-020-PsParisC-libs-client-commands-registration.empty "") + (write-file void_for_linking-octez-protocol-020-PsParisC-libs-plugin.empty "") (write-file void_for_linking-octez-protocol-alpha-libs-client-commands-registration.empty "") (write-file void_for_linking-octez-protocol-alpha-libs-baking-commands-registration.empty "") (write-file void_for_linking-octez-protocol-alpha-libs-plugin.empty "")))) diff --git a/src/bin_dal_node/dune b/src/bin_dal_node/dune index e3817c617669..c03ef2f64391 100644 --- a/src/bin_dal_node/dune +++ b/src/bin_dal_node/dune @@ -39,7 +39,6 @@ octez-libs.prometheus octez-crawler memtrace - octez-protocol-020-PsParisC-libs.dal octez-protocol-021-PsQuebec-libs.dal (select void_for_linking-octez-protocol-alpha-libs-dal from (octez-protocol-alpha-libs.dal -> void_for_linking-octez-protocol-alpha-libs-dal.empty) diff --git a/src/bin_node/dune b/src/bin_node/dune index 8b3501c1cdf9..910647bb2d00 100644 --- a/src/bin_node/dune +++ b/src/bin_node/dune @@ -148,8 +148,12 @@ (select void_for_linking-octez-protocol-019-PtParisB-libs-plugin-registerer from (octez-protocol-019-PtParisB-libs.plugin-registerer -> void_for_linking-octez-protocol-019-PtParisB-libs-plugin-registerer.empty) (-> void_for_linking-octez-protocol-019-PtParisB-libs-plugin-registerer.empty)) - tezos-protocol-020-PsParisC.embedded-protocol - octez-protocol-020-PsParisC-libs.plugin-registerer + (select void_for_linking-tezos-protocol-020-PsParisC-embedded-protocol from + (tezos-protocol-020-PsParisC.embedded-protocol -> void_for_linking-tezos-protocol-020-PsParisC-embedded-protocol.empty) + (-> void_for_linking-tezos-protocol-020-PsParisC-embedded-protocol.empty)) + (select void_for_linking-octez-protocol-020-PsParisC-libs-plugin-registerer from + (octez-protocol-020-PsParisC-libs.plugin-registerer -> void_for_linking-octez-protocol-020-PsParisC-libs-plugin-registerer.empty) + (-> void_for_linking-octez-protocol-020-PsParisC-libs-plugin-registerer.empty)) tezos-protocol-021-PsQuebec.embedded-protocol octez-protocol-021-PsQuebec-libs.plugin-registerer (select void_for_linking-tezos-protocol-alpha-embedded-protocol from @@ -227,6 +231,8 @@ (write-file void_for_linking-octez-protocol-018-Proxford-libs-plugin-registerer.empty "") (write-file void_for_linking-tezos-protocol-019-PtParisB-embedded-protocol.empty "") (write-file void_for_linking-octez-protocol-019-PtParisB-libs-plugin-registerer.empty "") + (write-file void_for_linking-tezos-protocol-020-PsParisC-embedded-protocol.empty "") + (write-file void_for_linking-octez-protocol-020-PsParisC-libs-plugin-registerer.empty "") (write-file void_for_linking-tezos-protocol-alpha-embedded-protocol.empty "") (write-file void_for_linking-octez-protocol-alpha-libs-plugin-registerer.empty "")))) diff --git a/src/bin_smart_rollup_node/dune b/src/bin_smart_rollup_node/dune index 061daaf0be64..d66ccb579d41 100644 --- a/src/bin_smart_rollup_node/dune +++ b/src/bin_smart_rollup_node/dune @@ -26,7 +26,9 @@ (select void_for_linking-octez_smart_rollup_node_PtParisB from (octez_smart_rollup_node_PtParisB -> void_for_linking-octez_smart_rollup_node_PtParisB.empty) (-> void_for_linking-octez_smart_rollup_node_PtParisB.empty)) - octez_smart_rollup_node_PsParisC + (select void_for_linking-octez_smart_rollup_node_PsParisC from + (octez_smart_rollup_node_PsParisC -> void_for_linking-octez_smart_rollup_node_PsParisC.empty) + (-> void_for_linking-octez_smart_rollup_node_PsParisC.empty)) octez_smart_rollup_node_PsQuebec (select void_for_linking-octez_smart_rollup_node_alpha from (octez_smart_rollup_node_alpha -> void_for_linking-octez_smart_rollup_node_alpha.empty) @@ -54,4 +56,5 @@ (write-file void_for_linking-octez_smart_rollup_node_PtNairob.empty "") (write-file void_for_linking-octez_smart_rollup_node_Proxford.empty "") (write-file void_for_linking-octez_smart_rollup_node_PtParisB.empty "") + (write-file void_for_linking-octez_smart_rollup_node_PsParisC.empty "") (write-file void_for_linking-octez_smart_rollup_node_alpha.empty "")))) diff --git a/src/lib_smart_rollup_node/test/helpers/dune b/src/lib_smart_rollup_node/test/helpers/dune index 7d8eaf0864cf..6400f2874530 100644 --- a/src/lib_smart_rollup_node/test/helpers/dune +++ b/src/lib_smart_rollup_node/test/helpers/dune @@ -25,7 +25,9 @@ (select void_for_linking-octez_smart_rollup_node_PtParisB from (octez_smart_rollup_node_PtParisB -> void_for_linking-octez_smart_rollup_node_PtParisB.empty) (-> void_for_linking-octez_smart_rollup_node_PtParisB.empty)) - octez_smart_rollup_node_PsParisC + (select void_for_linking-octez_smart_rollup_node_PsParisC from + (octez_smart_rollup_node_PsParisC -> void_for_linking-octez_smart_rollup_node_PsParisC.empty) + (-> void_for_linking-octez_smart_rollup_node_PsParisC.empty)) octez_smart_rollup_node_PsQuebec (select void_for_linking-octez_smart_rollup_node_alpha from (octez_smart_rollup_node_alpha -> void_for_linking-octez_smart_rollup_node_alpha.empty) @@ -47,4 +49,5 @@ (write-file void_for_linking-octez_smart_rollup_node_PtNairob.empty "") (write-file void_for_linking-octez_smart_rollup_node_Proxford.empty "") (write-file void_for_linking-octez_smart_rollup_node_PtParisB.empty "") + (write-file void_for_linking-octez_smart_rollup_node_PsParisC.empty "") (write-file void_for_linking-octez_smart_rollup_node_alpha.empty "")))) diff --git a/src/proto_020_PsParisC/bin_accuser/dune b/src/proto_020_PsParisC/bin_accuser/dune deleted file mode 100644 index ce1e3c779b29..000000000000 --- a/src/proto_020_PsParisC/bin_accuser/dune +++ /dev/null @@ -1,32 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(executable - (name main_accuser_020_PsParisC) - (public_name octez-accuser-PsParisC) - (package octez-accuser-PsParisC) - (instrumentation (backend bisect_ppx)) - (libraries - octez-rustzcash-deps - bls12-381.archive - octez-libs.base - octez-libs.clic - tezos-protocol-020-PsParisC.protocol - octez-protocol-020-PsParisC-libs.client - octez-shell-libs.client-commands - octez-protocol-020-PsParisC-libs.baking-commands - octez-libs.stdlib-unix - octez-shell-libs.client-base-unix) - (link_flags - (:standard) - (:include %{workspace_root}/static-link-flags.sexp) - (:include %{workspace_root}/macos-link-flags.sexp)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_protocol_020_PsParisC - -open Tezos_client_020_PsParisC - -open Tezos_client_commands - -open Tezos_baking_020_PsParisC_commands - -open Tezos_stdlib_unix - -open Tezos_client_base_unix)) diff --git a/src/proto_020_PsParisC/bin_accuser/main_accuser_020_PsParisC.ml b/src/proto_020_PsParisC/bin_accuser/main_accuser_020_PsParisC.ml deleted file mode 100644 index 17efa9e364ad..000000000000 --- a/src/proto_020_PsParisC/bin_accuser/main_accuser_020_PsParisC.ml +++ /dev/null @@ -1,39 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2019 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 () = - Client_commands.register Protocol.hash @@ fun _network -> - List.map (Tezos_clic.map_command (new Protocol_client_context.wrap_full)) - @@ Baking_commands.accuser_commands () - -let select_commands _ _ = - let open Lwt_result_syntax in - return - (List.map - (Tezos_clic.map_command (new Protocol_client_context.wrap_full)) - (Baking_commands.accuser_commands ())) - -let () = Client_main_run.run (module Daemon_config) ~select_commands diff --git a/src/proto_020_PsParisC/bin_baker/dune b/src/proto_020_PsParisC/bin_baker/dune deleted file mode 100644 index 2d38d33db798..000000000000 --- a/src/proto_020_PsParisC/bin_baker/dune +++ /dev/null @@ -1,32 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(executable - (name main_baker_020_PsParisC) - (public_name octez-baker-PsParisC) - (package octez-baker-PsParisC) - (instrumentation (backend bisect_ppx)) - (libraries - octez-rustzcash-deps - bls12-381.archive - octez-libs.base - octez-libs.clic - tezos-protocol-020-PsParisC.protocol - octez-protocol-020-PsParisC-libs.client - octez-shell-libs.client-commands - octez-protocol-020-PsParisC-libs.baking-commands - octez-libs.stdlib-unix - octez-shell-libs.client-base-unix) - (link_flags - (:standard) - (:include %{workspace_root}/static-link-flags.sexp) - (:include %{workspace_root}/macos-link-flags.sexp)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_protocol_020_PsParisC - -open Tezos_client_020_PsParisC - -open Tezos_client_commands - -open Tezos_baking_020_PsParisC_commands - -open Tezos_stdlib_unix - -open Tezos_client_base_unix)) diff --git a/src/proto_020_PsParisC/bin_baker/main_baker_020_PsParisC.ml b/src/proto_020_PsParisC/bin_baker/main_baker_020_PsParisC.ml deleted file mode 100644 index 05b95923263b..000000000000 --- a/src/proto_020_PsParisC/bin_baker/main_baker_020_PsParisC.ml +++ /dev/null @@ -1,54 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2019 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 () = - Client_commands.register Protocol.hash @@ fun _network -> - List.map (Tezos_clic.map_command (new Protocol_client_context.wrap_full)) - @@ Baking_commands.baker_commands () - -let select_commands _ _ = - let open Lwt_result_syntax in - return - (List.map - (Tezos_clic.map_command (new Protocol_client_context.wrap_full)) - (Baking_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 () - -module Config = struct - include Daemon_config - - let default_daily_logs_path = Some ("octez-baker-" ^ Protocol.name) -end - -let () = Client_main_run.run (module Config) ~select_commands diff --git a/src/proto_020_PsParisC/lib_benchmark/README.md b/src/proto_020_PsParisC/lib_benchmark/README.md deleted file mode 100644 index 8adba76cbf90..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/README.md +++ /dev/null @@ -1,42 +0,0 @@ -# `Tezos_benchmark_alpha` - -This library is dedicated to sampling Michelson values and in particular -Michelson programs. - -## Architecture - -This library provides a sampling-based interface for well-typed -Michelson generation. Internally, this library is built on a sampler for an -intermediate language called Mikhailsky post-composed with a function to -map Mikhailsky terms to Michelson ones. - -### Layer 1: Mikhailsky - Mikhailsky corresponds to "Michelson with typed holes". Mikhailsky terms - are encoded inside Micheline. The library `lib_benchmark_type_inference` - provides the language definition as well as a type inference engine. - -### Layer 2: Sampling Mikhailsky terms - We sample Mikhailsky terms using a Markov chain where transitions correspond - to local rewriting rules. The state space of the Markov chain is defined - in `State_space` module. The rewriting infrastructure is provided in the - `Kernel` module by instantiating `lib_micheline_rewriting`. - Rewrites are checked to preserved well-typedness in the Mikhailsky sense - using the type inference engine provided with Mikhailsky. The `Rules` - module defines all rewriting rules, for both Mikhailsky _programs_ - (submodule `Rules.Instruction`) and _data_ - (submodule `Rules.Data_rewrite_leaves`). The function `Rules.rewriting` - performs the enumeration of possible rewritings. - - The Markov chain is biased to sample terms of a specified - size using the Metropolis-Hasting functors provided by `StaTz`. - The instantiation of this Markov chain is defined in the `Sampler` - module. - -### Layer 3: - Once we can sample Mikhaislky terms of a specified size, we need - to convert them to Michelson ones. This is performed in two steps. - - In the first step, we use the `Autocomplete` module to fill holes - in Mikhailsky terms (resp. data) with well-typed code (resp. data). - This is a relatively ad-hoc process. - - The last step is to convert Mikhaislky to Michelson using the - `Michelson` module. diff --git a/src/proto_020_PsParisC/lib_benchmark/autocomp.ml b/src/proto_020_PsParisC/lib_benchmark/autocomp.ml deleted file mode 100644 index 18c9685b4c6a..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/autocomp.ml +++ /dev/null @@ -1,380 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(** Autocompletion functions (removing holes from Mikhailsky terms). *) - -open Sampling_helpers - -(* ------------------------------------------------------------------------- *) -(* Helpers *) - -let rec stack_length (stack : Type.Stack.t) acc = - match stack.node with - | Empty_t -> acc - | Stack_var_t _ -> acc + 1 - | Item_t (_, tl) -> stack_length tl (acc + 1) - -(* We need to sort and remove duplicate elements - of sets and maps to make them Michelson-compatible. *) -let sort_set_elements elements = - List.sort_uniq - (Structural_compare.compare - ~prim_compare:Mikhailsky.Mikhailsky_signature.compare) - elements - -let sort_map_elements elements = - let open Micheline in - List.sort_uniq - (fun node1 node2 -> - match (node1, node2) with - | ( Prim (_, Mikhailsky_prim.D_Elt, [k1; _v1], _), - Prim (_, Mikhailsky_prim.D_Elt, [k2; _v2], _) ) -> - Structural_compare.compare - ~prim_compare:Mikhailsky.Mikhailsky_signature.compare - k1 - k2 - | _ -> Stdlib.failwith "Autocomp.sort_map_elements: invalid Michelson map") - elements - -(* ------------------------------------------------------------------------- *) -(* Error handling *) - -type error_case = - | Cannot_complete_data of Mikhailsky.node * Kernel.Path.t - | Cannot_complete_code of Mikhailsky.node * Kernel.Path.t - -exception Autocompletion_error of error_case - -let cannot_complete_data node path = - raise (Autocompletion_error (Cannot_complete_data (node, path))) - -let cannot_complete_code node path = - raise (Autocompletion_error (Cannot_complete_code (node, path))) - -(* ------------------------------------------------------------------------- *) -(* Code & data autocompletion *) - -(* By default, comparable values are unit. *) -let default_comparable_type = Type.unit - -let generate_comparable _sp = Mikhailsky.Data.unit - -(* Instantiates variables in a base type, remaining variables - are mapped to some consistent choice of ground type - (this is made complicated by comparability constraints) *) -let rec instantiate_and_set ty = - let open Inference.M in - Inference.instantiate_base ty >>= fun ty -> replace_vars ty - -and replace_vars (ty : Type.Base.t) = - let open Inference.M in - let node = ty.node in - match node with - | Type.Base.Unit_t | Type.Base.Int_t | Type.Base.Nat_t | Type.Base.Bool_t - | Type.Base.String_t | Type.Base.Bytes_t | Type.Base.Key_hash_t - | Type.Base.Timestamp_t | Type.Base.Mutez_t | Type.Base.Key_t -> - return ty - | Type.Base.Var_t v -> ( - get_repr_exn v >>= fun repr -> - match repr with - | Inference.Stack_type _ -> assert false - | Inference.Base_type {comparable = _; repr = Some _} -> assert false - | Inference.Base_type {comparable; repr = None} -> ( - match comparable with - | Inference.Comparable -> return default_comparable_type - | Inference.Unconstrained | Inference.Not_comparable -> - return Type.unit)) - | Type.Base.Option_t ty -> - replace_vars ty >>= fun ty -> return (Type.option ty) - | Type.Base.Pair_t (lt, rt) -> - replace_vars lt >>= fun lt -> - replace_vars rt >>= fun rt -> return (Type.pair lt rt) - | Type.Base.Or_t (lt, rt) -> - replace_vars lt >>= fun lt -> - replace_vars rt >>= fun rt -> return (Type.or_ lt rt) - | Type.Base.List_t ty -> replace_vars ty >>= fun ty -> return (Type.list ty) - | Type.Base.Set_t ty -> replace_vars ty >>= fun ty -> return (Type.set ty) - | Type.Base.Map_t (k, v) -> - replace_vars k >>= fun k -> - replace_vars v >>= fun v -> return (Type.map k v) - | Type.Base.Lambda_t (dom, range) -> - replace_vars dom >>= fun dom -> - replace_vars range >>= fun range -> return (Type.lambda dom range) - -let rec instantiate_and_set_stack (stack_ty : Type.Stack.t) = - let open Inference.M in - let node = stack_ty.node in - match node with - | Type.Stack.Empty_t -> return Type.empty - | Type.Stack.Stack_var_t _ -> return Type.empty - | Type.Stack.Item_t (hd, tl) -> - instantiate_and_set hd >>= fun hd -> - instantiate_and_set_stack tl >>= fun tl -> return (Type.item hd tl) - -(* In the following we perform computations in the composite monad - (sampler o Inference.M.t), it is convenient to define the bind and return - explicitly. *) -module SM = struct - type 'a t = 'a Inference.M.t sampler - - let ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t = - fun m f rng_state s -> - let x, s = m rng_state s in - f x rng_state s - [@@inline] - - let sample : 'a sampler -> 'a Inference.M.t sampler = - fun x rng_state st -> (x rng_state, st) - [@@inline] - - let deterministic : 'a Inference.M.t -> 'a t = fun x _rng_state -> x - - let return x _ s = (x, s) [@@inline] -end - -module Make - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) = -struct - (* Generates minimally sized random data of specified type. - Used in autocompletion. *) - (* /!\ Always call [instantiate_and_set] on the type argument of - [generate_data]. /!\ *) - let rec generate_data : Type.Base.t -> Mikhailsky.node SM.t = - fun ty -> - let open SM in - let open Type.Base in - let desc = ty.node in - match desc with - | Var_t _v -> assert false - | Unit_t -> return Mikhailsky.Data.unit - | Int_t -> - sample @@ Michelson_base.int >>= fun i -> - let i = Protocol.Script_int.to_zint i in - return (Mikhailsky.Data.big_integer i) - | Nat_t -> - sample @@ Michelson_base.nat >>= fun n -> - let n = Protocol.Script_int.to_zint n in - return (Mikhailsky.Data.big_natural n) - | Bool_t -> - sample Base_samplers.uniform_bool >>= fun b -> - if b then return Mikhailsky.Data.true_ - else return Mikhailsky.Data.false_ - | String_t -> - sample Michelson_base.string >>= fun str -> - let str = Protocol.Script_string.to_string str in - return (Mikhailsky.Data.string str) - | Bytes_t -> - sample Michelson_base.bytes >>= fun bytes -> - return (Mikhailsky.Data.bytes bytes) - | Key_hash_t -> - sample Crypto_samplers.pkh >>= fun pkh -> - return (Mikhailsky.Data.key_hash pkh) - | Timestamp_t -> - sample Michelson_base.timestamp >>= fun tstamp -> - return (Mikhailsky.Data.timestamp tstamp) - | Mutez_t -> - sample Michelson_base.tez >>= fun tz -> - return (Mikhailsky.Data.mutez tz) - | Key_t -> - sample Crypto_samplers.pk >>= fun pk -> return (Mikhailsky.Data.key pk) - | Option_t ty -> - sample Base_samplers.uniform_bool >>= fun b -> - if b then return Mikhailsky.Data.none - else generate_data ty >>= fun res -> return (Mikhailsky.Data.some res) - | Pair_t (lty, rty) -> - generate_data lty >>= fun lv -> - generate_data rty >>= fun rv -> return (Mikhailsky.Data.pair lv rv) - | Or_t (lty, rty) -> - sample Base_samplers.uniform_bool >>= fun b -> - if b then generate_data lty >>= fun v -> return (Mikhailsky.Data.left v) - else generate_data rty >>= fun v -> return (Mikhailsky.Data.right v) - | List_t _ty -> return (Mikhailsky.Data.list []) - | Set_t _ty -> return (Mikhailsky.Data.set []) - | Map_t (_kty, _vty) -> return (Mikhailsky.Data.map []) - | Lambda_t (dom, range) -> - invent_term Type.(item dom empty) Type.(item range empty) - >>= fun code -> return (Mikhailsky.Data.lambda code) - - and invent_term (bef : Type.Stack.t) (aft : Type.Stack.t) : - Mikhailsky.node list SM.t = - let open SM in - install_dummy_stack aft [] >>= fun code -> - let terms = drop_stack bef code in - return terms - - and drop_stack (stack : Type.Stack.t) code = - Mikhailsky.Instructions.dropn (stack_length stack 0) :: code - - and install_dummy_stack (stack : Type.Stack.t) (acc : Mikhailsky.node list) = - let open SM in - match stack.node with - | Empty_t -> return acc - | Stack_var_t _ -> - let acc = Mikhailsky.(Instructions.push unit_ty Data.unit) :: acc in - return acc - | Item_t (hd, tl) -> - deterministic @@ instantiate_and_set hd >>= fun hd -> - (match hd.node with - | Lambda_t (dom, range) -> - invent_term Type.(item dom empty) Type.(item range empty) - >>= fun code -> - let instr = Mikhailsky.(prim I_LAMBDA [seq code] []) in - return instr - | _ -> - generate_data hd >>= fun term -> - let ty = Mikhailsky.unparse_ty_exn hd in - return (Mikhailsky.Instructions.push ty term)) - >>= fun instr -> install_dummy_stack tl (instr :: acc) - - (* Autocomplete Mikhailsky data. - When encountering a hole, we lookup its type and instantiate - some random data of the specified type. *) - let rec complete_data : - Mikhailsky.node -> Kernel.Path.t -> Mikhailsky.node SM.t = - let open SM in - fun node path -> - match node with - | Micheline.Int (_, _) | Micheline.String (_, _) | Micheline.Bytes (_, _) - -> - return node - | Micheline.Prim (_, D_Hole, _, _) -> ( - deterministic @@ Inference.M.get_data_annot path >>= fun ty_opt -> - match ty_opt with - | None -> cannot_complete_data node path - | Some ty -> - deterministic @@ instantiate_and_set ty >>= fun ty -> - generate_data ty) - | Micheline.Prim (_, A_Set, [Micheline.Seq (_, elements)], _) -> - complete_data_list (Kernel.Path.at_index 0 path) 0 elements [] - >>= fun elements -> - let elements = sort_set_elements elements in - return (Mikhailsky.Data.set elements) - | Micheline.Prim (_, A_Map, [Micheline.Seq (_, elements)], _) -> - complete_data_list (Kernel.Path.at_index 0 path) 0 elements [] - >>= fun elements -> - let elements = sort_map_elements elements in - return (Mikhailsky.Data.map elements) - | Micheline.Prim (_, prim, subterms, _) -> - complete_data_list path 0 subterms [] >>= fun subterms -> - return (Mikhailsky.prim prim subterms []) - | Micheline.Seq (_, subterms) -> - complete_data_list path 0 subterms [] >>= fun subterms -> - return (Mikhailsky.seq subterms) - - and complete_data_list path i subterms acc = - let open SM in - match subterms with - | [] -> return (List.rev acc) - | subterm :: tl -> - let path' = Kernel.Path.at_index i path in - complete_data subterm path' >>= fun term -> - complete_data_list path (i + 1) tl (term :: acc) - - let complete_data typing node rng_state = - let root_type_opt, _ = Inference.M.get_data_annot Kernel.Path.root typing in - match root_type_opt with - | None -> Stdlib.failwith "Autocomp.complete_data: cannot get type of expr" - | Some ty -> - let _, typing = Inference.instantiate_base ty typing in - let result, _ = - try complete_data node Kernel.Path.root rng_state typing - with Autocompletion_error (Cannot_complete_data (subterm, path)) -> - Format.eprintf "Cannot complete data@." ; - Format.eprintf "at path %s@." (Kernel.Path.to_string path) ; - Format.eprintf "%a@." Mikhailsky.pp subterm ; - Stdlib.failwith "in autocomp.ml: unrecoverable failure" - in - let typ, _typing = - try Inference.infer_data_with_state result - with Inference.Ill_typed_script error -> - Format.eprintf "%a@." Inference.pp_inference_error error ; - Format.eprintf "%a@." Mikhailsky.pp result ; - assert false - in - (result, typ) - - (* Autocomplete Mikhailsky code. *) - - let rec complete_code : - Mikhailsky.node -> Kernel.Path.t -> Mikhailsky.node SM.t = - let open SM in - fun node path -> - match node with - | Micheline.Int (_, _) | Micheline.String (_, _) | Micheline.Bytes (_, _) - -> - return node - | Micheline.Prim (_, I_Hole, _, _) -> ( - deterministic @@ Inference.M.get_instr_annot path >>= function - | None -> cannot_complete_code node path - | Some {bef; aft} -> - deterministic @@ Inference.instantiate bef >>= fun bef -> - deterministic @@ Inference.instantiate aft >>= fun aft -> - invent_term bef aft >>= fun code -> return (Mikhailsky.seq code)) - | Micheline.Prim (_, prim, subterms, _) -> - complete_code_list path 0 subterms [] >>= fun subterms -> - return (Mikhailsky.prim prim subterms []) - | Micheline.Seq (_, subterms) -> - complete_code_list path 0 subterms [] >>= fun subterms -> - return (Mikhailsky.seq subterms) - - and complete_code_list path i subterms acc = - let open SM in - match subterms with - | [] -> return (List.rev acc) - | subterm :: tl -> - let path' = Kernel.Path.at_index i path in - complete_code subterm path' >>= fun term -> - complete_code_list path (i + 1) tl (term :: acc) - - let complete_code typing node rng_state = - let root_type_opt, _ = - Inference.M.get_instr_annot Kernel.Path.root typing - in - match root_type_opt with - | None -> Stdlib.failwith "Autocomp.complete_code: cannot get type of expr" - | Some {bef; aft} -> - let _, typing = Inference.instantiate bef typing in - let _, typing = Inference.instantiate aft typing in - let result, _ = - try complete_code node Kernel.Path.root rng_state typing with - | Autocompletion_error (Cannot_complete_code (subterm, path)) -> - Format.eprintf "Cannot complete code@." ; - Format.eprintf "at path %s@." (Kernel.Path.to_string path) ; - Format.eprintf "%a@." Mikhailsky.pp subterm ; - Stdlib.failwith "in autocomp.ml: unrecoverable failure" - | _ -> assert false - in - let (bef, aft), typing = - try Inference.infer_with_state result - with Inference.Ill_typed_script error -> - Format.eprintf "%a@." Inference.pp_inference_error error ; - Format.eprintf "%a@." Mikhailsky.pp result ; - assert false - in - let bef, typing = instantiate_and_set_stack bef typing in - let aft, typing = instantiate_and_set_stack aft typing in - (result, (bef, aft), typing) -end diff --git a/src/proto_020_PsParisC/lib_benchmark/execution_context.ml b/src/proto_020_PsParisC/lib_benchmark/execution_context.ml deleted file mode 100644 index 1dce1b3b59e6..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/execution_context.ml +++ /dev/null @@ -1,103 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol - -type context = Alpha_context.context * Script_interpreter.step_constants - -let initial_balance = 4_000_000_000_000L - -let context_init_memory ?dal ~rng_state () = - let open Lwt_result_wrap_syntax in - let dal_enable = Option.is_some dal in - let* block, accounts = - Context.init_n - ~rng_state - ~dal_enable - ?dal - ~bootstrap_balances: - [ - initial_balance; - initial_balance; - initial_balance; - initial_balance; - initial_balance; - ] - 5 - () - in - match accounts with - | [bs1; bs2; bs3; bs4; bs5] -> - return (`Mem_block (block, (bs1, bs2, bs3, bs4, bs5))) - | _ -> assert false - -let context_init ?dal ~rng_state () = context_init_memory ?dal ~rng_state () - -let make ?dal ~rng_state () = - let open Lwt_result_wrap_syntax in - let* context = context_init_memory ?dal ~rng_state () in - let amount = Alpha_context.Tez.one in - let chain_id = Tezos_crypto.Hashed.Chain_id.zero in - let now = Script_timestamp.of_zint Z.zero in - let level = Script_int.zero_n in - let open Script_interpreter in - let* block, step_constants = - match context with - | `Mem_block (block, (bs1, _, _, _, _)) -> - let sender = Alpha_context.Destination.Contract bs1 in - let payer = Contract_helpers.default_payer in - let self = Contract_helpers.default_self in - let step_constants = - { - sender; - payer; - self; - amount; - balance = Alpha_context.Tez.of_mutez_exn initial_balance; - chain_id; - now; - level; - } - in - return (block, step_constants) - in - let* csts = Context.get_constants (B block) in - let minimal_block_delay = - Protocol.Alpha_context.Period.to_seconds csts.parametric.minimal_block_delay - in - let* vs = - Incremental.begin_construction - ~timestamp: - (Time.Protocol.add block.header.shell.timestamp minimal_block_delay) - block - in - let ctxt = Incremental.alpha_ctxt vs in - let ctxt = - (* Required for eg Create_contract *) - Protocol.Alpha_context.Origination_nonce.init - ctxt - Tezos_crypto.Hashed.Operation_hash.zero - in - return (ctxt, step_constants) diff --git a/src/proto_020_PsParisC/lib_benchmark/kernel.ml b/src/proto_020_PsParisC/lib_benchmark/kernel.ml deleted file mode 100644 index 0932302aa20b..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/kernel.ml +++ /dev/null @@ -1,39 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(* ------------------------------------------------------------------------- *) -(* Instantiate rewriting subsystem *) - -module Lang = - Micheline_with_hash_consing.Make - (Mikhailsky.Mikhailsky_signature) - (struct - let initial_size = None - end) - -module Path = Mikhailsky.Path -module Patt = Pattern.Make (Mikhailsky.Mikhailsky_signature) (Lang) (Path) -module Rewriter = - Rewrite.Make (Mikhailsky.Mikhailsky_signature) (Lang) (Path) (Patt) diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/dune b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/dune deleted file mode 100644 index 252a64386f15..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/dune +++ /dev/null @@ -1,23 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tezos_benchmark_type_inference_020_PsParisC) - (public_name tezos-benchmark-type-inference-020-PsParisC) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.stdlib - octez-libs.error-monad - octez-libs.crypto - octez-libs.micheline - tezos-micheline-rewriting - tezos-protocol-020-PsParisC.protocol - hashcons) - (flags - (:standard) - -open Tezos_stdlib - -open Tezos_error_monad - -open Tezos_crypto - -open Tezos_micheline - -open Tezos_micheline_rewriting - -open Tezos_protocol_020_PsParisC)) diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/inference.ml b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/inference.ml deleted file mode 100644 index 65ec8932a5e6..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/inference.ml +++ /dev/null @@ -1,1150 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Micheline -module UF = Uf.UF - -(* The domain of comparability: - * - * Comparable Not_comparable - * ^ ^ - * \ / - * \ / - * Unconstrained - * - * The higher we go, the more information we have. - * This domain admits all glbs but not all lubs. - *) - -type comparability = Comparable | Not_comparable | Unconstrained - -let pp_comparability fmtr (cmp : comparability) = - match cmp with - | Comparable -> Format.fprintf fmtr "Comparable" - | Not_comparable -> Format.fprintf fmtr "Not_comparable" - | Unconstrained -> Format.fprintf fmtr "Unconstrained" - -let sup_comparability (c1 : comparability) (c2 : comparability) = - match (c1, c2) with - | Unconstrained, c | c, Unconstrained -> Some c - | Comparable, Comparable -> Some Comparable - | Not_comparable, Not_comparable -> Some Not_comparable - | Comparable, Not_comparable | Not_comparable, Comparable -> None - -type michelson_type = - | Base_type of {repr : Type.Base.t option; comparable : comparability} - | Stack_type of Type.Stack.t option - -type transformer = {bef : Type.Stack.t; aft : Type.Stack.t} - -let michelson_type_to_string (x : michelson_type) = - match x with - | Base_type {repr = None; comparable} -> - Format.asprintf "?::[%a]" pp_comparability comparable - | Base_type {repr = Some ty; comparable} -> - Format.asprintf "%a::[%a]" Type.Base.pp ty pp_comparability comparable - | Stack_type None -> "" - | Stack_type (Some sty) -> Format.asprintf "%a" Type.Stack.pp sty - -(* ------------------------------------------------------------------------- *) -(* Typechecking errors *) - -type inference_error = - (* | Expected_data_with_ground_type of Mikhailsky.Path.t * Mikhailsky.node *) - | Unhandled_micheline of Mikhailsky.Path.t * Mikhailsky.node - | Expected_micheline_prim - | Unsatisfiable_comparability_constraint of comparability_error_witness - | Base_types_incompatible of Type.Base.t * Type.Base.t - | Stack_types_incompatible of Type.Stack.t * Type.Stack.t - | Badly_typed_arithmetic of Mikhailsky_prim.prim * Type.Base.t * Type.Base.t - | Ill_formed_arithmetic of Mikhailsky.Path.t * Mikhailsky.node - | Cyclic_stack_type - | Cyclic_base_type - | Invalid_ast of string option * Mikhailsky.Path.t * Mikhailsky.node - -and comparability_error_witness = - | Comparability_error_types of michelson_type * michelson_type - | Comparability_error_tags of Type.Base.t * comparability * comparability - -let pp_inference_error fmtr (err : inference_error) = - match err with - (* | Expected_data_with_ground_type (path, node) -> - * let path = Mikhailsky.Path.to_string path in - * let node = Mikhailsky.to_string node in - * Format.fprintf fmtr "Expected data with ground type: %s at path %s" node path *) - | Unhandled_micheline (path, node) -> - let path = Mikhailsky.Path.to_string path in - let node = Mikhailsky.to_string node in - Format.fprintf fmtr "Unhandled micheline: %s at path %s" node path - | Expected_micheline_prim -> - Format.fprintf fmtr "%s" "Expected_micheline_prim" - | Unsatisfiable_comparability_constraint - (Comparability_error_types (ty1, ty2)) -> - let ty1 = michelson_type_to_string ty1 in - let ty2 = michelson_type_to_string ty2 in - Format.fprintf - fmtr - "Unsatisfiable comparability constraint: %s # %s" - ty1 - ty2 - | Unsatisfiable_comparability_constraint - (Comparability_error_tags (ty, cmp1, cmp2)) -> - Format.fprintf - fmtr - "Unsatisfiable comparability constraint: %a :: %a # %a" - Type.Base.pp - ty - pp_comparability - cmp1 - pp_comparability - cmp2 - | Base_types_incompatible (ty1, ty2) -> - Format.fprintf - fmtr - "Base types incompatible: %a %a" - Type.Base.pp - ty1 - Type.Base.pp - ty2 - | Stack_types_incompatible (sty1, sty2) -> - Format.fprintf - fmtr - "Stack types incompatible: %a %a" - Type.Stack.pp - sty1 - Type.Stack.pp - sty2 - | Badly_typed_arithmetic (prim, ty1, ty2) -> - Format.fprintf - fmtr - "Badly typed arithmetic: %a(%a, %a)" - Mikhailsky_prim.pp - prim - Type.Base.pp - ty1 - Type.Base.pp - ty2 - | Ill_formed_arithmetic (path, node) -> - let path = Mikhailsky.Path.to_string path in - let node = Mikhailsky.to_string node in - Format.fprintf fmtr "Ill formed arithmetic: %s at path %s" node path - | Cyclic_stack_type -> Format.fprintf fmtr "Cyclic stack type" - | Cyclic_base_type -> Format.fprintf fmtr "Cyclic base type" - | Invalid_ast (msg_opt, path, node) -> ( - let path = Mikhailsky.Path.to_string path in - let node = Mikhailsky.to_string node in - match msg_opt with - | None -> Format.fprintf fmtr "Invalid ast: %s at path %s" node path - | Some msg -> - Format.fprintf fmtr "Invalid ast: %s at path %s (%s)" node path msg) - -exception Ill_typed_script of inference_error - -let unsatisfiable_comparability ty cmp1 cmp2 = - raise - (Ill_typed_script - (Unsatisfiable_comparability_constraint - (Comparability_error_tags (ty, cmp1, cmp2)))) - -let invalid_ast ?msg path node = - raise (Ill_typed_script (Invalid_ast (msg, path, node))) - -let () = - Printexc.register_printer (fun exn -> - match exn with - | Ill_typed_script error -> - Some (Format.asprintf "%a" pp_inference_error error) - | _ -> None) - -(* ------------------------------------------------------------------------- *) - -module Repr_store = - Stores.Map - (Int_map) - (struct - type key = int - - type value = michelson_type - - let key_to_string = string_of_int - - let value_to_string = michelson_type_to_string - end) - -module Repr_sm = Monads.Make_state_monad (Repr_store) -module Path_map = Map.Make (Mikhailsky.Path) - -module Annot_instr_store = - Stores.Map - (Path_map) - (struct - type key = Mikhailsky.Path.t - - type value = transformer - - let key_to_string = Mikhailsky.Path.to_string - - let value_to_string {bef; aft} = - Format.asprintf "%a => %a" Type.Stack.pp bef Type.Stack.pp aft - end) - -module Annot_instr_sm = Monads.Make_state_monad (Annot_instr_store) - -module Annot_data_store = - Stores.Map - (Path_map) - (struct - type key = Mikhailsky.Path.t - - type value = Type.Base.t - - let key_to_string = Mikhailsky.Path.to_string - - let value_to_string ty = Format.asprintf "%a" Type.Base.pp ty - end) - -module Annot_data_sm = Monads.Make_state_monad (Annot_data_store) - -type state = { - uf : UF.M.state; - repr : Repr_sm.state; - annot_instr : Annot_instr_sm.state; - annot_data : Annot_data_sm.state; -} - -module M = struct - type 'a t = state -> 'a * state - - let empty : unit -> state = - fun () -> - { - uf = UF.M.empty (); - repr = Repr_sm.empty (); - annot_instr = Annot_instr_sm.empty (); - annot_data = Annot_data_sm.empty (); - } - - let ( >>= ) m f s = - let x, s = m s in - f x s - [@@inline] - - let return x s = (x, s) - - (* let run m = fst (m (empty ())) *) - - let uf_lift : 'a UF.M.t -> 'a t = - fun computation state -> - let res, uf = computation state.uf in - (res, {state with uf}) - [@@inline] - - let repr_lift : 'a Repr_sm.t -> 'a t = - fun computation state -> - let res, repr = computation state.repr in - (res, {state with repr}) - [@@inline] - - let annot_instr_lift : 'a Annot_instr_sm.t -> 'a t = - fun computation state -> - let res, annot_instr = computation state.annot_instr in - (res, {state with annot_instr}) - [@@inline] - - let annot_data_lift : 'a Annot_data_sm.t -> 'a t = - fun computation state -> - let res, annot_data = computation state.annot_data in - (res, {state with annot_data}) - [@@inline] - - let set_repr k v = repr_lift (Repr_sm.set k v) [@@inline] - - let get_repr_exn k = - repr_lift (Repr_sm.get k) >>= function - | None -> Stdlib.failwith "get_repr_exn" - | Some res -> return res - [@@inline] - - let set_instr_annot k v = annot_instr_lift (Annot_instr_sm.set k v) [@@inline] - - let get_instr_annot k = annot_instr_lift (Annot_instr_sm.get k) [@@inline] - - let set_data_annot k v = annot_data_lift (Annot_data_sm.set k v) [@@inline] - - let get_data_annot k = annot_data_lift (Annot_data_sm.get k) [@@inline] - - let get_state state = (state, state) -end - -module S = Set.Make (Int) - -let rec instantiate (encountered : S.t) (stack_ty : Type.Stack.t) : - Type.Stack.t M.t = - let open Type.Stack in - let open M in - if S.mem stack_ty.tag encountered then - raise (Ill_typed_script Cyclic_stack_type) - else - let encountered = S.add stack_ty.tag encountered in - match stack_ty.node with - | Empty_t -> return stack_ty - | Stack_var_t x -> ( - uf_lift (UF.find x) >>= fun root -> - get_repr_exn root >>= function - | Stack_type None -> return (Type.stack_var root) - | Stack_type (Some ty) -> instantiate encountered ty - | _ -> assert false) - | Item_t (head, tail) -> - instantiate_base S.empty head >>= fun head -> - instantiate encountered tail >>= fun tail -> - return (Type.item head tail) - -and instantiate_base (encountered : S.t) (ty : Type.Base.t) : Type.Base.t M.t = - let open Type.Base in - let open M in - if S.mem ty.tag encountered then raise (Ill_typed_script Cyclic_base_type) - else - let encountered = S.add ty.tag encountered in - match ty.node with - | Unit_t | Int_t | Nat_t | Bool_t | String_t | Bytes_t | Key_hash_t | Key_t - | Timestamp_t | Mutez_t -> - return ty - | Option_t ty -> - instantiate_base encountered ty >>= fun ty -> return (Type.option ty) - | List_t ty -> - instantiate_base encountered ty >>= fun ty -> return (Type.list ty) - | Set_t ty -> - instantiate_base encountered ty >>= fun ty -> return (Type.set ty) - | Map_t (kty, vty) -> - instantiate_base encountered kty >>= fun kty -> - instantiate_base encountered vty >>= fun vty -> - return (Type.map kty vty) - | Pair_t (lty, rty) -> - instantiate_base encountered lty >>= fun lty -> - instantiate_base encountered rty >>= fun rty -> - return (Type.pair lty rty) - | Or_t (lty, rty) -> - instantiate_base encountered lty >>= fun lty -> - instantiate_base encountered rty >>= fun rty -> - return (Type.or_ lty rty) - | Lambda_t (dom, range) -> - instantiate_base encountered dom >>= fun dom -> - instantiate_base encountered range >>= fun range -> - return (Type.lambda dom range) - | Var_t x -> ( - uf_lift (UF.find x) >>= fun root -> - get_repr_exn root >>= function - | Base_type {repr = None; _} -> return (Type.var root) - | Base_type {repr = Some ty; _} -> instantiate_base encountered ty - | _ -> assert false) - -let instantiate_base base_ty = instantiate_base S.empty base_ty - -let instantiate stack_ty = instantiate S.empty stack_ty - -let rec unify (x : Type.Stack.t) (y : Type.Stack.t) : unit M.t = - let open Type.Stack in - let open M in - let unify_single_stack v x = - (match Type.Stack.vars x with - | None -> return () - | Some v' -> - if v = v' then raise (Ill_typed_script Cyclic_stack_type) else return ()) - >>= fun () -> - M.uf_lift (UF.find v) >>= fun root -> - get_repr_exn root >>= fun repr -> - merge_reprs (Stack_type (Some x)) repr >>= fun repr -> set_repr root repr - in - if x.tag = y.tag then return () - else - match (x.node, y.node) with - | Empty_t, Empty_t -> return () - | Stack_var_t x, Stack_var_t y -> - M.uf_lift (UF.find x) >>= fun root_x -> - M.uf_lift (UF.find y) >>= fun root_y -> - get_repr_exn root_x >>= fun repr_x -> - get_repr_exn root_y >>= fun repr_y -> - M.uf_lift (UF.union x y) >>= fun root -> - merge_reprs repr_x repr_y >>= fun repr -> set_repr root repr - | Stack_var_t v, _ -> unify_single_stack v y - | _, Stack_var_t v -> unify_single_stack v x - | Item_t (ty1, tail1), Item_t (ty2, tail2) -> - unify_base ty1 ty2 >>= fun () -> - unify tail1 tail2 >>= fun () -> return () - | _ -> raise (Ill_typed_script (Stack_types_incompatible (x, y))) - -and unify_base (x : Type.Base.t) (y : Type.Base.t) : unit M.t = - let open Type.Base in - let open M in - let unify_single_var v x = - (if List.mem v (Type.Base.vars x) then - raise (Ill_typed_script Cyclic_base_type) - else return ()) - >>= fun () -> - M.uf_lift (UF.find v) >>= fun root -> - get_repr_exn root >>= fun repr -> - get_comparability x >>= fun comparable -> - merge_reprs (Base_type {repr = Some x; comparable}) repr >>= fun repr -> - set_repr root repr - in - if x.tag = y.tag then return () - else - match (x.node, y.node) with - | Unit_t, Unit_t - | Int_t, Int_t - | Nat_t, Nat_t - | Bool_t, Bool_t - | String_t, String_t - | Bytes_t, Bytes_t - | Key_hash_t, Key_hash_t - | Timestamp_t, Timestamp_t - | Mutez_t, Mutez_t - | Key_t, Key_t -> - return () - | Option_t x, Option_t y -> unify_base x y - | List_t x, List_t y -> unify_base x y - | Set_t x, Set_t y -> unify_base x y - | Map_t (kx, vx), Map_t (ky, vy) -> - unify_base kx ky >>= fun () -> unify_base vx vy - | Pair_t (x, x'), Pair_t (y, y') -> - unify_base x y >>= fun () -> unify_base x' y' - | Or_t (x, x'), Or_t (y, y') -> - unify_base x y >>= fun () -> unify_base x' y' - | Lambda_t (x, x'), Lambda_t (y, y') -> - unify_base x y >>= fun () -> unify_base x' y' - | Var_t x, Var_t y -> - M.uf_lift (UF.find x) >>= fun root_x -> - M.uf_lift (UF.find y) >>= fun root_y -> - get_repr_exn root_x >>= fun repr_x -> - get_repr_exn root_y >>= fun repr_y -> - M.uf_lift (UF.union x y) >>= fun root -> - merge_reprs repr_x repr_y >>= fun repr -> set_repr root repr - | Var_t v, _ -> unify_single_var v y - | _, Var_t v -> unify_single_var v x - | _ -> - instantiate_base x >>= fun x -> - instantiate_base y >>= fun y -> - raise (Ill_typed_script (Base_types_incompatible (x, y))) - -and merge_reprs (repr1 : michelson_type) (repr2 : michelson_type) : - michelson_type M.t = - let open M in - match (repr1, repr2) with - | (Stack_type None as repr), Stack_type None - | (Stack_type (Some _) as repr), Stack_type None - | Stack_type None, (Stack_type (Some _) as repr) -> - return repr - | (Stack_type (Some sty1) as repr), Stack_type (Some sty2) -> - unify sty1 sty2 >>= fun () -> return repr - | ( Base_type {repr = opt1; comparable = cmp1}, - Base_type {repr = opt2; comparable = cmp2} ) -> ( - let comparable_opt = sup_comparability cmp1 cmp2 in - match comparable_opt with - | None -> - raise - (Ill_typed_script - (Unsatisfiable_comparability_constraint - (Comparability_error_types (repr1, repr2)))) - | Some comparable -> ( - match (opt1, opt2) with - | None, None -> return (Base_type {repr = None; comparable}) - | (Some ty as repr), None -> - assert_comparability comparable ty >>= fun () -> - return (Base_type {repr; comparable}) - | None, (Some ty as repr) -> - assert_comparability comparable ty >>= fun () -> - return (Base_type {repr; comparable}) - | Some ty1, Some ty2 -> - unify_base ty1 ty2 >>= fun () -> - assert_comparability comparable ty1 >>= fun () -> - assert_comparability comparable ty2 >>= fun () -> - return (Base_type {repr = opt1; comparable}))) - | _ -> assert false - -and assert_comparability comparable ty = - assert_comparability_aux comparable ty [] - -and assert_comparability_aux lower_bound (ty : Type.Base.t) - (encountered : int list) : unit M.t = - let open M in - if List.mem ty.tag encountered then raise (Ill_typed_script Cyclic_base_type) - else - let encountered = ty.tag :: encountered in - match ty.node with - | Var_t v -> ( - uf_lift (UF.find v) >>= fun root -> - get_repr_exn root >>= fun repr -> - match repr with - | Base_type {repr = None; comparable} -> ( - match sup_comparability comparable lower_bound with - | None -> unsatisfiable_comparability ty comparable lower_bound - | Some comparable -> - set_repr root (Base_type {repr = None; comparable})) - | Base_type {repr = Some ty; comparable} -> ( - match sup_comparability comparable lower_bound with - | None -> unsatisfiable_comparability ty comparable lower_bound - | Some comparable -> - assert_comparability_aux lower_bound ty encountered - >>= fun () -> - set_repr root (Base_type {repr = Some ty; comparable})) - | Stack_type _ -> assert false) - | List_t _ | Set_t _ | Map_t _ | Lambda_t _ | Key_t -> ( - match lower_bound with - | Unconstrained | Not_comparable -> return () - | Comparable -> unsatisfiable_comparability ty Unconstrained lower_bound - ) - | Unit_t | Int_t | Nat_t | Bool_t | String_t | Bytes_t | Key_hash_t - | Timestamp_t | Mutez_t -> - (* if not (le_comparability lower_bound Comparable) then - * unsatisfiable_comparability ty Comparable lower_bound - * else *) - return () - | Option_t ty -> ( - match lower_bound with - | Comparable -> assert_comparability_aux Comparable ty encountered - | Not_comparable | Unconstrained -> return ()) - | Pair_t (l, r) -> ( - match lower_bound with - | Comparable -> - assert_comparability_aux Comparable l encountered >>= fun () -> - assert_comparability_aux Comparable r encountered - | Unconstrained | Not_comparable -> return ()) - | Or_t (l, r) -> ( - match lower_bound with - | Comparable -> - assert_comparability_aux Comparable l encountered >>= fun () -> - assert_comparability_aux Comparable r encountered - | Unconstrained | Not_comparable -> return ()) - -and get_comparability (ty : Type.Base.t) : comparability M.t = - let open M in - match ty.node with - | Var_t v -> ( - get_repr_exn v >>= fun repr -> - match repr with - | Stack_type _ -> assert false - | Base_type {comparable; _} -> return comparable) - | Unit_t | Int_t | Nat_t | Bool_t | String_t | Bytes_t | Key_hash_t - | Timestamp_t | Mutez_t -> - return Comparable - | List_t _ | Set_t _ | Map_t _ | Lambda_t _ | Key_t -> return Not_comparable - | Option_t ty -> get_comparability ty - | Or_t (lt, rt) | Pair_t (lt, rt) -> ( - get_comparability lt >>= fun lc -> - get_comparability rt >>= fun rc -> - match (lc, rc) with - | Comparable, Comparable -> return Comparable - | _ -> return Unconstrained) - -let fresh = - let x = ref ~-1 in - fun () -> - incr x ; - !x - -let exists_stack : unit -> Type.Stack.t M.t = - let open M in - fun () -> - let fresh = fresh () in - uf_lift (UF.add fresh) >>= fun () -> - set_repr fresh (Stack_type None) >>= fun () -> return (Type.stack_var fresh) - -let exists : unit -> Type.Base.t M.t = - let open M in - fun () -> - let fresh = fresh () in - uf_lift (UF.add fresh) >>= fun () -> - set_repr fresh (Base_type {repr = None; comparable = Unconstrained}) - >>= fun () -> return (Type.var fresh) - -let exists_cmp : unit -> Type.Base.t M.t = - let open M in - fun () -> - let fresh = fresh () in - uf_lift (UF.add fresh) >>= fun () -> - set_repr fresh (Base_type {repr = None; comparable = Comparable}) - >>= fun () -> return (Type.var fresh) - -(* Adapted from [script_ir_translator] *) -let parse_uint30 n : int = - let max_uint30 = 0x3fffffff in - match n with - | Micheline.Int (_, n') - when Compare.Z.(Z.zero <= n') && Compare.Z.(n' <= Z.of_int max_uint30) -> - Z.to_int n' - | _ -> assert false - -(* encodes the per-instruction relationship between input and output types - of binary arithmetic operations. *) -let arith_type (instr : Mikhailsky_prim.prim) (ty1 : Type.Base.t) - (ty2 : Type.Base.t) : Type.Base.t option = - match (instr, ty1.node, ty2.node) with - | (I_ADD | I_MUL), Int_t, Int_t - | (I_ADD | I_MUL), Int_t, Nat_t - | (I_ADD | I_MUL), Nat_t, Int_t -> - Some Type.int - | (I_ADD | I_MUL), Nat_t, Nat_t -> Some Type.nat - | I_SUB, Int_t, Int_t - | I_SUB, Int_t, Nat_t - | I_SUB, Nat_t, Int_t - | I_SUB, Nat_t, Nat_t - | I_SUB, Timestamp_t, Timestamp_t -> - Some Type.int - | I_EDIV, Int_t, Int_t - | I_EDIV, Int_t, Nat_t - | I_EDIV, Nat_t, Int_t - | I_EDIV, Nat_t, Nat_t -> - Some Type.(option (pair nat nat)) - (* Timestamp *) - | I_ADD, Timestamp_t, Int_t - | I_ADD, Int_t, Timestamp_t - | I_SUB, Timestamp_t, Int_t -> - Some Type.timestamp - (* Mutez *) - | I_ADD, Mutez_t, Mutez_t - | I_SUB, Mutez_t, Mutez_t - | I_MUL, Mutez_t, Nat_t - | I_MUL, Nat_t, Mutez_t -> - Some Type.mutez - | I_EDIV, Mutez_t, Nat_t -> Some Type.(option (pair mutez mutez)) - | I_EDIV, Mutez_t, Mutez_t -> Some Type.(option (pair nat mutez)) - | _ -> None - -let rec generate_constraints (path : Mikhailsky.Path.t) (node : Mikhailsky.node) - (bef : Type.Stack.t) (aft : Type.Stack.t) : unit M.t = - let open M in - set_instr_annot path {bef; aft} >>= fun () -> - match node with - | Int (_, _) -> - assert false (* Ints should always be guarded by annotations *) - | String (_, _) | Bytes (_, _) -> - raise (Ill_typed_script Expected_micheline_prim) - (* Hole *) - | Prim (_, I_Hole, [], _) -> return () - (* Stack ops - simple cases *) - | Prim (_loc, I_DROP, [], _annot) -> - exists () >>= fun top -> unify bef (Type.item top aft) - | Prim (_loc, I_DROP, [n], _annot) -> - let n = parse_uint30 n in - generate_constraints_dropn n bef aft - | Prim (_loc, I_DUP, [], _annot) -> - exists () >>= fun top -> - exists_stack () >>= fun rest -> - unify bef Type.(item top rest) >>= fun () -> - unify aft Type.(item top (item top rest)) - | Prim (_loc, I_SWAP, [], _annot) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item b rest)) >>= fun () -> - unify aft Type.(item b (item a rest)) - | Prim (_loc, I_PUSH, [t; d], _annot) -> - let ty = - Mikhailsky.parse_ty - ~allow_big_map:false - ~allow_operation:false - ~allow_contract:false - t - in - generate_constraints_data (Mikhailsky.Path.at_index 1 path) d ty - >>= fun () -> - (* assert_data_has_ground_type (Mikhailsky.Path.at_index 1 path) d ty >>= fun () -> *) - unify aft Type.(item ty bef) - | Prim (_loc, I_UNIT, [], _annot) -> unify aft Type.(item unit bef) - | Prim (_loc, I_DIP, [code], _annot) -> - exists () >>= fun top -> - exists_stack () >>= fun bef_rest -> - exists_stack () >>= fun aft_rest -> - unify bef Type.(item top bef_rest) >>= fun () -> - unify aft Type.(item top aft_rest) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - bef_rest - aft_rest - (* TODO: DIGn, etc *) - (* Option-related instructions *) - | Prim (_, I_SOME, [], _) -> - exists () >>= fun top -> - exists_stack () >>= fun rest -> - unify bef Type.(item top rest) >>= fun () -> - unify aft Type.(item (option top) rest) - | Prim (_, I_NONE, [t], _) -> - let ty = - Mikhailsky.parse_ty - ~allow_big_map:true - ~allow_operation:true - ~allow_contract:true - t - in - unify aft Type.(item (option ty) bef) - | Prim (_, I_IF_NONE, [bt; bf], _) -> - exists () >>= fun a -> - exists_stack () >>= fun rest -> - unify bef Type.(item (option a) rest) >>= fun () -> - generate_constraints (Mikhailsky.Path.at_index 0 path) bt rest aft - >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 1 path) - bf - Type.(item a rest) - aft - (* bool-based control flow *) - | Prim (_, I_IF, [bt; bf], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item bool rest) >>= fun () -> - generate_constraints (Mikhailsky.Path.at_index 0 path) bt rest aft - >>= fun () -> - generate_constraints (Mikhailsky.Path.at_index 1 path) bf rest aft - | Prim (_, I_LOOP, [body], _) -> - unify bef Type.(item bool aft) >>= fun () -> - generate_constraints (Mikhailsky.Path.at_index 0 path) body aft bef - (* Boolean binops *) - | Prim (_, I_AND, [], _) | Prim (_, I_OR, [], _) | Prim (_, I_XOR, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item bool (item bool rest)) >>= fun () -> - unify aft Type.(item bool rest) - (* Arithmetic *) - | Prim (_, ((I_ADD | I_SUB | I_MUL | I_EDIV) as instr), [ty1; ty2], _) -> ( - let ty1 = - Mikhailsky.parse_ty - ~allow_big_map:false - ~allow_operation:false - ~allow_contract:false - ty1 - in - let ty2 = - Mikhailsky.parse_ty - ~allow_big_map:false - ~allow_operation:false - ~allow_contract:false - ty2 - in - match arith_type instr ty1 ty2 with - | None -> - raise (Ill_typed_script (Badly_typed_arithmetic (instr, ty1, ty2))) - | Some ret -> - exists_stack () >>= fun rest -> - unify bef Type.(item ty1 (item ty2 rest)) >>= fun () -> - unify aft Type.(item ret rest)) - | Prim (_, (I_ADD | I_SUB | I_MUL | I_EDIV), _, _) -> - raise (Ill_typed_script (Ill_formed_arithmetic (path, node))) - | Prim (_, I_COMPARE, [], _) -> - exists_cmp () >>= fun a -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item a rest)) >>= fun () -> - unify aft Type.(item int rest) - | Prim (_, I_ABS, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item int rest) >>= fun () -> - unify aft Type.(item nat rest) - | Prim (_, I_GT, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item int rest) >>= fun () -> - unify aft Type.(item bool rest) - (* Strings/bytes *) - | Prim (_, I_CONCAT, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item string (item string rest)) >>= fun () -> - unify aft Type.(item string rest) - | Prim (_, I_SIZE_STRING, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item string rest) >>= fun () -> - unify aft Type.(item nat rest) - | Prim (_, I_SIZE_BYTES, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item bytes rest) >>= fun () -> - unify aft Type.(item nat rest) - (* Crypto *) - | Prim (_, I_SHA256, [], _) - | Prim (_, I_SHA512, [], _) - | Prim (_, I_BLAKE2B, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item bytes rest) >>= fun () -> - unify aft Type.(item bytes rest) - | Prim (_, I_HASH_KEY, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item key rest) >>= fun () -> - unify aft Type.(item key_hash rest) - (* sets *) - | Prim (_, I_EMPTY_SET, [], _) -> - exists_cmp () >>= fun cmpty -> unify aft Type.(item (set cmpty) bef) - | Prim (_, I_UPDATE_SET, [], _) -> - exists_cmp () >>= fun cty -> - exists_stack () >>= fun rest -> - unify bef Type.(item cty (item bool (item (set cty) rest))) >>= fun () -> - unify aft Type.(item (set cty) rest) - | Prim (_, I_SIZE_SET, [], _) -> - exists_cmp () >>= fun cmpty -> - exists_stack () >>= fun rest -> - unify bef Type.(item (set cmpty) rest) >>= fun () -> - unify aft Type.(item nat rest) - | Prim (_, I_ITER_SET, [code], _) -> - exists_cmp () >>= fun cmpty -> - unify bef Type.(item (set cmpty) aft) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item cmpty aft) - aft - | Prim (_, I_MEM_SET, [], _) -> - exists_cmp () >>= fun cmpty -> - exists_stack () >>= fun rest -> - unify bef Type.(item cmpty (item (set cmpty) rest)) >>= fun () -> - unify aft Type.(item bool rest) - (* maps *) - | Prim (_, I_EMPTY_MAP, [], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> unify aft Type.(item (map kty vty) bef) - | Prim (_, I_UPDATE_MAP, [], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> - exists_stack () >>= fun rest -> - unify bef Type.(item kty (item (option vty) (item (map kty vty) rest))) - >>= fun () -> unify aft Type.(item (map kty vty) rest) - | Prim (_, I_SIZE_MAP, [], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> - exists_stack () >>= fun rest -> - unify bef Type.(item (map kty vty) rest) >>= fun () -> - unify aft Type.(item nat rest) - | Prim (_, I_ITER_MAP, [code], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> - unify bef Type.(item (map kty vty) aft) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item (pair kty vty) aft) - aft - | Prim (_, I_MAP_MAP, [code], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty1 -> - exists () >>= fun vty2 -> - exists_stack () >>= fun rest -> - unify bef Type.(item (map kty vty1) rest) >>= fun () -> - unify aft Type.(item (map kty vty2) rest) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item (pair kty vty1) rest) - Type.(item vty2 rest) - | Prim (_, I_MEM_MAP, [], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> - exists_stack () >>= fun rest -> - unify bef Type.(item kty (item (map kty vty) rest)) >>= fun () -> - unify aft Type.(item bool rest) - | Prim (_, I_GET_MAP, [], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> - exists_stack () >>= fun rest -> - unify bef Type.(item kty (item (map kty vty) rest)) >>= fun () -> - unify aft Type.(item (option vty) rest) - (* Pairs *) - | Prim (_, I_PAIR, [], _) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item b rest)) >>= fun () -> - unify aft Type.(item (pair a b) rest) - | Prim (_, I_CAR, [], _) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists_stack () >>= fun rest -> - unify bef Type.(item (pair a b) rest) >>= fun () -> - unify aft Type.(item a rest) - | Prim (_, I_CDR, [], _) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists_stack () >>= fun rest -> - unify bef Type.(item (pair a b) rest) >>= fun () -> - unify aft Type.(item b rest) - (* Ors *) - | Prim (_, I_LEFT, [], _) -> - exists () >>= fun lt -> - exists () >>= fun rt -> - exists_stack () >>= fun rest -> - unify bef (Type.item lt rest) >>= fun () -> - unify aft Type.(item (or_ lt rt) rest) >>= fun res -> return res - | Prim (_, I_RIGHT, [], _) -> - exists () >>= fun lt -> - exists () >>= fun rt -> - exists_stack () >>= fun rest -> - unify bef Type.(item rt rest) >>= fun () -> - unify aft Type.(item (or_ lt rt) rest) - | Prim (_, (I_LEFT | I_RIGHT), _ :: _, _) -> - invalid_ast ~msg:__LOC__ path node - | Prim (_, I_LOOP_LEFT, [body], _) -> - exists () >>= fun l -> - exists () >>= fun r -> - exists_stack () >>= fun rest -> - unify bef Type.(item (or_ l r) rest) >>= fun () -> - unify aft Type.(item r rest) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - body - Type.(item l rest) - bef - | Prim (_, I_IF_LEFT, [bt; bf], _) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists_stack () >>= fun rest -> - unify bef Type.(item (or_ a b) rest) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - bt - (Type.item a rest) - aft - >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 1 path) - bf - (Type.item b rest) - aft - (* lambdas *) - | Prim (_, I_LAMBDA, [code], _) -> - exists () >>= fun dom -> - exists () >>= fun range -> - unify aft Type.(item (lambda dom range) bef) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item dom empty) - Type.(item range empty) - | Prim (_, I_LAMBDA, _, _) -> invalid_ast ~msg:__LOC__ path node - | Prim (_, I_APPLY, [], _) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists () >>= fun ret -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item (lambda (pair a b) ret) rest)) >>= fun () -> - unify aft Type.(item (lambda b ret) rest) - | Prim (_, I_EXEC, [], _) -> - exists () >>= fun a -> - exists () >>= fun ret -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item (lambda a ret) rest)) >>= fun () -> - unify aft Type.(item ret rest) - (* lists *) - | Prim (_, I_NIL, [], _) -> - exists () >>= fun a -> unify aft Type.(item (list a) bef) - | Prim (_, I_CONS, [], _) -> - exists () >>= fun a -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item (list a) rest)) >>= fun () -> - unify aft Type.(item (list a) rest) - | Prim (_, I_SIZE_LIST, [], _) -> - exists () >>= fun ty -> - exists_stack () >>= fun rest -> - unify bef Type.(item (list ty) rest) >>= fun () -> - unify aft Type.(item nat rest) - | Prim (_, I_ITER_LIST, [code], _) -> - exists () >>= fun ty -> - unify bef Type.(item (list ty) aft) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item ty aft) - aft - | Prim (_, I_MAP_LIST, [code], _) -> - exists () >>= fun ty1 -> - exists () >>= fun ty2 -> - exists_stack () >>= fun rest -> - unify bef Type.(item (list ty1) rest) >>= fun () -> - unify aft Type.(item (list ty2) rest) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item ty1 rest) - Type.(item ty2 rest) - (* pack/unpack*) - | Prim (_, I_PACK, [], _) -> - exists () >>= fun ty -> - exists_stack () >>= fun rest -> - unify bef Type.(item ty rest) >>= fun () -> - unify aft Type.(item bytes rest) - | Prim (_, I_UNPACK, [], _) -> - exists () >>= fun ty -> - exists_stack () >>= fun rest -> - unify bef Type.(item bytes rest) >>= fun () -> - unify aft Type.(item (option ty) rest) - (* Others *) - | Seq (_, []) -> unify bef aft - | Seq (_, [single]) -> - generate_constraints (Mikhailsky.Path.at_index 0 path) single bef aft - | Seq (_, instrs) -> generate_constraints_seq path 0 instrs bef aft - | _ -> raise (Ill_typed_script (Unhandled_micheline (path, node))) - -and generate_constraints_seq path index instrs bef aft = - let open M in - match instrs with - | [] -> assert false - | [single] -> - generate_constraints (Mikhailsky.Path.at_index index path) single bef aft - | hd :: tl -> - exists_stack () >>= fun stack_ty -> - generate_constraints (Mikhailsky.Path.at_index index path) hd bef stack_ty - >>= fun () -> generate_constraints_seq path (index + 1) tl stack_ty aft - -and generate_constraints_data (path : Mikhailsky.Path.t) - (node : Mikhailsky.node) (ty : Type.Base.t) : unit M.t = - let open M in - set_data_annot path ty >>= fun () -> - match node with - | Prim (_, D_Hole, [], _) -> return () - | Prim (_, D_Unit, [], _) -> unify_base ty Type.unit - | Prim (_, D_True, [], _) | Prim (_, D_False, [], _) -> - unify_base ty Type.bool - | String _ -> unify_base ty Type.string - | Bytes _ -> unify_base ty Type.bytes - | Prim (_, D_Pair, [vl; vr], _) -> - exists () >>= fun lty -> - exists () >>= fun rty -> - generate_constraints_data (Mikhailsky.Path.at_index 0 path) vl lty - >>= fun () -> - generate_constraints_data (Mikhailsky.Path.at_index 1 path) vr rty - >>= fun () -> unify_base ty (Type.pair lty rty) - | Prim (_, D_Left, [term], _) -> - exists () >>= fun lty -> - exists () >>= fun rty -> - generate_constraints_data (Mikhailsky.Path.at_index 0 path) term lty - >>= fun () -> unify_base ty (Type.or_ lty rty) - | Prim (_, D_Right, [term], _) -> - exists () >>= fun lty -> - exists () >>= fun rty -> - generate_constraints_data (Mikhailsky.Path.at_index 0 path) term rty - >>= fun () -> unify_base ty (Type.or_ lty rty) - | Prim (_, D_None, [], _) -> - exists () >>= fun elt_ty -> unify_base ty (Type.option elt_ty) - | Prim (_, D_Some, [v], _) -> - exists () >>= fun elt_ty -> - generate_constraints_data (Mikhailsky.Path.at_index 0 path) v elt_ty - >>= fun () -> unify_base ty (Type.option elt_ty) - | Prim (_, A_Int, [Int (_, _)], _) -> unify_base ty Type.int - | Prim (_, A_Nat, [Int (_, _)], _) -> unify_base ty Type.nat - | Prim (_, A_Timestamp, [Int (_, _)], _) -> unify_base ty Type.timestamp - | Prim (_, A_Mutez, [Int (_, _)], _) -> unify_base ty Type.mutez - | Prim (_, A_Key_hash, [Bytes (_, _)], _) -> unify_base ty Type.key_hash - | Prim (_, A_Key, [Bytes (_, _)], _) -> unify_base ty Type.key - | Prim (_, A_List, [Seq (_, subterms)], _) -> - exists () >>= fun elt_ty -> - unify_base ty Type.(list elt_ty) >>= fun () -> - (* path' accounts for the fact that the Seq is hidden under an annot. *) - let path' = Mikhailsky.Path.at_index 0 path in - generate_constraints_data_list path' 0 subterms elt_ty - | Prim (_, A_Set, [Seq (_, subterms)], _) -> - exists_cmp () >>= fun elt_ty -> - unify_base ty Type.(set elt_ty) >>= fun () -> - (* path' accounts for the fact that the Seq is hidden under an annot. *) - let path' = Mikhailsky.Path.at_index 0 path in - generate_constraints_data_set path' 0 subterms elt_ty - | Prim (_, A_Map, [Seq (_, subterms)], _) -> - exists_cmp () >>= fun k_ty -> - exists () >>= fun v_ty -> - unify_base ty Type.(map k_ty v_ty) >>= fun () -> - (* path' accounts for the fact that the Seq is hidden under an annot. *) - let path' = Mikhailsky.Path.at_index 0 path in - generate_constraints_data_map path' 0 subterms k_ty v_ty - | Prim (_, A_Lambda, [(Seq (_, _) as node)], _) -> - exists () >>= fun dom -> - exists () >>= fun range -> - unify_base ty Type.(lambda dom range) >>= fun () -> - let path' = Mikhailsky.Path.at_index 0 path in - let bef = Type.(item dom empty) in - let aft = Type.(item range empty) in - generate_constraints path' node bef aft - | Prim (_, (A_Int | A_Nat | A_List), _, _) -> - invalid_ast ~msg:__LOC__ path node - | Int _ - (* Ints should always be guarded by annotations *) - | Seq (_, _) - (* Lists, sets, maps, lambdas, should always be guarded by annotations *) - | _ -> - invalid_ast ~msg:__LOC__ path node - -(* raise (Ill_typed_script (Invalid_ast (path, node))) *) -and generate_constraints_data_list path index data ty = - let open M in - match data with - | [] -> return () - | hd :: tl -> - let hd_path = Mikhailsky.Path.at_index index path in - generate_constraints_data hd_path hd ty >>= fun () -> - generate_constraints_data_list path (index + 1) tl ty - -and generate_constraints_data_set path index data ty = - let open M in - match data with - | [] -> return () - | hd :: tl -> - let hd_path = Mikhailsky.Path.at_index index path in - generate_constraints_data hd_path hd ty >>= fun () -> - generate_constraints_data_list path (index + 1) tl ty - -and generate_constraints_data_map path index data k_ty v_ty = - let open M in - match data with - | [] -> return () - | elt :: tl -> ( - let elt_path = Mikhailsky.Path.at_index index path in - match elt with - | Prim (_, D_Elt, [k; v], _) -> - let k_path = Mikhailsky.Path.at_index 0 elt_path in - generate_constraints_data k_path k k_ty >>= fun () -> - let v_path = Mikhailsky.Path.at_index 1 elt_path in - generate_constraints_data v_path v v_ty >>= fun () -> - generate_constraints_data_map path (index + 1) tl k_ty v_ty - | _ -> invalid_ast ~msg:__LOC__ elt_path elt) - -and generate_constraints_dropn n bef aft = - let open M in - if n = 0 then unify bef aft - else - exists () >>= fun top -> - generate_constraints_dropn (n - 1) bef (Type.item top aft) - -let infer_with_state (node : Mikhailsky.node) : - (Type.Stack.t * Type.Stack.t) * state = - let open M in - ( exists_stack () >>= fun bef -> - exists_stack () >>= fun aft -> - generate_constraints Mikhailsky.Path.root node bef aft >>= fun () -> - instantiate bef >>= fun bef -> - instantiate aft >>= fun aft -> return (bef, aft) ) - (M.empty ()) - -let infer (node : Mikhailsky.node) : Type.Stack.t * Type.Stack.t = - fst (infer_with_state node) - -let infer_data_with_state (node : Mikhailsky.node) : Type.Base.t * state = - let open M in - ( exists () >>= fun ty -> - generate_constraints_data Mikhailsky.Path.root node ty >>= fun () -> - instantiate_base ty >>= fun ty -> return ty ) - (M.empty ()) - -let infer_data (node : Mikhailsky.node) : Type.Base.t = - fst (infer_data_with_state node) diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/inference.mli b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/inference.mli deleted file mode 100644 index e44d83fab069..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/inference.mli +++ /dev/null @@ -1,145 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(** Errors and their pretty-printing function *) -type inference_error - -exception Ill_typed_script of inference_error - -val pp_inference_error : Format.formatter -> inference_error -> unit - -(** Comparability tag. *) -type comparability = Comparable | Not_comparable | Unconstrained - -(** Michelson types. *) -type michelson_type = - | Base_type of {repr : Type.Base.t option; comparable : comparability} - | Stack_type of Type.Stack.t option - -type transformer = {bef : Type.Stack.t; aft : Type.Stack.t} - -(** State of the type inference module *) - -(** Store implementation for type representatives *) -module Repr_store : Stores.S with type key = int and type value = michelson_type - -(** State monad built on [Repr_store] *) -module Repr_sm : - Monads.State_sig - with type state = Repr_store.state - and type key = int - and type value = michelson_type - -(** Store implementation for instruction type representatives *) -module Annot_instr_store : - Stores.S with type key = Mikhailsky.Path.t and type value = transformer - -(** State monad handling annotations on instructions *) -module Annot_instr_sm : - Monads.State_sig - with type state = Annot_instr_store.state - and type value = transformer - and type key = Mikhailsky.Path.t - -(** Store implementation for data type representatives *) -module Annot_data_store : - Stores.S with type key = Mikhailsky.Path.t and type value = Type.Base.t - -(** State monad handling annotations on data *) -module Annot_data_sm : - Monads.State_sig - with type state = Annot_data_store.state - and type value = Type.Base.t - and type key = Mikhailsky.Path.t - -(** State of the inference module *) -type state = { - uf : Uf.UF.M.state; - repr : Repr_sm.state; - annot_instr : Annot_instr_sm.state; - annot_data : Annot_data_sm.state; -} - -(** State monad of the inference module. *) -module M : sig - type 'a t = state -> 'a * state - - val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t - - val empty : unit -> state - - val return : 'a -> 'a t - - val set_repr : int -> michelson_type -> unit t - - val get_repr_exn : int -> michelson_type t - - val get_instr_annot : Annot_data_sm.key -> transformer option t - - val get_data_annot : Annot_data_sm.key -> Type.Base.t option t - - val uf_lift : 'a Uf.UF.M.t -> 'a t - - val repr_lift : 'a Repr_sm.t -> 'a t - - val annot_instr_lift : 'a Annot_instr_sm.t -> 'a t - - val annot_data_lift : 'a Annot_data_sm.t -> 'a t - - val get_state : state t -end - -(** Unifies two stack types. *) -val unify : Type.Stack.t -> Type.Stack.t -> unit M.t - -(** Unifies two base types. *) -val unify_base : Type.Base.t -> Type.Base.t -> unit M.t - -(** Instantiate type variables with the associated terms in a base type. *) -val instantiate_base : Type.Base.t -> Type.Base.t M.t - -(** Instantiate type variables with the associated terms in a stack type. *) -val instantiate : Type.Stack.t -> Type.Stack.t M.t - -(** Get comparability flag for a base type. *) -val get_comparability : Type.Base.t -> comparability M.t - -(** Performs inference on the given Mikhailsky term and returns - its type (as a pair of [before] and [after] stack) as well as the - inference engine state. *) -val infer_with_state : Mikhailsky.node -> (Type.Stack.t * Type.Stack.t) * state - -(** Performs inference on the given Mikhailsky term and throws - the inference engine state away. *) -val infer : Mikhailsky.node -> Type.Stack.t * Type.Stack.t - -(** Performs inference on a piece of Mikhailsky [data] and - returns the inference engine state along the inferred type. *) -val infer_data_with_state : Mikhailsky.node -> Type.Base.t * state - -(** Performs inference on a piece of Mikhailsky [data] and - returns the inferred type, throwing the inference engine - state away. *) -val infer_data : Mikhailsky.node -> Type.Base.t diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/int_map.ml b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/int_map.ml deleted file mode 100644 index e9b05fe91caa..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/int_map.ml +++ /dev/null @@ -1,26 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -include Map.Make (Compare.Int) diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky.ml b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky.ml deleted file mode 100644 index 4cdfbb80b285..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky.ml +++ /dev/null @@ -1,422 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol - -exception Term_contains_holes - -module Mikhailsky_signature : - Algebraic_signature.S with type t = Mikhailsky_prim.prim = struct - type t = Mikhailsky_prim.prim - - let compare (x : t) (y : t) = Stdlib.compare x y - - let hash (x : t) = Hashtbl.hash x - - let pp = Mikhailsky_prim.pp -end - -include - Micheline_with_hash_consing.Make - (Mikhailsky_signature) - (struct - let initial_size = None - end) - -module Path = Path.With_hash_consing (struct - let initial_size = None -end) - -(* Prints a Mikhailsky term. *) -let pp fmt node = - let canonical = Micheline.strip_locations node in - let printable = - Micheline_printer.printable Mikhailsky_prim.string_of_prim canonical - in - Micheline_printer.print_expr fmt printable - -let to_string node = - pp Format.str_formatter node ; - Format.flush_str_formatter () - -(* Adapted from Script_ir_translator.parse_ty *) -let rec parse_ty : - allow_big_map:bool -> - allow_operation:bool -> - allow_contract:bool -> - node -> - Type.Base.t = - fun ~allow_big_map ~allow_operation ~allow_contract node -> - match node with - | Prim (_loc, T_unit, [], _annot) -> Type.unit - | Prim (_loc, T_int, [], _annot) -> Type.int - | Prim (_loc, T_nat, [], _annot) -> Type.nat - | Prim (_loc, T_string, [], _annot) -> Type.string - | Prim (_loc, T_bytes, [], _annot) -> Type.bytes - | Prim (_loc, T_bool, [], _annot) -> Type.bool - | Prim (_loc, T_key_hash, [], _annot) -> Type.key_hash - | Prim (_loc, T_timestamp, [], _annot) -> Type.timestamp - | Prim (_loc, T_mutez, [], _annot) -> Type.mutez - | Prim (_loc, T_option, [ut], _annot) -> - let ty = parse_ty ~allow_big_map ~allow_operation ~allow_contract ut in - Type.option ty - | Prim (_loc, T_pair, [utl; utr], _annot) -> - let lty = parse_ty ~allow_big_map ~allow_operation ~allow_contract utl in - let rty = parse_ty ~allow_big_map ~allow_operation ~allow_contract utr in - Type.pair lty rty - | Prim (_loc, T_or, [utl; utr], _annot) -> - let lty = parse_ty ~allow_big_map ~allow_operation ~allow_contract utl in - let rty = parse_ty ~allow_big_map ~allow_operation ~allow_contract utr in - Type.or_ lty rty - | Prim (_loc, T_set, [ut], _annot) -> - let ut = parse_ty ~allow_big_map ~allow_operation ~allow_contract ut in - Type.set ut - | Prim (_loc, T_map, [uta; utb], _annot) -> - let uta = parse_ty ~allow_big_map ~allow_operation ~allow_contract uta in - let utb = parse_ty ~allow_big_map ~allow_operation ~allow_contract utb in - Type.map uta utb - | Prim (_loc, T_lambda, [dom; range], _annot) -> - let dom = parse_ty ~allow_big_map ~allow_operation ~allow_contract dom in - let range = - parse_ty ~allow_big_map ~allow_operation ~allow_contract range - in - Type.lambda dom range - | Prim (_loc, T_list, [elt], _annot) -> - let elt = parse_ty ~allow_big_map ~allow_operation ~allow_contract elt in - Type.list elt - | _ -> - let s = to_string node in - Stdlib.failwith ("Mikhailsky.parse_ty: could not parse " ^ s) - -exception Term_has_variables - -exception Ill_formed_mikhailsky - -let rec map_var f (x : Type.Base.t) = - match x.node with - | Unit_t -> prim T_unit [] [] - | Var_t v -> f v - | Int_t -> prim T_int [] [] - | Nat_t -> prim T_nat [] [] - | Bool_t -> prim T_bool [] [] - | String_t -> prim T_string [] [] - | Bytes_t -> prim T_bytes [] [] - | Key_hash_t -> prim T_key_hash [] [] - | Timestamp_t -> prim T_timestamp [] [] - | Mutez_t -> prim T_mutez [] [] - | Key_t -> prim T_key [] [] - | Option_t ty -> - let mty = map_var f ty in - prim T_option [mty] [] - | Pair_t (lty, rty) -> - let lty = map_var f lty in - let rty = map_var f rty in - prim T_pair [lty; rty] [] - | Or_t (lty, rty) -> - let lty = map_var f lty in - let rty = map_var f rty in - prim T_or [lty; rty] [] - | List_t ty -> - let mty = map_var f ty in - prim T_list [mty] [] - | Set_t ty -> - let mty = map_var f ty in - prim T_set [mty] [] - | Map_t (kty, vty) -> - let mkty = map_var f kty in - let mvty = map_var f vty in - prim T_map [mkty; mvty] [] - | Lambda_t (dom, range) -> - let dom = map_var f dom in - let range = map_var f range in - prim T_lambda [dom; range] [] - -let unparse_ty_exn (x : Type.Base.t) = - map_var (fun _ -> raise Term_has_variables) x - -let unparse_ty (x : Type.Base.t) = - try Some (unparse_ty_exn x) with Term_has_variables -> None - -(* Exports a Mikhailsky term to Michelson. Fails if term contains holes. - Erases annotations, introduces types where missing. *) -let rec to_michelson (n : node) = - match n with - | Micheline.Int (_, i) -> Micheline.Int (0, i) - | Micheline.Prim (_, head, [term], _) - when Mikhailsky_prim.kind head = Annot_kind && head <> A_Lambda -> - to_michelson term - | Micheline.Prim (_, I_Hole, _, _) -> raise Term_contains_holes - | Micheline.Prim (_, D_Hole, _, _) -> raise Term_contains_holes - | Micheline.Prim (_, head, subterms, annots) -> - let head = Mikhailsky_prim.to_michelson head in - Micheline.Prim (0, head, List.map to_michelson subterms, annots) - | Micheline.String (_, s) -> Micheline.String (0, s) - | Micheline.Bytes (_, b) -> Micheline.Bytes (0, b) - | Micheline.Seq (_, subterms) -> - Micheline.Seq (0, List.map to_michelson subterms) - -let to_michelson (n : node) : Script_repr.expr = - Micheline.strip_locations (to_michelson n) - -let rec size : node -> int = - fun node -> - match node with - | Micheline.Int (_, _) -> 1 - | Micheline.String (_, _) -> 1 - | Micheline.Bytes (_, _) -> 1 - | Micheline.Prim (_, _, subterms, _) -> - List.fold_left (fun acc n -> acc + size n) 1 subterms - | Micheline.Seq (_, subterms) -> - List.fold_left (fun acc n -> acc + size n) 1 subterms - -let instr_hole = prim I_Hole [] [] - -let data_hole = prim D_Hole [] [] - -(* types *) -let unit_ty = prim T_unit [] [] - -let bool_ty = prim T_bool [] [] - -let int_ty = prim T_int [] [] - -let nat_ty = prim T_nat [] [] - -let string_ty = prim T_string [] [] - -let bytes_ty = prim T_bytes [] [] - -let key_hash_ty = prim T_key_hash [] [] - -let option_ty x = prim T_option [x] [] - -let list_ty x = prim T_list [x] [] - -(* Unique identifier provided by hash-consing Micheline terms. *) -let tag node = - let l = label node in - l.tag - -(* hash of term *) -let hash node = - let l = label node in - l.hash - -module Instructions = struct - (* arithmetic *) - - let add ty1 ty2 = prim I_ADD [ty1; ty2] [] - - let sub ty1 ty2 = prim I_SUB [ty1; ty2] [] - - let mul ty1 ty2 = prim I_MUL [ty1; ty2] [] - - let ediv ty1 ty2 = prim I_EDIV [ty1; ty2] [] - - let abs = prim I_ABS [] [] - - let gt = prim I_GT [] [] - - (* stack ops *) - let push ty v = prim I_PUSH [ty; v] [] - - let dip code = prim I_DIP [seq [code]] [] - - let dup = prim I_DUP [] [] - - let drop = prim I_DROP [] [] - - let dropn n = prim I_DROP [int (Z.of_int n)] [] - - let swap = prim I_SWAP [] [] - - (* crypto *) - let blake2b = prim I_BLAKE2B [] [] - - let sha256 = prim I_SHA256 [] [] - - let sha512 = prim I_SHA512 [] [] - - let hash_key = prim I_HASH_KEY [] [] - - (* control *) - let if_ bt bf = prim I_IF [seq [bt]; seq [bf]] [] - - let if_left bt bf = prim I_IF_LEFT [seq [bt]; seq [bf]] [] - - let if_none bt bf = prim I_IF_NONE [seq [bt]; seq [bf]] [] - - let loop b = prim I_LOOP [seq [b]] [] - - let loop_left b = prim I_LOOP_LEFT [seq [b]] [] - - (* pairs *) - let car = prim I_CAR [] [] - - let cdr = prim I_CDR [] [] - - let pair = prim I_PAIR [] [] - - (* ors *) - - let left = prim I_LEFT [] [] - - let right = prim I_RIGHT [] [] - - (* boolean *) - let and_ = prim I_AND [] [] - - (* compare *) - let compare = prim I_COMPARE [] [] - - (* map/set *) - let empty_set = prim I_EMPTY_SET [] [] - - let update_set = prim I_UPDATE_SET [] [] - - let size_set = prim I_SIZE_SET [] [] - - let iter_set code = prim I_ITER_SET [seq code] [] - - let mem_set = prim I_MEM_SET [] [] - - let empty_map = prim I_EMPTY_MAP [] [] - - let update_map = prim I_UPDATE_MAP [] [] - - let size_map = prim I_SIZE_MAP [] [] - - let iter_map code = prim I_ITER_MAP [seq code] [] - - let map_map code = prim I_MAP_MAP [seq code] [] - - let get_map = prim I_GET_MAP [] [] - - let mem_map = prim I_MEM_MAP [] [] - - (* lists*) - let nil = prim I_NIL [] [] - - let cons = prim I_CONS [] [] - - let size_list = prim I_SIZE_LIST [] [] - - let iter_list code = prim I_ITER_LIST [seq code] [] - - let map_list code = prim I_MAP_LIST [seq code] [] - - (* strings *) - let concat = prim I_CONCAT [] [] - - let size_string = prim I_SIZE_STRING [] [] - - let size_bytes = prim I_SIZE_BYTES [] [] - - (* Lambdas *) - let lambda code = prim I_LAMBDA [seq code] [] - - let exec = prim I_EXEC [] [] - - let apply = prim I_APPLY [] [] - - (* pack/unpack *) - let pack = prim I_PACK [] [] - - let unpack = prim I_UNPACK [] [] - - (* hole *) - let hole = instr_hole -end - -(* value constructors *) -module Data = struct - let unit = prim D_Unit [] [] - - let false_ = prim D_False [] [] - - let true_ = prim D_True [] [] - - let none = prim D_None [] [] - - let some x = prim D_Some [x] [] - - let pair x y = prim D_Pair [x; y] [] - - let left x = prim D_Left [x] [] - - let right x = prim D_Right [x] [] - - let list elts = prim A_List [seq elts] [] - - let set elts = prim A_Set [seq elts] [] - - let map_elt k v = prim D_Elt [k; v] [] - - let map elts = prim A_Map [seq elts] [] - - let timestamp ts = - let z = Protocol.Script_timestamp.to_zint ts in - prim A_Timestamp [int z] [] - - let mutez (tz : Protocol.Alpha_context.Tez.t) = - let i = Protocol.Alpha_context.Tez.to_mutez tz in - prim A_Mutez [int (Z.of_int64 i)] [] - - let key_hash kh = - let b = - Data_encoding.Binary.to_bytes_exn - Environment.Signature.Public_key_hash.encoding - kh - in - prim A_Key_hash [bytes b] [] - - let key k = - let b = - Data_encoding.Binary.to_bytes_exn - Environment.Signature.Public_key.encoding - k - in - prim A_Key [bytes b] [] - - let integer (i : int) = prim A_Int [int (Z.of_int i)] [] - - let natural (i : int) = - assert (i >= 0) ; - prim A_Nat [int (Z.of_int i)] [] - - let big_integer (i : Z.t) = prim A_Int [int i] [] - - let big_natural (i : Z.t) = - assert (Z.geq i Z.zero) ; - prim A_Nat [int i] [] - - let string = string - - let bytes = bytes - - let lambda code = prim A_Lambda [seq code] [] - - let hole = data_hole -end diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky.mli b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky.mli deleted file mode 100644 index 724bfa299074..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky.mli +++ /dev/null @@ -1,331 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol - -(** Mikhailsky: Michelson in Micheline form, with typed holes and annotations. - Mikhailsky terms are hash-consed. *) - -(** - Michelson code is a hard to type-check and generate incrementally due to - the presence of ambiguous constructs, such as literals - like [{ 1 ; 2 ; 3 }]. Is it a list of ints? of nats? of tez? Or a set? - - Thus, we will work with Mikhailsky, a better behaved version of Michelson - allowing local reconstruction of types. - - Differences wrt Michelson: - - 1. non string/byte literals are explicitly annotated with their head type constructor. - Here is an int i: Prim (_, D_int, [Int i], _) - Here is an nat n: Prim (_, D_nat, [Int i], _) - Here is an list of something: Prim (_, D_list, michelson_list, _) - Here is a set: Prim (_, D_set, michelson_set, _) - Here is a map: Prim (_, D_map, michelson_map, _) - etc. - Projecting back from this language to Michelson is trivial. - - 2. Instructions `LEFT/RIGHT` do not need to carry the type of the other - component of the disjunction. These has to be filled in back when - generating Michelson from Mikhailsky. - - 4. The same holds for the input/output type of a lambda as specified in the - `LAMBDA` instruction. - - 3. Some instructions are annotated with the type on which they operate. - Eg if Prim (_, I_ADD, [], []) is the (ad-hoc polymorphic) addition in Michelson, - we will have the following variants in Mikhailsky: - - Prim (_, I_ADD, [ Prim (_, T_mutez, [], []), - Prim (_, T_mutez, [], []) ], []) for mutez addition - - Prim (_, I_ADD, [ Prim (_, T_int, [], []), - Prim (_, T_nat, [], []) ], []) for int+nat addition - etc. -*) - -(** The signature of Mikhailsky terms. *) -module Mikhailsky_signature : - Algebraic_signature.S with type t = Mikhailsky_prim.prim - -(** Elements of type [Path.t] allow to index subterms of Mikhailsky terms. *) -module Path : Path.S - -(** The following types correspond to those provided when instantiating the - functor [Micheline_with_hash_consing.Make] on [Mikhailsky_signature]. *) -type label = Micheline_with_hash_consing.hcons_info - -type head = Mikhailsky_signature.t - -type node = (label, head) Micheline.node - -exception Term_contains_holes - -exception Ill_formed_mikhailsky - -(** [parse_ty] returns a type from a Mikhailsky term. *) -val parse_ty : - allow_big_map:bool -> - allow_operation:bool -> - allow_contract:bool -> - node -> - Type.Base.t - -(** [map_var f x] maps the function f on all variables contained - in the type [x]. *) -val map_var : (int -> node) -> Type.Base.t -> node - -(** [unparse_ty] returns a Mikhailsky term representing a type. *) -val unparse_ty_exn : Type.Base.t -> node - -val unparse_ty : Type.Base.t -> node option - -(** Extracts a Michelson term from a Mikhailsky one. Raises - [Term_contains_holes] if it cannot be done. *) -val to_michelson : node -> Script_repr.expr - -(** Pretty printer. *) -val pp : Format.formatter -> node -> unit - -val to_string : node -> string - -(** Returns the number of nodes of a Mikhailsky term. *) -val size : node -> int - -(** Micheline generic constructors *) -val prim : Mikhailsky_prim.prim -> node list -> string list -> node - -val seq : node list -> node - -val string : string -> node - -val bytes : Bytes.t -> node - -(** Mikhailsky smart constructors*) - -(** Holes *) -val instr_hole : node - -val data_hole : node - -(** Types *) -val unit_ty : node - -val int_ty : node - -val nat_ty : node - -val bool_ty : node - -val string_ty : node - -val bytes_ty : node - -val key_hash_ty : node - -val option_ty : node -> node - -val list_ty : node -> node - -(** Project unique tag out of Mikhailsky node *) -val tag : node -> int - -(** Project hash out of Mikhailsky node *) -val hash : node -> int - -(** Instructions *) -module Instructions : sig - (** Arithmetic. Binary operations take the input types as extra arguments. *) - val add : node -> node -> node - - val sub : node -> node -> node - - val mul : node -> node -> node - - val ediv : node -> node -> node - - val abs : node - - val gt : node - - (** Stack *) - val push : node -> node -> node - - val dip : node -> node - - val dup : node - - val drop : node - - val dropn : int -> node - - val swap : node - - (** Crypto *) - val blake2b : node - - val sha256 : node - - val sha512 : node - - val hash_key : node - - (** Control *) - val if_ : node -> node -> node - - val if_left : node -> node -> node - - val if_none : node -> node -> node - - val loop : node -> node - - val loop_left : node -> node - - (** Pairs *) - val car : node - - val cdr : node - - val pair : node - - (** Unions *) - val left : node - - val right : node - - (** Booleans *) - val and_ : node - - (** Compare *) - val compare : node - - (** Set/Map *) - val empty_set : node - - val update_set : node - - val size_set : node - - val iter_set : node list -> node - - val mem_set : node - - val empty_map : node - - val update_map : node - - val size_map : node - - val iter_map : node list -> node - - val map_map : node list -> node - - val get_map : node - - val mem_map : node - - (** Lists *) - val nil : node - - val cons : node - - val size_list : node - - val iter_list : node list -> node - - val map_list : node list -> node - - (** Strings/bytes *) - val concat : node - - val size_string : node - - val size_bytes : node - - (** Lambdas *) - val lambda : node list -> node - - val exec : node - - val apply : node - - (** pack/unpack *) - - val pack : node - - val unpack : node - - (** Hole *) - val hole : node -end - -(** data *) -module Data : sig - val unit : node - - val false_ : node - - val true_ : node - - val none : node - - val some : node -> node - - val pair : node -> node -> node - - val left : node -> node - - val right : node -> node - - val list : node list -> node - - val set : node list -> node - - val map_elt : node -> node -> node - - val map : node list -> node - - val timestamp : Script_timestamp.t -> node - - val mutez : Alpha_context.Tez.t -> node - - val key_hash : Environment.Signature.Public_key_hash.t -> node - - val key : Environment.Signature.Public_key.t -> node - - val integer : int -> node - - val natural : int -> node - - val big_integer : Z.t -> node - - val big_natural : Z.t -> node - - val string : string -> node - - val bytes : Bytes.t -> node - - val lambda : node list -> node - - val hole : node -end diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky_prim.ml b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky_prim.ml deleted file mode 100644 index cd6689498404..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/mikhailsky_prim.ml +++ /dev/null @@ -1,575 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* Copyright (c) 2024 Marigold, *) -(* *) -(* 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 - -(** Mikhailsky primitives correspond to Michelson primitives plus special - "holes" for instructions and data. *) - -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 - | D_Ticket - | 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_MAP - | I_GET_AND_UPDATE_MAP - | 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_LOOP - | I_LSL - | I_LSR - | I_LT - | I_MAP_MAP - | I_MAP_LIST - | I_MEM_SET - | I_MEM_MAP - | 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_SET - | I_SIZE_MAP - | I_SIZE_LIST - | I_SIZE_STRING - | I_SIZE_BYTES - | I_SOME - | I_SOURCE - | I_SENDER - | I_SELF - | I_SLICE - | I_STEPS_TO_QUOTA - | I_SUB - | I_SWAP - | I_TRANSFER_TOKENS - | I_SET_DELEGATE - | I_UNIT - | I_UPDATE_SET - | I_UPDATE_MAP - | I_XOR - | I_ITER_MAP - | I_ITER_LIST - | I_ITER_SET - | I_LOOP_LEFT - | I_ADDRESS - | I_CONTRACT - | I_ISNAT - | I_CAST - | I_RENAME - | I_DIG - | I_DUG - | I_LEVEL - | I_SELF_ADDRESS - | I_NEVER - | I_SAPLING_EMPTY_STATE - | I_SAPLING_VERIFY_UPDATE - | 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_chain_id - | T_never - | T_sapling_state - | T_sapling_transaction_deprecated - | T_bls12_381_g1 - | T_bls12_381_g2 - | T_bls12_381_fr - | T_ticket - (* Holes in programs and data. *) - | I_Hole - | D_Hole - (* Annotations. *) - | A_Int - | A_Nat - | A_Timestamp - | A_Mutez - | A_Key_hash - | A_Key - | A_List - | A_Set - | A_Map - | A_Lambda - -let relation = - [ - (K_parameter, Michelson_v1_primitives.K_parameter); - (K_storage, Michelson_v1_primitives.K_storage); - (K_code, Michelson_v1_primitives.K_code); - (D_False, Michelson_v1_primitives.D_False); - (D_Elt, Michelson_v1_primitives.D_Elt); - (D_Left, Michelson_v1_primitives.D_Left); - (D_None, Michelson_v1_primitives.D_None); - (D_Pair, Michelson_v1_primitives.D_Pair); - (D_Right, Michelson_v1_primitives.D_Right); - (D_Some, Michelson_v1_primitives.D_Some); - (D_True, Michelson_v1_primitives.D_True); - (D_Unit, Michelson_v1_primitives.D_Unit); - (I_PACK, Michelson_v1_primitives.I_PACK); - (I_UNPACK, Michelson_v1_primitives.I_UNPACK); - (I_BLAKE2B, Michelson_v1_primitives.I_BLAKE2B); - (I_SHA256, Michelson_v1_primitives.I_SHA256); - (I_SHA512, Michelson_v1_primitives.I_SHA512); - (I_ABS, Michelson_v1_primitives.I_ABS); - (I_ADD, Michelson_v1_primitives.I_ADD); - (I_AMOUNT, Michelson_v1_primitives.I_AMOUNT); - (I_AND, Michelson_v1_primitives.I_AND); - (I_BALANCE, Michelson_v1_primitives.I_BALANCE); - (I_CAR, Michelson_v1_primitives.I_CAR); - (I_CDR, Michelson_v1_primitives.I_CDR); - (I_CHAIN_ID, Michelson_v1_primitives.I_CHAIN_ID); - (I_CHECK_SIGNATURE, Michelson_v1_primitives.I_CHECK_SIGNATURE); - (I_COMPARE, Michelson_v1_primitives.I_COMPARE); - (I_CONCAT, Michelson_v1_primitives.I_CONCAT); - (I_CONS, Michelson_v1_primitives.I_CONS); - (I_CREATE_ACCOUNT, Michelson_v1_primitives.I_CREATE_ACCOUNT); - (I_CREATE_CONTRACT, Michelson_v1_primitives.I_CREATE_CONTRACT); - (I_IMPLICIT_ACCOUNT, Michelson_v1_primitives.I_IMPLICIT_ACCOUNT); - (I_DIP, Michelson_v1_primitives.I_DIP); - (I_DROP, Michelson_v1_primitives.I_DROP); - (I_DUP, Michelson_v1_primitives.I_DUP); - (I_EDIV, Michelson_v1_primitives.I_EDIV); - (I_EMPTY_BIG_MAP, Michelson_v1_primitives.I_EMPTY_BIG_MAP); - (I_EMPTY_MAP, Michelson_v1_primitives.I_EMPTY_MAP); - (I_EMPTY_SET, Michelson_v1_primitives.I_EMPTY_SET); - (I_EQ, Michelson_v1_primitives.I_EQ); - (I_EXEC, Michelson_v1_primitives.I_EXEC); - (I_APPLY, Michelson_v1_primitives.I_APPLY); - (I_FAILWITH, Michelson_v1_primitives.I_FAILWITH); - (I_GE, Michelson_v1_primitives.I_GE); - (I_GET_MAP, Michelson_v1_primitives.I_GET); - (I_GET_AND_UPDATE_MAP, Michelson_v1_primitives.I_GET_AND_UPDATE); - (I_GT, Michelson_v1_primitives.I_GT); - (I_HASH_KEY, Michelson_v1_primitives.I_HASH_KEY); - (I_IF, Michelson_v1_primitives.I_IF); - (I_IF_CONS, Michelson_v1_primitives.I_IF_CONS); - (I_IF_LEFT, Michelson_v1_primitives.I_IF_LEFT); - (I_IF_NONE, Michelson_v1_primitives.I_IF_NONE); - (I_INT, Michelson_v1_primitives.I_INT); - (I_LAMBDA, Michelson_v1_primitives.I_LAMBDA); - (I_LE, Michelson_v1_primitives.I_LE); - (I_LEFT, Michelson_v1_primitives.I_LEFT); - (I_LEVEL, Michelson_v1_primitives.I_LEVEL); - (I_LOOP, Michelson_v1_primitives.I_LOOP); - (I_LSL, Michelson_v1_primitives.I_LSL); - (I_LSR, Michelson_v1_primitives.I_LSR); - (I_LT, Michelson_v1_primitives.I_LT); - (I_MAP_MAP, Michelson_v1_primitives.I_MAP); - (I_MAP_LIST, Michelson_v1_primitives.I_MAP); - (I_MEM_SET, Michelson_v1_primitives.I_MEM); - (I_MEM_MAP, Michelson_v1_primitives.I_MEM); - (I_MUL, Michelson_v1_primitives.I_MUL); - (I_NEG, Michelson_v1_primitives.I_NEG); - (I_NEQ, Michelson_v1_primitives.I_NEQ); - (I_NIL, Michelson_v1_primitives.I_NIL); - (I_NONE, Michelson_v1_primitives.I_NONE); - (I_NOT, Michelson_v1_primitives.I_NOT); - (I_NOW, Michelson_v1_primitives.I_NOW); - (I_OR, Michelson_v1_primitives.I_OR); - (I_PAIR, Michelson_v1_primitives.I_PAIR); - (I_UNPAIR, Michelson_v1_primitives.I_UNPAIR); - (I_PUSH, Michelson_v1_primitives.I_PUSH); - (I_RIGHT, Michelson_v1_primitives.I_RIGHT); - (I_SIZE_SET, Michelson_v1_primitives.I_SIZE); - (I_SIZE_MAP, Michelson_v1_primitives.I_SIZE); - (I_SIZE_LIST, Michelson_v1_primitives.I_SIZE); - (I_SIZE_STRING, Michelson_v1_primitives.I_SIZE); - (I_SIZE_BYTES, Michelson_v1_primitives.I_SIZE); - (I_SOME, Michelson_v1_primitives.I_SOME); - (I_SOURCE, Michelson_v1_primitives.I_SOURCE); - (I_SENDER, Michelson_v1_primitives.I_SENDER); - (I_SELF, Michelson_v1_primitives.I_SELF); - (I_SELF_ADDRESS, Michelson_v1_primitives.I_SELF_ADDRESS); - (I_SLICE, Michelson_v1_primitives.I_SLICE); - (I_STEPS_TO_QUOTA, Michelson_v1_primitives.I_STEPS_TO_QUOTA); - (I_SUB, Michelson_v1_primitives.I_SUB); - (I_SWAP, Michelson_v1_primitives.I_SWAP); - (I_TRANSFER_TOKENS, Michelson_v1_primitives.I_TRANSFER_TOKENS); - (I_SET_DELEGATE, Michelson_v1_primitives.I_SET_DELEGATE); - (I_UNIT, Michelson_v1_primitives.I_UNIT); - (I_UPDATE_SET, Michelson_v1_primitives.I_UPDATE); - (I_UPDATE_MAP, Michelson_v1_primitives.I_UPDATE); - (I_XOR, Michelson_v1_primitives.I_XOR); - (I_ITER_MAP, Michelson_v1_primitives.I_ITER); - (I_ITER_LIST, Michelson_v1_primitives.I_ITER); - (I_ITER_SET, Michelson_v1_primitives.I_ITER); - (I_LOOP_LEFT, Michelson_v1_primitives.I_LOOP_LEFT); - (I_ADDRESS, Michelson_v1_primitives.I_ADDRESS); - (I_CONTRACT, Michelson_v1_primitives.I_CONTRACT); - (I_ISNAT, Michelson_v1_primitives.I_ISNAT); - (I_CAST, Michelson_v1_primitives.I_CAST); - (I_RENAME, Michelson_v1_primitives.I_RENAME); - (I_SAPLING_EMPTY_STATE, Michelson_v1_primitives.I_SAPLING_EMPTY_STATE); - (I_SAPLING_VERIFY_UPDATE, Michelson_v1_primitives.I_SAPLING_VERIFY_UPDATE); - (I_DIG, Michelson_v1_primitives.I_DIG); - (I_DUG, Michelson_v1_primitives.I_DUG); - (I_NEVER, Michelson_v1_primitives.I_NEVER); - (I_VOTING_POWER, Michelson_v1_primitives.I_VOTING_POWER); - (I_TOTAL_VOTING_POWER, Michelson_v1_primitives.I_TOTAL_VOTING_POWER); - (I_KECCAK, Michelson_v1_primitives.I_KECCAK); - (I_SHA3, Michelson_v1_primitives.I_SHA3); - (I_PAIRING_CHECK, Michelson_v1_primitives.I_PAIRING_CHECK); - (I_TICKET, Michelson_v1_primitives.I_TICKET); - (I_READ_TICKET, Michelson_v1_primitives.I_READ_TICKET); - (I_SPLIT_TICKET, Michelson_v1_primitives.I_SPLIT_TICKET); - (I_JOIN_TICKETS, Michelson_v1_primitives.I_JOIN_TICKETS); - (T_bool, Michelson_v1_primitives.T_bool); - (T_contract, Michelson_v1_primitives.T_contract); - (T_int, Michelson_v1_primitives.T_int); - (T_key, Michelson_v1_primitives.T_key); - (T_key_hash, Michelson_v1_primitives.T_key_hash); - (T_lambda, Michelson_v1_primitives.T_lambda); - (T_list, Michelson_v1_primitives.T_list); - (T_map, Michelson_v1_primitives.T_map); - (T_big_map, Michelson_v1_primitives.T_big_map); - (T_nat, Michelson_v1_primitives.T_nat); - (T_option, Michelson_v1_primitives.T_option); - (T_or, Michelson_v1_primitives.T_or); - (T_pair, Michelson_v1_primitives.T_pair); - (T_set, Michelson_v1_primitives.T_set); - (T_signature, Michelson_v1_primitives.T_signature); - (T_string, Michelson_v1_primitives.T_string); - (T_bytes, Michelson_v1_primitives.T_bytes); - (T_mutez, Michelson_v1_primitives.T_mutez); - (T_timestamp, Michelson_v1_primitives.T_timestamp); - (T_unit, Michelson_v1_primitives.T_unit); - (T_operation, Michelson_v1_primitives.T_operation); - (T_address, Michelson_v1_primitives.T_address); - ( T_sapling_transaction_deprecated, - Michelson_v1_primitives.T_sapling_transaction_deprecated ); - (T_sapling_state, Michelson_v1_primitives.T_sapling_state); - (T_chain_id, Michelson_v1_primitives.T_chain_id); - (T_never, Michelson_v1_primitives.T_never); - (T_bls12_381_g1, Michelson_v1_primitives.T_bls12_381_g1); - (T_bls12_381_g2, Michelson_v1_primitives.T_bls12_381_g2); - (T_bls12_381_fr, Michelson_v1_primitives.T_bls12_381_fr); - (T_ticket, Michelson_v1_primitives.T_ticket); - ] - -let relation_table = - let table = Hashtbl.create 269 in - List.iter - (fun (mikhailsky, michelson) -> Hashtbl.add table mikhailsky michelson) - relation ; - table - -exception Primitive_cannot_be_cast_back_to_Michelson of prim - -let to_michelson prim = - match Hashtbl.find relation_table prim with - | exception Not_found -> - raise (Primitive_cannot_be_cast_back_to_Michelson prim) - | res -> res - -let string_of_prim prim = - match prim with - | K_parameter -> "K_parameter" - | K_storage -> "K_storage" - | K_code -> "K_code" - | D_False -> "D_False" - | D_Elt -> "D_Elt" - | D_Left -> "D_Left" - | D_None -> "D_None" - | D_Pair -> "D_Pair" - | D_Right -> "D_Right" - | D_Some -> "D_Some" - | D_True -> "D_True" - | D_Unit -> "D_Unit" - | D_Ticket -> "D_Ticket" - | I_PACK -> "I_PACK" - | I_UNPACK -> "I_UNPACK" - | I_BLAKE2B -> "I_BLAKE2B" - | I_SHA256 -> "I_SHA256" - | I_SHA512 -> "I_SHA512" - | I_ABS -> "I_ABS" - | I_ADD -> "I_ADD" - | I_AMOUNT -> "I_AMOUNT" - | I_AND -> "I_AND" - | I_BALANCE -> "I_BALANCE" - | I_CAR -> "I_CAR" - | I_CDR -> "I_CDR" - | I_CHAIN_ID -> "I_CHAIN_ID" - | I_CHECK_SIGNATURE -> "I_CHECK_SIGNATURE" - | I_COMPARE -> "I_COMPARE" - | I_CONCAT -> "I_CONCAT" - | I_CONS -> "I_CONS" - | I_CREATE_ACCOUNT -> "I_CREATE_ACCOUNT" - | I_CREATE_CONTRACT -> "I_CREATE_CONTRACT" - | I_IMPLICIT_ACCOUNT -> "I_IMPLICIT_ACCOUNT" - | I_DIP -> "I_DIP" - | I_DROP -> "I_DROP" - | I_DUP -> "I_DUP" - | I_EDIV -> "I_EDIV" - | I_EMPTY_BIG_MAP -> "I_EMPTY_BIG_MAP" - | I_EMPTY_MAP -> "I_EMPTY_MAP" - | I_EMPTY_SET -> "I_EMPTY_SET" - | I_EQ -> "I_EQ" - | I_EXEC -> "I_EXEC" - | I_APPLY -> "I_APPLY" - | I_FAILWITH -> "I_FAILWITH" - | I_GE -> "I_GE" - | I_GET_MAP -> "I_GET_MAP" - | I_GET_AND_UPDATE_MAP -> "I_GET_AND_UPDATE_MAP" - | I_GT -> "I_GT" - | I_HASH_KEY -> "I_HASH_KEY" - | I_IF -> "I_IF" - | I_IF_CONS -> "I_IF_CONS" - | I_IF_LEFT -> "I_IF_LEFT" - | I_IF_NONE -> "I_IF_NONE" - | I_INT -> "I_INT" - | I_LAMBDA -> "I_LAMBDA" - | I_LE -> "I_LE" - | I_LEFT -> "I_LEFT" - | I_LOOP -> "I_LOOP" - | I_LSL -> "I_LSL" - | I_LSR -> "I_LSR" - | I_LT -> "I_LT" - | I_MAP_MAP -> "I_MAP_MAP" - | I_MAP_LIST -> "I_MAP_LIST" - | I_MEM_SET -> "I_MEM_SET" - | I_MEM_MAP -> "I_MEM_MAP" - | I_MUL -> "I_MUL" - | I_NEG -> "I_NEG" - | I_NEQ -> "I_NEQ" - | I_NIL -> "I_NIL" - | I_NONE -> "I_NONE" - | I_NOT -> "I_NOT" - | I_NOW -> "I_NOW" - | I_OR -> "I_OR" - | I_PAIR -> "I_PAIR" - | I_UNPAIR -> "I_UNPAIR" - | I_PUSH -> "I_PUSH" - | I_RIGHT -> "I_RIGHT" - | I_SIZE_SET -> "I_SIZE_SET" - | I_SIZE_MAP -> "I_SIZE_MAP" - | I_SIZE_LIST -> "I_SIZE_LIST" - | I_SIZE_STRING -> "I_SIZE_STRING" - | I_SIZE_BYTES -> "I_SIZE_BYTES" - | I_SOME -> "I_SOME" - | I_SOURCE -> "I_SOURCE" - | I_SENDER -> "I_SENDER" - | I_SELF -> "I_SELF" - | I_SLICE -> "I_SLICE" - | I_STEPS_TO_QUOTA -> "I_STEPS_TO_QUOTA" - | I_SUB -> "I_SUB" - | I_SWAP -> "I_SWAP" - | I_TRANSFER_TOKENS -> "I_TRANSFER_TOKENS" - | I_SET_DELEGATE -> "I_SET_DELEGATE" - | I_UNIT -> "I_UNIT" - | I_UPDATE_SET -> "I_UPDATE_SET" - | I_UPDATE_MAP -> "I_UPDATE_MAP" - | I_XOR -> "I_XOR" - | I_ITER_MAP -> "I_ITER_MAP" - | I_ITER_LIST -> "I_ITER_LIST" - | I_ITER_SET -> "I_ITER_SET" - | I_LOOP_LEFT -> "I_LOOP_LEFT" - | I_ADDRESS -> "I_ADDRESS" - | I_CONTRACT -> "I_CONTRACT" - | I_ISNAT -> "I_ISNAT" - | I_CAST -> "I_CAST" - | I_RENAME -> "I_RENAME" - | I_DIG -> "I_DIG" - | I_DUG -> "I_DUG" - | I_LEVEL -> "I_LEVEL" - | I_SELF_ADDRESS -> "I_SELF_ADDRESS" - | I_NEVER -> "I_NEVER" - | I_SAPLING_EMPTY_STATE -> "I_SAPLING_EMPTY_STATE" - | I_SAPLING_VERIFY_UPDATE -> "I_SAPLING_VERIFY_UPDATE" - | I_VOTING_POWER -> "I_VOTING_POWER" - | I_TOTAL_VOTING_POWER -> "I_TOTAL_VOTING_POWER" - | I_KECCAK -> "I_KECCAK" - | I_SHA3 -> "I_SHA3" - | I_PAIRING_CHECK -> "I_PAIRING_CHECK" - | I_TICKET -> "I_TICKET" - | I_READ_TICKET -> "I_READ_TICKET" - | I_SPLIT_TICKET -> "I_SPLIT_TICKET" - | I_JOIN_TICKETS -> "I_JOIN_TICKETS" - | T_bool -> "T_bool" - | T_contract -> "T_contract" - | T_int -> "T_int" - | T_key -> "T_key" - | T_key_hash -> "T_key_hash" - | T_lambda -> "T_lambda" - | T_list -> "T_list" - | T_map -> "T_map" - | T_big_map -> "T_big_map" - | T_nat -> "T_nat" - | T_option -> "T_option" - | T_or -> "T_or" - | T_pair -> "T_pair" - | T_set -> "T_set" - | T_signature -> "T_signature" - | T_string -> "T_string" - | T_bytes -> "T_bytes" - | T_mutez -> "T_mutez" - | T_timestamp -> "T_timestamp" - | T_unit -> "T_unit" - | T_operation -> "T_operation" - | T_address -> "T_address" - | T_chain_id -> "T_chain_id" - | T_never -> "T_never" - | T_sapling_state -> "T_sapling_state" - | T_sapling_transaction_deprecated -> "T_sapling_transaction_deprecated" - | T_bls12_381_g1 -> "T_bls12_381_g1" - | T_bls12_381_g2 -> "T_bls12_381_g2" - | T_bls12_381_fr -> "T_bls12_381_fr" - | T_ticket -> "T_ticket" - | I_Hole -> "I_Hole" - | D_Hole -> "D_Hole" - | A_Int -> "A_Int" - | A_Nat -> "A_Nat" - | A_Timestamp -> "A_Timestamp" - | A_Mutez -> "A_Mutez" - | A_Key_hash -> "A_Key_hash" - | A_Key -> "A_Key" - | A_List -> "A_List" - | A_Set -> "A_Set" - | A_Map -> "A_Map" - | A_Lambda -> "A_Lambda" - -let pp fmtr prim = Format.fprintf fmtr "%s" (string_of_prim prim) - -type kind = Data_kind | Instr_kind | Type_kind | Keyword_kind | Annot_kind - -let kind (x : prim) = - match x with - | K_parameter | K_storage | K_code -> Keyword_kind - | D_Hole | D_False | D_Elt | D_Left | D_None | D_Pair | D_Right | D_Some - | D_True | D_Unit | D_Ticket -> - Data_kind - | 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_MAP | I_GET_AND_UPDATE_MAP | 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_LOOP | I_LSL | I_LSR | I_LT | I_MAP_MAP | I_MAP_LIST | I_MEM_SET - | I_MEM_MAP | 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_SET | I_SIZE_MAP | I_SIZE_LIST - | I_SIZE_STRING | I_SIZE_BYTES | I_SOME | I_SOURCE | I_SENDER | I_SELF - | I_SLICE | I_STEPS_TO_QUOTA | I_SUB | I_SWAP | I_TRANSFER_TOKENS - | I_SET_DELEGATE | I_UNIT | I_UPDATE_SET | I_UPDATE_MAP | I_XOR | I_ITER_MAP - | I_ITER_LIST | I_ITER_SET | I_LOOP_LEFT | I_ADDRESS | I_CONTRACT | I_ISNAT - | I_CAST | I_RENAME | I_DIG | I_DUG | I_LEVEL | I_SELF_ADDRESS | I_NEVER - | I_SAPLING_EMPTY_STATE | I_SAPLING_VERIFY_UPDATE | 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 | I_Hole -> - Instr_kind - | 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_chain_id | T_never | T_sapling_state - | T_sapling_transaction_deprecated | T_bls12_381_g1 | T_bls12_381_g2 - | T_bls12_381_fr | T_ticket -> - Type_kind - (* Holes in programs and data. *) - (* Annotations. *) - | A_Int | A_Nat | A_Timestamp | A_Mutez | A_Key_hash | A_Key | A_List | A_Set - | A_Map | A_Lambda -> - Annot_kind diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/monads.ml b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/monads.ml deleted file mode 100644 index 47273406af50..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/monads.ml +++ /dev/null @@ -1,83 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(* Widely used module types. *) - -module type S = sig - type 'a t - - val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t - - val return : 'a -> 'a t - - val run : 'a t -> 'a -end - -(* Signature of a state monad. *) -module type State_sig = sig - type state - - type key - - type value - - include S with type 'a t = state -> 'a * state - - val empty : unit -> state - - val set : key -> value -> unit t - - val get : key -> value option t - - val iter_list : ('a -> unit t) -> 'a list -> unit t -end - -module Make_state_monad (X : Stores.S) : - State_sig - with type state = X.state - and type key = X.key - and type value = X.value - and type 'a t = X.state -> 'a * X.state = struct - include X - - type 'a t = state -> 'a * state - - let ( >>= ) m f s = - let x, s = m s in - f x s - - let return x s = (x, s) - - let run m = fst (m (empty ())) - - let set k v s = ((), set k v s) - - let get k s = (get k s, s) - - let rec iter_list (f : 'a -> unit t) (l : 'a list) = - match l with - | [] -> return () - | elt :: tl -> f elt >>= fun () -> iter_list f tl -end diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/stores.ml b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/stores.ml deleted file mode 100644 index dff87824d1b4..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/stores.ml +++ /dev/null @@ -1,85 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(* Various implementations of Monads.Store_sig *) - -(* Signature of a persistent store. *) -module type S = sig - type state - - type key - - type value - - val empty : unit -> state - - val set : key -> value -> state -> state - - val get : key -> state -> value option - - val map : (value -> value) -> state -> state - - val to_string : state -> string -end - -module type Map_store_param_sig = sig - type key - - type value - - val key_to_string : key -> string - - val value_to_string : value -> string -end - -(* An implemention of [S] using maps. *) -module Map (M : Map.S) (V : Map_store_param_sig with type key = M.key) : - S with type state = V.value M.t and type key = M.key and type value = V.value = -struct - type state = V.value M.t - - type key = M.key - - type value = V.value - - let empty () = M.empty - - let set = M.add - - let get = M.find_opt - - let map = M.map - - let to_string s = - M.fold - (fun key node acc -> - Printf.sprintf - "%s\n%s |-> %s" - acc - (V.key_to_string key) - (V.value_to_string node)) - s - "" -end diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/type.ml b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/type.ml deleted file mode 100644 index bc8d164c6c5c..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/type.ml +++ /dev/null @@ -1,200 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(* Michelson types. *) - -module Base = struct - type comparable_tag = Comparable | Maybe_not_comparable - - type t = t_node Hashcons.hash_consed - - and t_node = - | Unit_t - | Var_t of int - | Int_t - | Nat_t - | Bool_t - | String_t - | Bytes_t - | Key_hash_t - | Timestamp_t - | Mutez_t - | Key_t - | Option_t of t - | Pair_t of t * t - | Or_t of t * t - | List_t of t - | Set_t of t - | Map_t of t * t - | Lambda_t of t * t - - module Hashed = struct - type t = t_node - - let equal (t1 : t) (t2 : t) = - match (t1, t2) with - | Var_t v1, Var_t v2 -> v1 = v2 - | Unit_t, Unit_t - | Int_t, Int_t - | Nat_t, Nat_t - | Bool_t, Bool_t - | String_t, String_t - | Bytes_t, Bytes_t - | Key_hash_t, Key_hash_t - | Timestamp_t, Timestamp_t - | Mutez_t, Mutez_t - | Key_t, Key_t -> - true - | Option_t ty1, Option_t ty2 -> ty1.tag = ty2.tag - | Pair_t (l1, r1), Pair_t (l2, r2) -> l1.tag = l2.tag && r1.tag = r2.tag - | Or_t (l1, r1), Or_t (l2, r2) -> l1.tag = l2.tag && r1.tag = r2.tag - | List_t ty1, List_t ty2 -> ty1.tag = ty2.tag - | Set_t ty1, Set_t ty2 -> ty1.tag = ty2.tag - | Map_t (kty1, vty1), Map_t (kty2, vty2) -> - kty1.tag = kty2.tag && vty1.tag = vty2.tag - | Lambda_t (dom1, range1), Lambda_t (dom2, range2) -> - dom1.tag = dom2.tag && range1.tag = range2.tag - | _ -> false - - let hash (t : t) = Hashtbl.hash t - end - - module Table = Hashcons.Make (Hashed) - - let table = Table.create 101 - - let rec pp fmtr x = - match x.Hashcons.node with - | Unit_t -> Format.pp_print_string fmtr "unit" - | Var_t v -> Format.fprintf fmtr "%d" v - | Int_t -> Format.pp_print_string fmtr "int" - | Nat_t -> Format.pp_print_string fmtr "nat" - | Bool_t -> Format.pp_print_string fmtr "bool" - | String_t -> Format.pp_print_string fmtr "string" - | Bytes_t -> Format.pp_print_string fmtr "bytes" - | Key_hash_t -> Format.pp_print_string fmtr "key_hash" - | Timestamp_t -> Format.pp_print_string fmtr "timestamp" - | Mutez_t -> Format.pp_print_string fmtr "mutez" - | Key_t -> Format.pp_print_string fmtr "key" - | Option_t ty -> Format.fprintf fmtr "(option %a)" pp ty - | List_t ty -> Format.fprintf fmtr "(list %a)" pp ty - | Pair_t (lty, rty) -> Format.fprintf fmtr "(pair %a %a)" pp lty pp rty - | Or_t (lty, rty) -> Format.fprintf fmtr "(or %a %a)" pp lty pp rty - | Set_t ty -> Format.fprintf fmtr "(set %a)" pp ty - | Map_t (kty, vty) -> Format.fprintf fmtr "(map %a %a)" pp kty pp vty - | Lambda_t (dom, range) -> - Format.fprintf fmtr "(lambda %a %a)" pp dom pp range - - let rec vars x acc = - match x.Hashcons.node with - | Unit_t | Int_t | Nat_t | Bool_t | String_t | Bytes_t | Key_hash_t - | Timestamp_t | Mutez_t | Key_t -> - acc - | Var_t v -> v :: acc - | Option_t ty | List_t ty | Set_t ty -> vars ty acc - | Pair_t (lty, rty) | Or_t (lty, rty) -> vars lty (vars rty acc) - | Map_t (kty, vty) -> vars kty (vars vty acc) - | Lambda_t (dom, range) -> vars dom (vars range acc) - - let vars x = vars x [] -end - -module Stack = struct - type t = t_node Hashcons.hash_consed - - and t_node = Empty_t | Stack_var_t of int | Item_t of Base.t * t - - module Hashed = struct - type t = t_node - - let equal (t1 : t) (t2 : t) = - match (t1, t2) with - | Empty_t, Empty_t -> true - | Stack_var_t v1, Stack_var_t v2 -> v1 = v2 - | Item_t (h1, tl1), Item_t (h2, tl2) -> h1 == h2 && tl1 == tl2 - | _ -> false - - let hash (t : t) = Hashtbl.hash t - end - - module Table = Hashcons.Make (Hashed) - - let table = Table.create 101 - - let rec pp fmtr x = - match x.Hashcons.node with - | Empty_t -> Format.pp_print_string fmtr "[]" - | Stack_var_t v -> Format.fprintf fmtr "<%d>" v - | Item_t (head, tail) -> Format.fprintf fmtr "%a :: %a" Base.pp head pp tail - - let rec vars x = - match x.Hashcons.node with - | Empty_t -> None - | Stack_var_t v -> Some v - | Item_t (_head, tail) -> vars tail -end - -let unit = Base.Table.hashcons Base.table Unit_t - -let var x = Base.Table.hashcons Base.table (Var_t x) - -let int = Base.Table.hashcons Base.table Int_t - -let nat = Base.Table.hashcons Base.table Nat_t - -let bool = Base.Table.hashcons Base.table Bool_t - -let string = Base.Table.hashcons Base.table String_t - -let bytes = Base.Table.hashcons Base.table Bytes_t - -let key_hash = Base.Table.hashcons Base.table Key_hash_t - -let timestamp = Base.Table.hashcons Base.table Timestamp_t - -let mutez = Base.Table.hashcons Base.table Mutez_t - -let key = Base.Table.hashcons Base.table Key_t - -let option ty = Base.Table.hashcons Base.table (Option_t ty) - -let pair lty rty = Base.Table.hashcons Base.table (Pair_t (lty, rty)) - -let or_ lty rty = Base.Table.hashcons Base.table (Or_t (lty, rty)) - -let list ty = Base.Table.hashcons Base.table (List_t ty) - -let set ty = Base.Table.hashcons Base.table (Set_t ty) - -let map kty vty = Base.Table.hashcons Base.table (Map_t (kty, vty)) - -let lambda dom range = Base.Table.hashcons Base.table (Lambda_t (dom, range)) - -(* Stack smart constructors *) -let empty = Stack.Table.hashcons Stack.table Empty_t - -let stack_var x = Stack.Table.hashcons Stack.table (Stack_var_t x) - -let item head tail = Stack.Table.hashcons Stack.table (Item_t (head, tail)) diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/type.mli b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/type.mli deleted file mode 100644 index bdc806590b25..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/type.mli +++ /dev/null @@ -1,111 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(** Michelson types, hash-consed. *) - -(** Base types *) -module Base : sig - type comparable_tag = Comparable | Maybe_not_comparable - - type t = t_node Hashcons.hash_consed - - and t_node = private - | Unit_t - | Var_t of int - | Int_t - | Nat_t - | Bool_t - | String_t - | Bytes_t - | Key_hash_t - | Timestamp_t - | Mutez_t - | Key_t - | Option_t of t - | Pair_t of t * t - | Or_t of t * t - | List_t of t - | Set_t of t - | Map_t of t * t - | Lambda_t of t * t - - val pp : Format.formatter -> t -> unit - - val vars : t -> int list -end - -(** Stack types *) -module Stack : sig - type t = t_node Hashcons.hash_consed - - and t_node = private Empty_t | Stack_var_t of int | Item_t of Base.t * t - - val pp : Format.formatter -> t -> unit - - val vars : t -> int option -end - -(** Smart constructors *) -val unit : Base.t - -val var : int -> Base.t - -val int : Base.t - -val nat : Base.t - -val bool : Base.t - -val string : Base.t - -val bytes : Base.t - -val key_hash : Base.t - -val timestamp : Base.t - -val mutez : Base.t - -val key : Base.t - -val option : Base.t -> Base.t - -val pair : Base.t -> Base.t -> Base.t - -val or_ : Base.t -> Base.t -> Base.t - -val list : Base.t -> Base.t - -val set : Base.t -> Base.t - -val map : Base.t -> Base.t -> Base.t - -val lambda : Base.t -> Base.t -> Base.t - -val empty : Stack.t - -val stack_var : int -> Stack.t - -val item : Base.t -> Stack.t -> Stack.t diff --git a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/uf.ml b/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/uf.ml deleted file mode 100644 index f14a166939a7..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/lib_benchmark_type_inference/uf.ml +++ /dev/null @@ -1,99 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(* ------------------------------------------------------------------------- *) -(* Union find parameterized over a persistent store. *) - -module type S = sig - module M : Monads.State_sig - - type key = int - - val add : key -> unit M.t - - val find : key -> key M.t - - val union : key -> key -> key M.t - - val show : string M.t -end - -module UF : S = struct - type node = T of {rank : int} | Ptr of key - - and key = int - - module S = - Stores.Map - (Int_map) - (struct - type key = int - - type value = node - - let key_to_string = string_of_int - - let value_to_string (x : value) = - match x with - | T {rank} -> Printf.sprintf "[%d]" rank - | Ptr k -> Printf.sprintf "ptr(%d)" k - end) - - module M = Monads.Make_state_monad (S) - - let add (k : key) = - let open M in - set k (T {rank = 1}) - - let rec get_root (k : key) (acc : key list) = - let open M in - get k >>= function - | None -> - let msg = Printf.sprintf "UF.get_root: invalid key %d" k in - Stdlib.failwith msg - | Some (T {rank}) -> - let ptr_to_root = Ptr k in - iter_list (fun key -> set key ptr_to_root) acc >>= fun () -> - return (k, rank) - | Some (Ptr k') -> get_root k' (k :: acc) - - let find (k : key) = - let open M in - get_root k [] >>= fun (res, _) -> return res - - let union k1 k2 = - let open M in - get_root k1 [] >>= fun (k1, rank1) -> - get_root k2 [] >>= fun (k2, rank2) -> - if k1 = k2 then return k1 - else if rank1 < rank2 then set k1 (Ptr k2) >>= fun () -> return k2 - else if rank1 > rank2 then set k2 (Ptr k1) >>= fun () -> return k1 - else - let new_root = T {rank = rank1 + 1} in - set k2 (Ptr k1) >>= fun () -> - set k1 new_root >>= fun () -> return k1 - - let show s = (S.to_string s, s) -end diff --git a/src/proto_020_PsParisC/lib_benchmark/micheline_sampler.ml b/src/proto_020_PsParisC/lib_benchmark/micheline_sampler.ml deleted file mode 100644 index 1e4778f856f0..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/micheline_sampler.ml +++ /dev/null @@ -1,110 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(** Micheline sampling. *) - -type width_function = depth:int -> int Base_samplers.sampler - -(** [Base_samplers] specifies samplers for leaves, primitives and annotations. *) -module type Base_samplers = sig - (** The type of primitives. *) - type prim - - val sample_prim : prim Base_samplers.sampler - - val sample_annots : string list Base_samplers.sampler - - val sample_string : string Base_samplers.sampler - - val sample_bytes : Bytes.t Base_samplers.sampler - - val sample_z : Z.t Base_samplers.sampler - - val width_function : width_function -end - -module type S = sig - type prim - - val sample : (int, prim) Micheline.node Base_samplers.sampler -end - -type node_kind = Int_node | String_node | Bytes_node | Seq_node | Prim_node - -(* The distribution can be skewed towards non-leaf nodes by repeating their - relevant kind in the array below. *) -let all_kinds = [|Int_node; String_node; Bytes_node; Seq_node; Prim_node|] - -let sample_kind : node_kind Base_samplers.sampler = - fun rng_state -> - let i = Random.State.int rng_state (Array.length all_kinds) in - all_kinds.(i) - -let reasonable_width_function ~depth rng_state = - (* Entirely ad-hoc *) - Base_samplers.( - sample_in_interval - ~range:{min = 0; max = 20 / (Bits.numbits depth + 1)} - rng_state) - -module Make (P : Base_samplers) : S with type prim = P.prim = struct - type prim = P.prim - - let sample (w : width_function) rng_state = - let rec sample depth rng_state k = - match sample_kind rng_state with - | Int_node -> k (Micheline.Int (0, P.sample_z rng_state)) - | String_node -> k (Micheline.String (0, P.sample_string rng_state)) - | Bytes_node -> k (Micheline.Bytes (0, P.sample_bytes rng_state)) - | Seq_node -> - let width = w ~depth rng_state in - sample_list - depth - width - [] - (fun terms -> k (Micheline.Seq (0, terms))) - rng_state - | Prim_node -> - let prim = P.sample_prim rng_state in - let annots = P.sample_annots rng_state in - let width = w ~depth rng_state in - sample_list - depth - width - [] - (fun terms -> k (Micheline.Prim (0, prim, terms, annots))) - rng_state - and sample_list depth width acc k rng_state = - if width < 0 then invalid_arg "sample_list: negative width" - else if width = 0 then k (List.rev acc) - else - sample (depth + 1) rng_state (fun x -> - sample_list depth (width - 1) (x :: acc) k rng_state) - in - sample 0 rng_state (fun x -> x) - - let sample rng_state = sample P.width_function rng_state -end diff --git a/src/proto_020_PsParisC/lib_benchmark/micheline_sampler.mli b/src/proto_020_PsParisC/lib_benchmark/micheline_sampler.mli deleted file mode 100644 index 97e3d4ec1e12..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/micheline_sampler.mli +++ /dev/null @@ -1,70 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(** Micheline sampling. *) - -(** A [width_function] specifies the distribution of node degree as a function - of [depth]. A [width_function] {e must} be supported by the nonnegative - integers. - - Note that picking a [width_function] which doesn't converge fast enough to - the singular distribution on 0 could yield very large terms. *) -type width_function = depth:int -> int Base_samplers.sampler - -(** [reasonable_width_function] is a width function which works well - empirically. *) -val reasonable_width_function : width_function - -(** [Base_samplers] specifies samplers for leaves, primitives and annotations. *) -module type Base_samplers = sig - (** The type of primitives. *) - type prim - - val sample_prim : prim Base_samplers.sampler - - val sample_annots : string list Base_samplers.sampler - - val sample_string : string Base_samplers.sampler - - val sample_bytes : Bytes.t Base_samplers.sampler - - val sample_z : Z.t Base_samplers.sampler - - val width_function : width_function -end - -(** Applying the [Make] functor below yields a module with the following - type. *) -module type S = sig - type prim - - (** [sample w] is a Micheline sampler for the prescribed primitive - type. The sampler uses the provided width function [w]. *) - val sample : (int, prim) Micheline.node Base_samplers.sampler -end - -(** [Make] instantiates a micheline sampler. *) -module Make (P : Base_samplers) : S with type prim = P.prim diff --git a/src/proto_020_PsParisC/lib_benchmark/michelson_mcmc_samplers.ml b/src/proto_020_PsParisC/lib_benchmark/michelson_mcmc_samplers.ml deleted file mode 100644 index 0515479b29f6..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/michelson_mcmc_samplers.ml +++ /dev/null @@ -1,341 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(** MCMC-based Michelson data and code samplers. *) - -open Protocol -open Stats - -type michelson_code = { - term : Script_repr.expr; - bef : Script_repr.expr list; - aft : Script_repr.expr list; -} - -type michelson_data = {term : Script_repr.expr; typ : Script_repr.expr} - -type michelson_sample = Code of michelson_code | Data of michelson_data - -let michelson_sample_list_encoding = - let open Data_encoding in - let e = Script_repr.expr_encoding in - list - @@ union - [ - case - ~title:"Code" - (Tag 0) - (tup3 e (list e) (list e)) - (function - | Code {term; bef; aft} -> Some (term, bef, aft) | _ -> None) - (fun (term, bef, aft) -> Code {term; bef; aft}); - case - ~title:"Data" - (Tag 1) - (tup2 e e) - (function Data {term; typ} -> Some (term, typ) | _ -> None) - (fun (term, typ) -> Data {term; typ}); - ] - -let save ~filename ~terms = - let str = - match - Data_encoding.Binary.to_string michelson_sample_list_encoding terms - with - | Error err -> - Format.eprintf - "Michelson_mcmc_samplers.save: encoding failed (%a); exiting@." - Data_encoding.Binary.pp_write_error - err ; - exit 1 - | Ok res -> res - in - try Lwt_main.run @@ Tezos_stdlib_unix.Lwt_utils_unix.create_file filename str - with exn -> - Format.eprintf - "Michelson_mcmc_samplers.save: create_file %s failed (%s); exiting@." - filename - (Printexc.to_string exn) ; - exit 1 - -let load ~filename = - let open TzPervasives in - let string = - try Lwt_main.run @@ Tezos_stdlib_unix.Lwt_utils_unix.read_file filename - with exn -> - Format.eprintf - "Michelson_mcmc_samplers.load: read_file %s failed (%s); exiting@." - filename - (Printexc.to_string exn) ; - exit 1 - in - let bytes = Bytes.of_string string in - match Data_encoding.Binary.of_bytes michelson_sample_list_encoding bytes with - | Ok result -> result - | Error err -> - Format.eprintf - "Michelson_mcmc_samplers.load: decoding %s failed (%a); exiting@." - filename - Data_encoding.Binary.pp_read_error - err ; - exit 1 - -(* Helpers *) - -let base_type_to_michelson_type (typ : Type.Base.t) = - let typ = Mikhailsky.map_var (fun _ -> Mikhailsky.unit_ty) typ in - Mikhailsky.to_michelson typ - -module type Sampler_parameters_sig = sig - val initial : State_space.t - - val energy : State_space.t -> float - - val rules : Rules.rule_set list - - val infer : Mikhailsky.node -> Inference.state - - val verbosity : [`Silent | `Progress | `Trace] -end - -(* The Markov chain in state [state] *) -type mc_state = { - state : State_space.t; - jump : State_space.t Fin.Float.prb Lazy.t; -} - -module State_hashtbl = Hashtbl.Make (State_space) - -(** Generic MCMC michelson sampler (can be used for code and data) *) -module Make_generic (P : Sampler_parameters_sig) = struct - let uniform (l : State_space.t list) : State_space.t Fin.Float.prb = - match l with - | [] -> - (* This can only happen is the MCMC was driven to a coffin state, - which means that it's not reversible (this is a bug) *) - assert false - | _ -> - let arr = Array.of_list l in - let emp = Emp.of_raw_data arr in - Fin.Float.counts_of_empirical (module State_hashtbl) emp - |> Fin.Float.normalize - - let unrecoverable_failure err current result = - Format.eprintf "Error when typechecking term:@." ; - Format.eprintf "%a@." Inference.pp_inference_error err ; - Format.eprintf "Original state: @[%a@]@." State_space.pp current ; - Format.eprintf "Erroneous term: %a@." Mikhailsky.pp result ; - Stdlib.failwith "in sampler.ml: unrecoverable failure." - - let of_state : State_space.t -> mc_state = - fun state -> - { - state; - jump = - Lazy.from_fun (fun () -> - let current = state in - let rewriting_options = Rules.rewriting current P.rules in - let term = current.term in - let rewritings = - List.fold_left - (fun rewritings (path, replacement) -> - let result = Kernel.Rewriter.subst ~term ~path ~replacement in - let typing = - Lazy.from_fun (fun () -> - try P.infer result - with Inference.Ill_typed_script err -> - unrecoverable_failure err current result) - in - {State_space.typing; term = result} :: rewritings) - [] - rewriting_options - in - uniform rewritings); - } - - module MH_params : Mh.MH_parameters with type t = mc_state = struct - type t = mc_state - - let pp fmtr {state; jump = _} = State_space.pp fmtr state - - let trace state = - match P.verbosity with - | `Silent | `Progress -> () - | `Trace -> - Format.eprintf "@." ; - Format.eprintf "%a" State_space.pp state ; - Format.eprintf "energy:@." ; - Format.eprintf "%f:@." (P.energy state) - - let proposal_log_density s1 s2 = - let jump = Lazy.force s1.jump in - let p = try Fin.Float.eval_prb jump s2.state with Not_found -> 0.0 in - Log_space.of_float p - - let proposal mcmc_state rng_state = - trace mcmc_state.state ; - let dist = Lazy.force mcmc_state.jump in - let next = Fin.Float.sample (Fin.Float.as_measure dist) rng_state in - of_state next - - let log_weight state = Log_space.unsafe_cast (-.P.energy state.state) - end - - module Sampler = Mh.Make (MH_params) - - let generator ~burn_in = - P.(Sampler.mcmc ~verbosity ~initial:(of_state initial) ~burn_in) -end - -module Make_code_sampler - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) - (X : sig - val rng_state : Random.State.t - - val target_size : int - - val verbosity : [`Silent | `Progress | `Trace] - end) = -struct - module Autocomp = Autocomp.Make (Michelson_base) (Crypto_samplers) - - module MCMC = Make_generic (struct - let initial = - let term = Mikhailsky.Instructions.hole in - let typing = Lazy.from_val @@ snd (Inference.infer_with_state term) in - {State_space.term; typing} - - let energy state = - let stats = State_space.statistics state in - let size_deficit = - abs_float - (float_of_int X.target_size -. float_of_int stats.State_space.size) - in - let holes_proportion = float stats.holes /. float stats.size in - let holes_deficit = - (* we want at least 1% of holes, above is ok *) - if holes_proportion < 0.01 then - (0.01 -. holes_proportion) *. size_deficit - else 0.0 - in - size_deficit +. holes_deficit - - let rules = Rules.Instruction.rules - - let infer term = snd (Inference.infer_with_state term) - - let verbosity = X.verbosity - end) - - let to_michelson {state = ({typing; term} : State_space.t); jump = _} = - let typing = Lazy.force typing in - let node, (bef, aft), state = - Autocomp.complete_code typing term X.rng_state - in - let node = - Micheline.strip_locations @@ Mikhailsky_to_michelson.convert node state - in - { - term = node; - bef = Type_helpers.stack_type_to_michelson_type_list bef; - aft = Type_helpers.stack_type_to_michelson_type_list aft; - } - - let generator ~burn_in = - Gen.map (MCMC.generator ~burn_in) @@ fun after_burn_in -> - Gen.map after_burn_in to_michelson -end - -module Make_data_sampler - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) - (X : sig - val rng_state : Random.State.t - - val target_size : int - - val verbosity : [`Silent | `Progress | `Trace] - end) = -struct - module Autocomp = Autocomp.Make (Michelson_base) (Crypto_samplers) - module Rewrite_rules = - Rules.Data_rewrite_leaves (Michelson_base) (Crypto_samplers) - - module MCMC = Make_generic (struct - let initial = - let term = Mikhailsky.Data.hole in - let typing = - Lazy.from_val @@ snd (Inference.infer_data_with_state term) - in - {State_space.term; typing} - - let energy state = - let stats = State_space.statistics state in - let size_deficit = - abs_float - (float_of_int X.target_size -. float_of_int stats.State_space.size) - in - let holes_proportion = - float_of_int stats.holes /. float_of_int stats.size - in - let holes_deficit = - (* we want at least 10% of holes, above is ok *) - if holes_proportion < 0.5 then (0.5 -. holes_proportion) *. size_deficit - else 0.0 - in - let depth_deficit = - abs_float - ((0.1 *. float_of_int X.target_size) -. float_of_int stats.depth) - in - size_deficit +. holes_deficit +. depth_deficit - - let rules = Rewrite_rules.rules X.rng_state - - let infer term = snd (Inference.infer_data_with_state term) - - let verbosity = X.verbosity - end) - - let to_michelson {state = ({typing; term} : State_space.t); jump = _} = - let typing = Lazy.force typing in - let node, _ = Autocomp.complete_data typing term X.rng_state in - let typ, state = - try Inference.infer_data_with_state node - with _ -> - Format.eprintf "Bug found!@." ; - Format.eprintf "Ill-typed autocompletion. Resulting term:@." ; - Format.eprintf "%a@." Mikhailsky.pp node ; - Stdlib.failwith "in generators.ml: unrecoverable failure" - in - let node = - Micheline.strip_locations @@ Mikhailsky_to_michelson.convert node state - in - {term = node; typ = base_type_to_michelson_type typ} - - let generator ~burn_in = - Gen.map (MCMC.generator ~burn_in) @@ fun after_burn_in -> - Gen.map after_burn_in to_michelson -end diff --git a/src/proto_020_PsParisC/lib_benchmark/michelson_mcmc_samplers.mli b/src/proto_020_PsParisC/lib_benchmark/michelson_mcmc_samplers.mli deleted file mode 100644 index bd67d13e3c16..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/michelson_mcmc_samplers.mli +++ /dev/null @@ -1,115 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(** MCMC-based Michelson data and code samplers. *) - -open Protocol - -(** MCMC samplers can either produce data or code. Note that the samplers - natively produce data and code in Micheline (ie untyped) form. *) - -type michelson_code = { - term : Script_repr.expr; - (** [term] is a typeable Michelson program in Micheline form. *) - bef : Script_repr.expr list; - (** [bef] is an input stack type for which [term] is a well-typed script. *) - aft : Script_repr.expr list; - (** [aft] is the stack type corresponding to the execution of [term] - on a stack of type [bef]. *) -} - -type michelson_data = { - term : Script_repr.expr; - (** [term] is a typeable Michelson data in Micheline form. *) - typ : Script_repr.expr; (** [typ] is the type of [term]. *) -} - -(** A [michelson_sample] is either a code sample or a data sample. *) -type michelson_sample = Code of michelson_code | Data of michelson_data - -(** Encoding used for saving or loading data. *) -val michelson_sample_list_encoding : michelson_sample list Data_encoding.t - -(** Saving a list of samples to a file. - Exits with code 1 if an error arises during encoding or file manipulation. *) -val save : filename:string -> terms:michelson_sample list -> unit - -(** Loading a list of samples from a file. - Exits with code 1 if an error arises during decoding or file manipulation. *) -val load : filename:string -> michelson_sample list - -(** [Make_code_sampler] produces a sampler for well-typed Michelson code. - The parameters of the functor are: - - a module [Michelson_base] implementing samplers for basic values - - a module [Crypto_samplers] implementing samplers for pk/pkh/sk triplets - - a module [X] containing some parameters to the Markov chain sampler: - - [rng_state] is the mutable state that will be used during sampling - - [target_size] specifies the size, in terms of Micheline nodes, of the - terms that the sampler should try to produce - - [verbosity] specifies how much information should be written on stdout - during the sampling process. - - The outcome is a [michelson_code] [generator]. The [burn_in] parameter - specifies how much samples should be thrown away before starting to - produce sample (this is used to let the underlying Markov chain reach - its stationary distribution - the value should be commensurate with - the [target_size]. - *) -module Make_code_sampler : functor - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) - (X : sig - val rng_state : Random.State.t - - val target_size : int - - val verbosity : [`Progress | `Silent | `Trace] - end) - -> sig - (** [generator ~burn_in rng_state] performs a burn-in phase consisting of sampling [burn_in] times, - throwing the results away and returns a michelson term sampler. The goal of burn-in is - to drive the underlying Markov chain to its stationary distribution, ie to sample - terms around the specified [X.target_size]. *) - val generator : burn_in:int -> Random.State.t -> michelson_code Stats.Gen.t -end - -(** See documentation for [Make_code_sampler] *) -module Make_data_sampler : functor - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) - (X : sig - val rng_state : Random.State.t - - val target_size : int - - val verbosity : [`Progress | `Silent | `Trace] - end) - -> sig - (** [generator ~burn_in rng_state] performs a burn-in phase consisting of sampling [burn_in] times, - throwing the results away and returns a michelson term sampler. The goal of burn-in is - to drive the underlying Markov chain to its stationary distribution, ie to sample - terms around the specified [X.target_size]. *) - val generator : burn_in:int -> Random.State.t -> michelson_data Stats.Gen.t -end diff --git a/src/proto_020_PsParisC/lib_benchmark/michelson_samplers.ml b/src/proto_020_PsParisC/lib_benchmark/michelson_samplers.ml deleted file mode 100644 index a872dc08ca63..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/michelson_samplers.ml +++ /dev/null @@ -1,824 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021-2022 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 Protocol -open Script_typed_ir - -type parameters = { - base_parameters : Michelson_samplers_base.parameters; - list_size : Base_samplers.range; - set_size : Base_samplers.range; - map_size : Base_samplers.range; -} - -let parameters_encoding = - let open Data_encoding in - let range_encoding = Base_samplers.range_encoding in - conv - (fun {base_parameters; list_size; set_size; map_size} -> - (base_parameters, (list_size, set_size, map_size))) - (fun (base_parameters, (list_size, set_size, map_size)) -> - {base_parameters; list_size; set_size; map_size}) - (merge_objs - Michelson_samplers_base.parameters_encoding - (obj3 - (req "list_size" range_encoding) - (req "set_size" range_encoding) - (req "map_size" range_encoding))) - -(* ------------------------------------------------------------------------- *) -(* Type names. *) - -(* We only want to generated inhabited types, hence Never is not included. *) - -type type_name = - [ `TUnit - | `TInt - | `TNat - | `TSignature - | `TString - | `TBytes - | `TMutez - | `TKey_hash - | `TKey - | `TTimestamp - | `TAddress - | `TBool - | `TPair - | `TOr - | `TLambda - | `TOption - | `TList - | `TSet - | `TMap - | `TBig_map - | `TContract - | `TSapling_transaction - | `TSapling_transaction_deprecated - | `TSapling_state - | `TOperation - | `TChain_id - | `TBls12_381_g1 - | `TBls12_381_g2 - | `TBls12_381_fr - | `TTicket ] - -type atomic_type_name = - [ `TUnit - | `TInt - | `TNat - | `TSignature - | `TString - | `TBytes - | `TMutez - | `TKey_hash - | `TKey - | `TTimestamp - | `TAddress - | `TBool - | `TSapling_transaction - | `TSapling_transaction_deprecated - | `TSapling_state - | `TChain_id - | `TBls12_381_g1 - | `TBls12_381_g2 - | `TBls12_381_fr ] - -type non_atomic_type_name = - [ `TPair - | `TOr - | `TLambda - | `TOption - | `TList - | `TSet - | `TMap - | `TBig_map - | `TContract - | `TTicket ] - -(* Ensure inclusion of atomic_type_name in type_name *) -let (_ : atomic_type_name -> type_name) = fun x -> (x :> type_name) - -(* Ensure inclusion of non_atomic_type_name in type_name *) -let (_ : non_atomic_type_name -> type_name) = fun x -> (x :> type_name) - -let all_atomic_type_names : atomic_type_name array = - [| - `TUnit; - `TInt; - `TNat; - `TSignature; - `TString; - `TBytes; - `TMutez; - `TKey_hash; - `TKey; - `TTimestamp; - `TAddress; - `TBool; - `TSapling_transaction; - `TSapling_transaction_deprecated; - `TSapling_state; - `TChain_id; - `TBls12_381_g1; - `TBls12_381_g2; - `TBls12_381_fr; - |] - -let all_non_atomic_type_names : non_atomic_type_name array = - [| - `TPair; - `TOr; - `TLambda; - `TOption; - `TList; - `TSet; - `TMap; - `TBig_map; - `TContract; - `TTicket; - |] - -type comparable_type_name = - [ `TUnit - | `TInt - | `TNat - | `TSignature - | `TString - | `TBytes - | `TMutez - | `TBool - | `TKey_hash - | `TKey - | `TTimestamp - | `TChain_id - | `TAddress - | `TPair - | `TOr - | `TOption ] - -(* Ensure inclusion of comparable_type_name in type_name *) -let (_ : comparable_type_name -> type_name) = fun x -> (x :> type_name) - -type 'a comparable_and_atomic = 'a - constraint 'a = [< comparable_type_name] constraint 'a = [< atomic_type_name] - -let all_comparable_atomic_type_names : 'a comparable_and_atomic array = - [| - `TUnit; - `TInt; - `TNat; - `TSignature; - `TString; - `TBytes; - `TMutez; - `TBool; - `TKey_hash; - `TKey; - `TTimestamp; - `TChain_id; - `TAddress; - |] - -type 'a comparable_and_non_atomic = 'a - constraint 'a = [< comparable_type_name] - constraint 'a = [< non_atomic_type_name] - -let all_comparable_non_atomic_type_names : 'a comparable_and_non_atomic array = - [|`TPair; `TOr; `TOption|] - -(* Ensure inclusion of comparable_and_atomic in type_name *) -let (_ : 'a comparable_and_atomic -> type_name) = fun x -> (x :> type_name) - -(* ------------------------------------------------------------------------- *) -(* Uniform type name generators *) - -open Sampling_helpers - -let uniform : ?blacklist:('a -> bool) -> 'a array -> 'a sampler = - fun ?blacklist arr rng_state -> - let arr = - match blacklist with - | None -> arr - | Some blacklist -> - Array.to_seq arr - |> Seq.filter (fun x -> not (blacklist x)) - |> Array.of_seq - in - let i = Random.State.int rng_state (Array.length arr) in - arr.(i) - -let uniform_atomic_type_name ?blacklist : atomic_type_name sampler = - uniform ?blacklist all_atomic_type_names - -let uniform_comparable_atomic_type_name : 'a comparable_and_atomic sampler = - uniform all_comparable_atomic_type_names - -let uniform_comparable_non_atomic_type_name : - 'a comparable_and_non_atomic sampler = - uniform all_comparable_non_atomic_type_names - -(* ------------------------------------------------------------------------- *) -(* Random generation functor. *) - -module type S = sig - module Michelson_base : Michelson_samplers_base.S - - module Random_type : sig - val m_type : - size:int -> - ?blacklist:(type_name -> bool) -> - unit -> - Script_typed_ir.ex_ty sampler - - val m_comparable_type : - size:int -> Script_ir_translator.ex_comparable_ty sampler - end - - module Random_value : sig - val value : ('a, _) Script_typed_ir.ty -> 'a sampler - - val comparable : 'a Script_typed_ir.comparable_ty -> 'a sampler - - val stack : ('a, 'b) Script_typed_ir.stack_ty -> ('a * 'b) sampler - end -end - -exception SamplingError of string - -let fail_sampling error = raise (SamplingError error) - -module Make - (P : sig - val parameters : parameters - end) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) : S = struct - module Michelson_base = Michelson_samplers_base.Make (struct - let parameters = P.parameters.base_parameters - end) - - let memo_size = - Alpha_context.Sapling.Memo_size.parse_z Z.zero |> Result.get_ok - - (* [pick_split x] randomly splits the integer [x] into two integers [left] - and [right] such that [1 <= left], [1 <= right], and [left + right = x]. - Expects [x >= 2]. *) - let pick_split : int -> (int * int) sampler = - fun x rng_state -> - if x < 2 then invalid_arg "pick_split" - else - (* x >= 2 *) - let left = 1 + Random.State.int rng_state (x - 1) in - let right = x - left in - assert (left + right = x) ; - (left, right) - - (* Random generation of Michelson types. *) - module Random_type = struct - let type_of_atomic_type_name (at_tn : atomic_type_name) : - Script_typed_ir.ex_ty = - match at_tn with - | `TString -> Ex_ty string_t - | `TNat -> Ex_ty nat_t - | `TKey -> Ex_ty key_t - | `TBytes -> Ex_ty bytes_t - | `TBool -> Ex_ty bool_t - | `TAddress -> Ex_ty address_t - | `TTimestamp -> Ex_ty timestamp_t - | `TKey_hash -> Ex_ty key_hash_t - | `TMutez -> Ex_ty mutez_t - | `TSignature -> Ex_ty signature_t - | `TUnit -> Ex_ty unit_t - | `TInt -> Ex_ty int_t - | `TSapling_state -> Ex_ty (sapling_state_t ~memo_size) - | `TSapling_transaction -> Ex_ty (sapling_transaction_t ~memo_size) - | `TSapling_transaction_deprecated -> - Ex_ty (sapling_transaction_deprecated_t ~memo_size) - | `TChain_id -> Ex_ty chain_id_t - | `TBls12_381_g1 -> Ex_ty bls12_381_g1_t - | `TBls12_381_g2 -> Ex_ty bls12_381_g2_t - | `TBls12_381_fr -> Ex_ty bls12_381_fr_t - - let comparable_type_of_comparable_atomic_type_name - (cmp_tn : 'a comparable_and_atomic) : - Script_ir_translator.ex_comparable_ty = - match cmp_tn with - | `TString -> Ex_comparable_ty string_t - | `TNat -> Ex_comparable_ty nat_t - | `TBytes -> Ex_comparable_ty bytes_t - | `TBool -> Ex_comparable_ty bool_t - | `TAddress -> Ex_comparable_ty address_t - | `TTimestamp -> Ex_comparable_ty timestamp_t - | `TKey_hash -> Ex_comparable_ty key_hash_t - | `TMutez -> Ex_comparable_ty mutez_t - | `TInt -> Ex_comparable_ty int_t - | `TUnit -> Ex_comparable_ty unit_t - | `TSignature -> Ex_comparable_ty signature_t - | `TKey -> Ex_comparable_ty key_t - | `TChain_id -> Ex_comparable_ty chain_id_t - - let rec m_type ~size ?blacklist () : Script_typed_ir.ex_ty sampler = - let open Script_ir_translator in - let open M in - let blacklist = - match blacklist with - | None -> None - | Some blacklist -> Some (fun x -> blacklist (x :> type_name)) - in - if size <= 0 then Stdlib.failwith "m_type: size <= 0" - else if size = 1 then - (* only atomic types can have size 1 *) - let* at_tn = uniform_atomic_type_name ?blacklist in - return (type_of_atomic_type_name at_tn) - else if size = 2 then - bind - (uniform [|`TOption; `TList; `TSet; `TTicket; `TContract|] ?blacklist) - @@ function - | `TOption -> ( - let* (Ex_ty t) = m_type ~size:1 ?blacklist () in - match option_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TList -> ( - let* (Ex_ty t) = m_type ~size:1 ?blacklist () in - match list_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TSet -> ( - let* (Ex_comparable_ty t) = m_comparable_type ~size:1 in - match set_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TTicket -> ( - let* (Ex_comparable_ty contents) = m_comparable_type ~size:1 in - match ticket_t (-1) contents with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TContract -> ( - let* (Ex_ty t) = m_type ~size:1 ?blacklist () in - match contract_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - else - bind (uniform all_non_atomic_type_names ?blacklist) @@ function - | `TPair -> ( - let* lsize, rsize = pick_split (size - 1) in - let* (Ex_ty left) = m_type ~size:lsize ?blacklist () in - let* (Ex_ty right) = m_type ~size:rsize ?blacklist () in - match pair_t (-1) left right with - | Error _ -> assert false - | Ok (Ty_ex_c res_ty) -> return @@ Ex_ty res_ty) - | `TLambda -> ( - let* lsize, rsize = pick_split (size - 1) in - let* (Ex_ty domain) = m_type ~size:lsize ?blacklist () in - let* (Ex_ty range) = m_type ~size:rsize ?blacklist () in - match lambda_t (-1) domain range with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TOr -> ( - let* lsize, rsize = pick_split (size - 1) in - let* (Ex_ty left) = m_type ~size:lsize ?blacklist () in - let* (Ex_ty right) = m_type ~size:rsize ?blacklist () in - match or_t (-1) left right with - | Error _ -> assert false - | Ok (Ty_ex_c res_ty) -> return @@ Ex_ty res_ty) - | `TOption -> ( - let* (Ex_ty t) = m_type ~size:(size - 1) ?blacklist () in - match option_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TMap -> ( - let* lsize, rsize = pick_split (size - 1) in - let* (Ex_comparable_ty key) = m_comparable_type ~size:lsize in - let* (Ex_ty elt) = m_type ~size:rsize ?blacklist () in - match map_t (-1) key elt with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TSet -> ( - let* (Ex_comparable_ty key_ty) = - m_comparable_type ~size:(size - 1) - in - match set_t (-1) key_ty with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TList -> ( - let* (Ex_ty elt) = m_type ~size:(size - 1) ?blacklist () in - match list_t (-1) elt with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TTicket -> ( - let* (Ex_comparable_ty contents) = - m_comparable_type ~size:(size - 1) - in - match ticket_t (-1) contents with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TContract -> ( - let* (Ex_ty t) = m_type ~size:(size - 1) ?blacklist () in - match contract_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TBig_map -> - (* Don't know what to do with theses. Redraw. *) - m_type ~size ?blacklist () - - and m_comparable_type ~size : Script_ir_translator.ex_comparable_ty sampler - = - let open M in - let open Script_ir_translator in - let atomic_case () = - let* at_tn = uniform_comparable_atomic_type_name in - return (comparable_type_of_comparable_atomic_type_name at_tn) - in - let option_case size = - let size = size - 1 in - let* (Ex_comparable_ty t) = m_comparable_type ~size in - match option_t (-1) t with - | Error _ -> (* what should be done here? *) assert false - | Ok res_ty -> return @@ Ex_comparable_ty res_ty - in - let pair_case size = - let size = size - 1 in - let* size_left = - Base_samplers.sample_in_interval ~range:{min = 1; max = size - 1} - in - let size_right = size - size_left in - let* (Ex_comparable_ty l) = m_comparable_type ~size:size_left in - let* (Ex_comparable_ty r) = m_comparable_type ~size:size_right in - match comparable_pair_t (-1) l r with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_comparable_ty res_ty - in - let or_case size = - let size = size - 1 in - let* size_left = - Base_samplers.sample_in_interval ~range:{min = 1; max = size - 1} - in - let size_right = size - size_left in - let* (Ex_comparable_ty l) = m_comparable_type ~size:size_left in - let* (Ex_comparable_ty r) = m_comparable_type ~size:size_right in - match comparable_or_t (-1) l r with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_comparable_ty res_ty - in - - if size <= 1 then atomic_case () - else if size = 2 then option_case size - else - let* cmp_tn = uniform_comparable_non_atomic_type_name in - match cmp_tn with - | `TPair -> pair_case size - | `TOr -> or_case size - | `TOption -> option_case size - end - - (* Type-directed generation of random values. *) - module Random_value : sig - val value : ('a, _) Script_typed_ir.ty -> 'a sampler - - val comparable : 'a Script_typed_ir.comparable_ty -> 'a sampler - - val stack : ('a, 'b) Script_typed_ir.stack_ty -> ('a * 'b) sampler - end = struct - let implicit = Crypto_samplers.pkh - - let originated rng_state = - (* For a description of the format, see - tezos-codec describe alpha.contract binary encoding *) - let string = - "\001" ^ Base_samplers.uniform_string ~nbytes:20 rng_state ^ "\000" - in - Data_encoding.Binary.of_string_exn - Alpha_context.Contract.originated_encoding - string - - let sc_rollup rng_state = - let string = Base_samplers.uniform_string ~nbytes:20 rng_state in - Data_encoding.Binary.of_string_exn - Alpha_context.Sc_rollup.Address.encoding - string - - let entrypoint rng_state = - Alpha_context.Entrypoint.of_string_strict_exn - @@ Base_samplers.string ~size:{min = 1; max = 31} rng_state - - let address rng_state = - if Base_samplers.uniform_bool rng_state then - let destination = - Alpha_context.Destination.Contract (Implicit (implicit rng_state)) - in - {destination; entrypoint = Alpha_context.Entrypoint.default} - else - let destination = - Alpha_context.Destination.Contract (Originated (originated rng_state)) - in - let entrypoint = entrypoint rng_state in - {destination; entrypoint} - - let generate_originated_contract : - type arg argc. - (arg, argc) Script_typed_ir.ty -> - arg Script_typed_ir.typed_contract sampler = - fun arg_ty -> - let open M in - let* c = originated in - let* entrypoint in - let destination = Alpha_context.Destination.Contract (Originated c) in - return - (Typed_contract.Internal_for_tests.typed_exn - arg_ty - destination - entrypoint) - - let generate_sc_rollup_contract : - type arg argc. - (arg, argc) Script_typed_ir.ty -> - arg Script_typed_ir.typed_contract sampler = - fun arg_ty -> - let open M in - let* ru = sc_rollup in - let destination = Alpha_context.Destination.Sc_rollup ru in - return - (Typed_contract.Internal_for_tests.typed_exn - arg_ty - destination - Alpha_context.Entrypoint.default) - - let generate_any_type_contract : - type arg argc. - (arg, argc) Script_typed_ir.ty -> - arg Script_typed_ir.typed_contract sampler = - fun arg_ty -> - let open M in - let* b = Base_samplers.uniform_bool in - if b then generate_originated_contract arg_ty - else generate_sc_rollup_contract arg_ty - - let generate_contract : - type arg argc. - (arg, argc) Script_typed_ir.ty -> - arg Script_typed_ir.typed_contract sampler = - fun arg_ty -> - let open M in - match arg_ty with - | Unit_t -> - let* b = Base_samplers.uniform_bool in - if b then - let* pkh = implicit in - let destination = - Alpha_context.Destination.Contract (Implicit pkh) - in - let entrypoint = Alpha_context.Entrypoint.default in - return - (Typed_contract.Internal_for_tests.typed_exn - arg_ty - destination - entrypoint) - else generate_any_type_contract arg_ty - | _ -> generate_any_type_contract arg_ty - - let chain_id rng_state = - let string = Base_samplers.uniform_string ~nbytes:4 rng_state in - Data_encoding.Binary.of_string_exn Script_chain_id.encoding string - - let signature rng_state = - Script_signature.make (Michelson_base.signature rng_state) - - let rec value : type a ac. (a, ac) Script_typed_ir.ty -> a sampler = - let open Script_typed_ir in - fun typ -> - match typ with - | Never_t -> assert false - | Unit_t -> M.return () - | Int_t -> Michelson_base.int - | Nat_t -> Michelson_base.nat - | Signature_t -> signature - | String_t -> Michelson_base.string - | Bytes_t -> Michelson_base.bytes - | Mutez_t -> Michelson_base.tez - | Key_hash_t -> Crypto_samplers.pkh - | Key_t -> Crypto_samplers.pk - | Timestamp_t -> Michelson_base.timestamp - | Bool_t -> Base_samplers.uniform_bool - | Address_t -> address - | Pair_t (left_t, right_t, _, _) -> - M.( - let* left_v = value left_t in - let* right_v = value right_t in - return (left_v, right_v)) - | Or_t (left_t, right_t, _, _) -> - fun rng_state -> - if Base_samplers.uniform_bool rng_state then - L (value left_t rng_state) - else R (value right_t rng_state) - | Lambda_t (arg_ty, ret_ty, _) -> generate_lambda arg_ty ret_ty - | Option_t (ty, _, _) -> - fun rng_state -> - if Base_samplers.uniform_bool rng_state then None - else Some (value ty rng_state) - | List_t (elt_ty, _) -> generate_list elt_ty - | Set_t (elt_ty, _) -> generate_set elt_ty - | Map_t (key_ty, val_ty, _) -> generate_map key_ty val_ty - | Contract_t (arg_ty, _) -> generate_contract arg_ty - | Operation_t -> generate_operation - | Big_map_t (key_ty, val_ty, _) -> generate_big_map key_ty val_ty - | Chain_id_t -> chain_id - | Bls12_381_g1_t -> generate_bls12_381_g1 - | Bls12_381_g2_t -> generate_bls12_381_g2 - | Bls12_381_fr_t -> generate_bls12_381_fr - | Ticket_t (contents_ty, _) -> generate_ticket contents_ty - | Sapling_transaction_t _ -> - fail_sampling - "Michelson_samplers: sapling transactions not handled yet" - | Sapling_transaction_deprecated_t _ -> - fail_sampling - "Michelson_samplers: sapling transactions not handled yet" - | Sapling_state_t _ -> - fail_sampling "Michelson_samplers: sapling state not handled yet" - | Chest_key_t -> - fail_sampling "Michelson_samplers: chest key not handled yet" - | Chest_t -> fail_sampling "Michelson_samplers: chest not handled yet" - - and generate_lambda : - type arg argc ret retc. - (arg, argc) Script_typed_ir.ty -> - (ret, retc) Script_typed_ir.ty -> - (arg, ret) Script_typed_ir.lambda sampler = - fun _arg_ty _ret_ty _rng_state -> - fail_sampling "Michelson_samplers: lambda not handled yet" - - and generate_list : - type elt eltc. - (elt, eltc) Script_typed_ir.ty -> elt Script_list.t sampler = - fun elt_type -> - let open M in - let* _, elements = - Structure_samplers.list - ~range:P.parameters.list_size - ~sampler:(value elt_type) - in - return @@ Script_list.of_list elements - - (* Note that we might very well generate sets smaller than the specified range (consider the - case of a set of type [unit]). *) - and generate_set : - type elt. - elt Script_typed_ir.comparable_ty -> elt Script_typed_ir.set sampler = - fun elt_ty -> - let open M in - let* _, elements = - Structure_samplers.list - ~range:P.parameters.set_size - ~sampler:(value elt_ty) - in - return - @@ List.fold_left - (fun set x -> Script_set.update x true set) - (Script_set.empty elt_ty) - elements - - and generate_map : - type key elt eltc. - key Script_typed_ir.comparable_ty -> - (elt, eltc) Script_typed_ir.ty -> - (key, elt) Script_typed_ir.map sampler = - fun key_ty elt_ty rng_state -> - let size = - Base_samplers.sample_in_interval rng_state ~range:P.parameters.map_size - in - let keys = List.init size (fun _ -> value key_ty rng_state) in - let elts = List.init size (fun _ -> value elt_ty rng_state) in - List.fold_left2 - (fun map key elt -> Script_map.update key (Some elt) map) - (Script_map.empty key_ty) - keys - elts - - and generate_big_map : - type key elt eltc. - key Script_typed_ir.comparable_ty -> - (elt, eltc) Script_typed_ir.ty -> - (key, elt) Script_typed_ir.big_map sampler = - let open Lwt_result_wrap_syntax in - let open Script_typed_ir in - fun key_ty elt_ty rng_state -> - let open TzPervasives in - let result = - Lwt_main.run - (let* ctxt, _ = Execution_context.make ~rng_state () in - let big_map = Script_big_map.empty key_ty elt_ty in - (* Cannot have big maps under big maps *) - let*? opt_elt_ty = - option_t (-1) elt_ty |> Environment.wrap_tzresult - in - let map = generate_map key_ty opt_elt_ty rng_state in - let* big_map, _ = - let*! result = - Script_map.fold - (fun k v acc -> - let* bm, ctxt_acc = acc in - Script_big_map.update ctxt_acc k v bm) - map - (return (big_map, ctxt)) - in - Lwt.return @@ Environment.wrap_tzresult result - in - return big_map) - in - match result with - | Ok x -> x - | Error e -> - Format.eprintf - "%a@." - (Error_monad.TzTrace.pp_print Error_monad.pp) - e ; - fail_sampling "raise_if_error" - - and generate_operation : Script_typed_ir.operation sampler = - fun rng_state -> - let transfer = generate_transfer_tokens rng_state in - Script_typed_ir.{piop = transfer; lazy_storage_diff = None} - - and generate_transfer_tokens : - Script_typed_ir.packed_internal_operation sampler = - fun _rng_state -> fail_sampling "generate_transfer_tokens: unimplemented" - - and generate_bls12_381_g1 : Script_bls.G1.t sampler = - fun rng_state -> - let b = Bls12_381.G1.(to_bytes (random ~state:rng_state ())) in - match Script_bls.G1.of_bytes_opt b with - | Some x -> x - | None -> assert false - - and generate_bls12_381_g2 : Script_bls.G2.t sampler = - fun rng_state -> - let b = Bls12_381.G2.(to_bytes (random ~state:rng_state ())) in - match Script_bls.G2.of_bytes_opt b with - | Some x -> x - | None -> assert false - - and generate_bls12_381_fr : Script_bls.Fr.t sampler = - fun rng_state -> - let b = Bls12_381.Fr.(to_bytes (random ~state:rng_state ())) in - match Script_bls.Fr.of_bytes_opt b with - | Some x -> x - | None -> assert false - - and generate_ticket : - type a ac. - (a, ac) Script_typed_ir.ty -> a Script_typed_ir.ticket sampler = - fun ty rng_state -> - let contents = value ty rng_state in - let ticketer = - Alpha_context.Contract.Implicit (Crypto_samplers.pkh rng_state) - in - let amount = - let open Ticket_amount in - match of_n (Michelson_base.nat rng_state) with - | Some amount -> add amount one - | None -> one - in - Script_typed_ir.{ticketer; contents; amount} - - let comparable ty = value ty - - (* Random stack generation. *) - let rec stack : type a b. (a, b) Script_typed_ir.stack_ty -> (a * b) sampler - = - let open M in - let open Script_typed_ir in - fun stack_ty -> - match stack_ty with - | Item_t (ty, tl) -> - let* elt = value ty in - let* tl = stack tl in - return ((elt, tl) : a * b) - | Bot_t -> return (EmptyCell, EmptyCell) - end -end - -module Internal_for_tests = struct - type nonrec type_name = type_name -end diff --git a/src/proto_020_PsParisC/lib_benchmark/michelson_samplers.mli b/src/proto_020_PsParisC/lib_benchmark/michelson_samplers.mli deleted file mode 100644 index 78ee62a3392c..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/michelson_samplers.mli +++ /dev/null @@ -1,172 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021-2022 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. *) -(* *) -(*****************************************************************************) - -(** Sampling various Michelson values. *) - -exception SamplingError of string - -open Protocol -open Base_samplers - -(** This module exposes a functor implementing various samplers for Michelson. - These allow to sample: - - types and comparable types (given a target size), - - values and comparable values of a given Michelson type (given some more - parameters fixed at functor instantiation time) - - stacks - - Note that some kind of values might not be supported. At the time of writing, - the value sampler doesn't handle the following types: - - Sapling transaction and states - - Timelock chests and chest keys - - Operations - - Lambdas (ie code) - - For the latter, consider using the samplers in {!Michelson_mcmc_samplers}. -*) - -(** Parameters for the Michelson samplers. *) -type parameters = { - base_parameters : Michelson_samplers_base.parameters; - list_size : Base_samplers.range; - (** The range of the size, measured in number of elements, in which lists must be sampled.*) - set_size : Base_samplers.range; - (** The range of the size, measured in number of elements, in which sets must be sampled.*) - map_size : Base_samplers.range; - (** The range of the size, measured in number of bindings, in which maps must be sampled.*) -} - -(** Encoding for sampler prameters. *) -val parameters_encoding : parameters Data_encoding.t - -type type_name = - [ `TUnit - | `TInt - | `TNat - | `TSignature - | `TString - | `TBytes - | `TMutez - | `TKey_hash - | `TKey - | `TTimestamp - | `TAddress - | `TBool - | `TPair - | `TOr - | `TLambda - | `TOption - | `TList - | `TSet - | `TMap - | `TBig_map - | `TContract - | `TSapling_transaction - | `TSapling_transaction_deprecated - | `TSapling_state - | `TOperation - | `TChain_id - | `TBls12_381_g1 - | `TBls12_381_g2 - | `TBls12_381_fr - | `TTicket ] - -(** The module type produced by the [Make] functor. *) -module type S = sig - (** Basic Michelson samplers, re-exported for convenience by the functor. *) - module Michelson_base : Michelson_samplers_base.S - - (** Samplers for random Michelson types. *) - module Random_type : sig - (** [m_type ~size ?blacklist] samples a type containing exactly - [size] constructors. The [blacklist] is a predicate which can - be used to discard some unwanted cases. *) - val m_type : - size:int -> - ?blacklist:(type_name -> bool) -> - unit -> - Script_typed_ir.ex_ty sampler - - (** [m_comparable_type ~size] samples a comparable type containing - exactly [size] constructors. *) - val m_comparable_type : - size:int -> Script_ir_translator.ex_comparable_ty sampler - end - - (** Samplers for random Michelson values. Restrictions apply on the - supported types as listed at the beginning of this file. *) - module Random_value : sig - (** Sample a value given its type. *) - val value : ('a, _) Script_typed_ir.ty -> 'a sampler - - (** Sample a comparable value given its type. *) - val comparable : 'a Script_typed_ir.comparable_ty -> 'a sampler - - (** Sample a stack given its type. *) - val stack : ('a, 'b) Script_typed_ir.stack_ty -> ('a * 'b) sampler - end -end - -(** Instantiate a module of type {!S}. *) -module Make : functor - (P : sig - val parameters : parameters - end) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) - -> S - -module Internal_for_tests : sig - type type_name = - [ `TAddress - | `TBig_map - | `TBls12_381_fr - | `TBls12_381_g1 - | `TBls12_381_g2 - | `TBool - | `TBytes - | `TChain_id - | `TContract - | `TInt - | `TKey - | `TKey_hash - | `TLambda - | `TList - | `TMap - | `TMutez - | `TNat - | `TOperation - | `TOption - | `TPair - | `TSapling_state - | `TSapling_transaction - | `TSapling_transaction_deprecated - | `TSet - | `TSignature - | `TString - | `TTicket - | `TTimestamp - | `TOr - | `TUnit ] -end diff --git a/src/proto_020_PsParisC/lib_benchmark/michelson_samplers_base.ml b/src/proto_020_PsParisC/lib_benchmark/michelson_samplers_base.ml deleted file mode 100644 index 651a385016bf..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/michelson_samplers_base.ml +++ /dev/null @@ -1,139 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Sampling_helpers - -(** Parameters for basic samplers *) -type parameters = { - int_size : Base_samplers.range; - string_size : Base_samplers.range; - bytes_size : Base_samplers.range; -} - -(** Encoding for basic samplers parameters *) -let parameters_encoding = - let open Data_encoding in - let range = Base_samplers.range_encoding in - conv - (fun {int_size; string_size; bytes_size} -> - (int_size, string_size, bytes_size)) - (fun (int_size, string_size, bytes_size) -> - {int_size; string_size; bytes_size}) - (obj3 - (req "int_size" range) - (req "string_size" range) - (req "bytes_size" range)) - -(** A module of type [S] packs samplers used to construct basic Michelson values. *) -module type S = sig - val int : Script_int.z Script_int.num sampler - - val nat : Script_int.n Script_int.num sampler - - val signature : Tezos_crypto.Signature.t sampler - - val string : Script_string.t sampler - - val bytes : bytes sampler - - val tez : Alpha_context.Tez.t sampler - - val timestamp : Script_timestamp.t sampler -end - -(* Samplers for basic Michelson types. *) - -module Make (P : sig - val parameters : parameters -end) : S = struct - let int rng_state = - let i = Base_samplers.int ~size:P.parameters.int_size rng_state in - Script_int.of_zint i - - let nat rng_state = - let i = Base_samplers.nat ~size:P.parameters.int_size rng_state in - Script_int.abs (Script_int.of_zint i) - - let signature rng_state = - let i = Random.State.int rng_state 5 in - match i with - | 0 -> ( - let open Tezos_crypto.Signature.Ed25519 in - let bytes = Base_samplers.uniform_bytes ~nbytes:size rng_state in - match of_bytes_opt bytes with - | None -> assert false - | Some s -> Tezos_crypto.Signature.of_ed25519 s) - | 1 -> ( - let open Tezos_crypto.Signature.Secp256k1 in - let bytes = Base_samplers.uniform_bytes ~nbytes:size rng_state in - match of_bytes_opt bytes with - | None -> assert false - | Some s -> Tezos_crypto.Signature.of_secp256k1 s) - | 2 -> ( - let open Tezos_crypto.Signature.P256 in - let bytes = Base_samplers.uniform_bytes ~nbytes:size rng_state in - match of_bytes_opt bytes with - | None -> assert false - | Some s -> Tezos_crypto.Signature.of_p256 s) - | 3 -> - (* BLS checks that signatures are on the curve so we need to generate real - ones by signing a message. *) - let open Tezos_crypto.Signature.Bls in - let msg = Base_samplers.uniform_bytes ~nbytes:32 rng_state in - let seed = Base_samplers.uniform_bytes ~nbytes:32 rng_state in - let _, _, sk = generate_key ~seed () in - Tezos_crypto.Signature.of_bls (sign sk msg) - | _ -> - let open Tezos_crypto.Signature in - let bytes = - Base_samplers.uniform_bytes - ~nbytes:Tezos_crypto.Signature.Ed25519.size - rng_state - in - Unknown bytes - - let string rng_state = - let s = - Base_samplers.readable_ascii_string - ~size:P.parameters.string_size - rng_state - in - match Protocol.Script_string.of_string s with - | Ok s -> s - | Error _ -> assert false - - let bytes = Base_samplers.bytes ~size:P.parameters.bytes_size - - let tez rng_state = - let i = Random.State.int64 rng_state (Int64.of_int max_int) in - match Protocol.Alpha_context.Tez.of_mutez i with - | Some res -> res - | None -> assert false - - let timestamp rng_state = - let i = Base_samplers.int ~size:P.parameters.int_size rng_state in - Script_timestamp.of_zint i -end diff --git a/src/proto_020_PsParisC/lib_benchmark/michelson_samplers_base.mli b/src/proto_020_PsParisC/lib_benchmark/michelson_samplers_base.mli deleted file mode 100644 index 91ebc6b4f10d..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/michelson_samplers_base.mli +++ /dev/null @@ -1,67 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(** Samplers for basic Michelson values (not including pairs, ors, tickets, big maps, etc) *) - -open Protocol -open Base_samplers - -(** Parameters for basic samplers *) -type parameters = { - int_size : Base_samplers.range; - (** The range of the size, measured in bytes, in which big integers must be sampled.*) - string_size : Base_samplers.range; - (** The range of the size, measured in bytes, in which strings must be sampled.*) - bytes_size : Base_samplers.range; - (** The range of the size, measured in bytes, in which [bytes] must be sampled.*) -} - -(** Encoding for [parameters] *) -val parameters_encoding : parameters Data_encoding.t - -(** A module of type [S] packs samplers used to construct basic Michelson values. *) -module type S = sig - val int : Script_int.z Script_int.num sampler - - val nat : Script_int.n Script_int.num sampler - - val signature : Tezos_crypto.Signature.t sampler - - val string : Script_string.t sampler - - val bytes : bytes sampler - - val tez : Alpha_context.Tez.t sampler - - val timestamp : Script_timestamp.t sampler -end - -(** The [Make] functor instantiates a module of type [S], where the - samplers satisfy the given parameters. *) -module Make : functor - (P : sig - val parameters : parameters - end) - -> S diff --git a/src/proto_020_PsParisC/lib_benchmark/mikhailsky_to_michelson.ml b/src/proto_020_PsParisC/lib_benchmark/mikhailsky_to_michelson.ml deleted file mode 100644 index 6ee761048306..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/mikhailsky_to_michelson.ml +++ /dev/null @@ -1,229 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -exception Cannot_get_type of Mikhailsky.node * Kernel.Path.t - -exception Unexpected_stack_type of string - -exception Unexpected_base_type - -let unparse_type = Mikhailsky.map_var (fun _ -> Mikhailsky.prim T_unit [] []) - -let project_top (aft : Type.Stack.t) = - match aft.node with - | Type.Stack.Empty_t -> raise (Unexpected_stack_type "empty") - | Type.Stack.Stack_var_t _ -> raise (Unexpected_stack_type "var") - | Type.Stack.Item_t (top, _) -> top - -let project_or (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with - | Type.Base.Or_t (l, r) -> (l, r) - | _ -> raise Unexpected_base_type - -let project_lambda (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with - | Type.Base.Lambda_t (dom, range) -> (dom, range) - | _ -> raise Unexpected_base_type - -let project_list (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with - | Type.Base.List_t t -> t - | _ -> raise Unexpected_base_type - -let project_set (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with Type.Base.Set_t t -> t | _ -> raise Unexpected_base_type - -let project_map (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with - | Type.Base.Map_t (k, v) -> (k, v) - | _ -> raise Unexpected_base_type - -let project_option (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with - | Type.Base.Option_t t -> t - | _ -> raise Unexpected_base_type - -let rec convert_raw : Mikhailsky.node -> (int, 'a) Micheline.node = - fun node -> - match node with - | Micheline.Int (_, i) -> Micheline.Int (0, i) - | Micheline.Prim (_, head, subterms, annots) -> - let head = Mikhailsky_prim.to_michelson head in - Micheline.Prim (0, head, List.map convert_raw subterms, annots) - | Micheline.String (_, s) -> Micheline.String (0, s) - | Micheline.Bytes (_, b) -> Micheline.Bytes (0, b) - | Micheline.Seq (_, subterms) -> - Micheline.Seq (0, List.map convert_raw subterms) - -(* We assume that the term has been completed. *) -let rec convert : - Mikhailsky.node -> Kernel.Path.t -> (int, 'a) Micheline.node Inference.M.t = - fun node path -> - let open Inference.M in - match node with - | Micheline.Int (_, i) -> return (Micheline.Int (0, i)) - | Micheline.String (_, s) -> return (Micheline.String (0, s)) - | Micheline.Bytes (_, b) -> return (Micheline.Bytes (0, b)) - (* Remove annotations *) - | Micheline.Prim (_, prim, [term], _) - when Mikhailsky_prim.kind prim = Annot_kind -> - let path = Kernel.Path.at_index 0 path in - convert term path - (* Fail on holes *) - | Micheline.Prim (_, I_Hole, _, _) | Micheline.Prim (_, D_Hole, _, _) -> - raise Mikhailsky.Term_contains_holes - (* Add type information to or injections *) - | Micheline.Prim (_, I_LEFT, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let _, r = project_or aft in - Inference.instantiate_base r >>= fun r -> - Autocomp.replace_vars r >>= fun r -> - let r = unparse_type r in - let head = Mikhailsky_prim.to_michelson I_LEFT in - return (Micheline.Prim (0, head, [convert_raw r], annots))) - | Micheline.Prim (_, I_RIGHT, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let l, _ = project_or aft in - Inference.instantiate_base l >>= fun l -> - Autocomp.replace_vars l >>= fun l -> - let l = unparse_type l in - let head = Mikhailsky_prim.to_michelson I_RIGHT in - return (Micheline.Prim (0, head, [convert_raw l], annots))) - | Micheline.Prim (_, (I_LEFT | I_RIGHT), _, _) -> - raise Mikhailsky.Ill_formed_mikhailsky - (* Add type information for lambdas *) - | Micheline.Prim (_, I_LAMBDA, [code], annots) -> ( - convert code (Kernel.Path.at_index 0 path) >>= fun code -> - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let dom, range = project_lambda aft in - Inference.instantiate_base dom >>= fun dom -> - Autocomp.replace_vars dom >>= fun dom -> - Inference.instantiate_base range >>= fun range -> - Autocomp.replace_vars range >>= fun range -> - let dom = unparse_type dom in - let range = unparse_type range in - let head = Mikhailsky_prim.to_michelson I_LAMBDA in - return - (Micheline.Prim - (0, head, [convert_raw dom; convert_raw range; code], annots))) - (* Add type information for empty_set, empty_map *) - | Micheline.Prim (_, I_EMPTY_SET, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let elt = project_set aft in - Inference.instantiate_base elt >>= fun elt -> - Autocomp.replace_vars elt >>= fun elt -> - let elt = unparse_type elt in - let head = Mikhailsky_prim.to_michelson I_EMPTY_SET in - return (Micheline.Prim (0, head, [convert_raw elt], annots))) - | Micheline.Prim (_, I_EMPTY_MAP, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let k, v = project_map aft in - Inference.instantiate_base k >>= fun k -> - Autocomp.replace_vars k >>= fun k -> - Inference.instantiate_base v >>= fun v -> - Autocomp.replace_vars v >>= fun v -> - let k = convert_raw (unparse_type k) in - let v = convert_raw (unparse_type v) in - let head = Mikhailsky_prim.to_michelson I_EMPTY_MAP in - return (Micheline.Prim (0, head, [k; v], annots))) - (* Add type information for UNPACK *) - | Micheline.Prim (_, I_UNPACK, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let elt = project_option aft in - Inference.instantiate_base elt >>= fun elt -> - Autocomp.replace_vars elt >>= fun elt -> - let elt = unparse_type elt in - let head = Mikhailsky_prim.to_michelson I_UNPACK in - return (Micheline.Prim (0, head, [convert_raw elt], annots))) - (* Add type information for NIL *) - | Micheline.Prim (_, I_NIL, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let elt = project_list aft in - Inference.instantiate_base elt >>= fun elt -> - Autocomp.replace_vars elt >>= fun elt -> - let elt = unparse_type elt in - let head = Mikhailsky_prim.to_michelson I_NIL in - return (Micheline.Prim (0, head, [convert_raw elt], annots))) - | Micheline.Prim (_, I_NIL, _, _) -> raise Mikhailsky.Ill_formed_mikhailsky - (* Project out type information from arithmetic ops *) - | Prim (_, ((I_ADD | I_SUB | I_MUL | I_EDIV) as instr), [_ty1; _ty2], annots) - -> - let head = Mikhailsky_prim.to_michelson instr in - return (Micheline.Prim (0, head, [], annots)) - | Prim (_, (I_ADD | I_SUB | I_MUL | I_EDIV), _, _) -> - raise Mikhailsky.Ill_formed_mikhailsky - (* Base case *) - | Micheline.Prim (_, head, subterms, annots) -> - let head = Mikhailsky_prim.to_michelson head in - convert_list path 0 subterms [] >>= fun subterms -> - return (Micheline.Prim (0, head, subterms, annots)) - | Micheline.Seq (_, subterms) -> - convert_list path 0 subterms [] >>= fun subterms -> - return (Micheline.Seq (0, subterms)) - -and convert_list path i subterms acc = - let open Inference.M in - match subterms with - | [] -> return (List.rev acc) - | subterm :: tl -> - let path' = Kernel.Path.at_index i path in - convert subterm path' >>= fun term -> - convert_list path (i + 1) tl (term :: acc) - -let convert node state = fst (convert node Kernel.Path.root state) diff --git a/src/proto_020_PsParisC/lib_benchmark/rules.ml b/src/proto_020_PsParisC/lib_benchmark/rules.ml deleted file mode 100644 index 88a148e0213e..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/rules.ml +++ /dev/null @@ -1,975 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Kernel - -type rule_set = {rule_patt : pattern; replacements : guarded_replacement list} - -and guarded_replacement = { - type_constraint : type_constraint; - replacement : replacement list; -} - -and type_constraint = - | No_cnstrnt - | Data_cnstrnt of {cnstrnt : Type.Base.t; fresh : int list} - | Instr_cnstrnt of { - cnstrnt : Inference.transformer; - fresh : var list; - fresh_stack : int list; - } - -and replacement = - | Context_aware of (Mikhailsky.node -> Mikhailsky.node) - | Context_blind of (unit -> Mikhailsky.node) - -and pattern = Pattern of Patt.t | Root - -and var = Plain of int | Cmp of int - -let stack_repr = Inference.Stack_type None - -let base_repr = - Inference.Base_type {repr = None; comparable = Inference.Unconstrained} - -let cmp_repr = - Inference.Base_type {repr = None; comparable = Inference.Comparable} - -let rec add_fresh_stack_variables vars = - let open Inference.M in - match vars with - | [] -> return () - | fresh :: tl -> - uf_lift (Uf.UF.add fresh) >>= fun () -> - set_repr fresh stack_repr >>= fun () -> add_fresh_stack_variables tl - -let rec add_fresh_data_variables vars = - let open Inference.M in - match vars with - | [] -> return () - | fresh :: tl -> - uf_lift (Uf.UF.add fresh) >>= fun () -> - set_repr fresh base_repr >>= fun () -> add_fresh_data_variables tl - -let rec add_fresh_variables vars plain_repr cmp_repr = - let open Inference.M in - match vars with - | [] -> return () - | Plain fresh :: tl -> - uf_lift (Uf.UF.add fresh) >>= fun () -> - set_repr fresh plain_repr >>= fun () -> - add_fresh_variables tl plain_repr cmp_repr - | Cmp fresh :: tl -> - uf_lift (Uf.UF.add fresh) >>= fun () -> - set_repr fresh cmp_repr >>= fun () -> - add_fresh_variables tl plain_repr cmp_repr - -let evaluate_guard_monadic guard path = - let open Inference.M in - match guard with - | No_cnstrnt -> return () - | Data_cnstrnt {cnstrnt = base_type_constraint; fresh} -> ( - add_fresh_data_variables fresh >>= fun () -> - get_data_annot path >>= fun res_opt -> - match res_opt with - | None -> assert false - | Some type_of_expr -> - Inference.unify_base type_of_expr base_type_constraint >>= fun () -> - Inference.instantiate_base type_of_expr >>= fun _ -> return ()) - | Instr_cnstrnt {cnstrnt = {bef = pre; aft = post}; fresh; fresh_stack} -> ( - (* Add base fresh type variables *) - add_fresh_variables fresh base_repr cmp_repr - >>= fun () -> - add_fresh_stack_variables fresh_stack >>= fun () -> - get_instr_annot path >>= fun res_opt -> - match res_opt with - | None -> assert false - | Some {bef; aft} -> - Inference.unify pre bef >>= fun () -> - Inference.unify post aft >>= fun () -> - Inference.instantiate bef >>= fun _bef -> - Inference.instantiate aft >>= fun _aft -> return ()) - -let evaluate_guard typing guard path = - try - let _ = evaluate_guard_monadic guard path typing in - true - with Inference.Ill_typed_script _ -> false - -let filter_matches typing guard matches = - List.filter (evaluate_guard typing guard) matches - -(* Provides a speedup but should better be done in the - rewriting module (so that not only top matches are hash-consed). *) -let matches_with_hash_consing = - let match_table : (int * int, Kernel.Path.t list) Hashtbl.t = - Hashtbl.create 97 - in - fun pattern term -> - match pattern with - | Root -> [Path.root] - | Pattern patt -> ( - let key = (Kernel.Patt.uid patt, Mikhailsky.tag term) in - match Hashtbl.find_opt match_table key with - | None -> - let res = Rewriter.all_matches patt term in - Hashtbl.add match_table key res ; - res - | Some res -> res) - -let matches_without_consing pattern term = - match pattern with - | Root -> [Path.root] - | Pattern patt -> Rewriter.all_matches patt term - -let rewriting (state : State_space.t) (rules : rule_set list) = - List.fold_left - (fun acc rule -> - let matches = matches_without_consing rule.rule_patt state.term in - List.fold_left - (fun acc guarded_replacement -> - let matches = - filter_matches - (Lazy.force state.typing) - guarded_replacement.type_constraint - matches - in - List.fold_left - (fun acc replacement -> - match replacement with - | Context_blind term -> - List.fold_left - (fun acc path -> (path, term ()) :: acc) - acc - matches - | Context_aware f -> - List.fold_left - (fun acc path -> - let term = Rewriter.get_subterm ~term:state.term ~path in - (path, f term) :: acc) - acc - matches) - acc - guarded_replacement.replacement) - acc - rule.replacements) - [] - rules - -module Instruction = struct - (* ----------------------------------------------------------------------- *) - (* Rule: replace instruction by hole. *) - - (* Matches instructions *) - let match_any_instr = - let open Patt in - Pattern - (focus - (prim_pred - (fun prim -> Mikhailsky_prim.kind prim = Mikhailsky_prim.Instr_kind) - list_any)) - - let replace_any_instr_by_hole = - let replace_by_hole = - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.instr_hole)]; - } - in - {rule_patt = match_any_instr; replacements = [replace_by_hole]} - - (* ----------------------------------------------------------------------- *) - (* Rule: replace instruction hole by instruction satisfying typing - constraints. *) - - (* Matches instruction holes *) - let match_instr_hole = - let open Patt in - Pattern (focus (prim I_Hole list_any)) - - let replacement ?(fresh = []) ?(fresh_stack = []) ~bef ~aft ~replacement () : - guarded_replacement = - { - type_constraint = Instr_cnstrnt {cnstrnt = {bef; aft}; fresh; fresh_stack}; - replacement; - } - - let instructions = - let open Type in - let module M = Mikhailsky in - let module I = Inference in - let alpha = ~-1 in - let beta = ~-2 in - let gamma = ~-3 in - let delta = ~-4 in - [ - replacement - ~fresh_stack:[alpha] - ~bef:(item bytes (stack_var alpha)) - ~aft:(item bytes (stack_var alpha)) - ~replacement: - [ - Context_blind (fun () -> M.Instructions.blake2b); - Context_blind (fun () -> M.Instructions.sha256); - Context_blind (fun () -> M.Instructions.sha512); - ] - (); - replacement - ~fresh_stack:[alpha] - ~bef:(item int (stack_var alpha)) - ~aft:(item bool (stack_var alpha)) - ~replacement:[Context_blind (fun () -> M.Instructions.gt)] - (); - replacement - ~fresh_stack:[alpha] - ~bef:(item int (stack_var alpha)) - ~aft:(item nat (stack_var alpha)) - ~replacement:[Context_blind (fun () -> M.Instructions.abs)] - (); - replacement - ~fresh_stack:[alpha] - ~bef:(item int (item int (stack_var alpha))) - ~aft:(item int (stack_var alpha)) - ~replacement: - [ - Context_blind (fun () -> M.Instructions.add M.int_ty M.int_ty); - Context_blind (fun () -> M.Instructions.mul M.int_ty M.int_ty); - ] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (pair (var alpha) (var beta)) (stack_var gamma)) - ~aft:(item (var alpha) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.car)] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (pair (var alpha) (var beta)) (stack_var gamma)) - ~aft:(item (var beta) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.cdr)] - (); - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (item (var alpha) (stack_var gamma))) - ~aft:(item int (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.compare)] - (); - replacement - ~fresh_stack:[gamma] - ~bef:(item string (item string (stack_var gamma))) - ~aft:(item string (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.concat)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[beta; gamma] - ~bef:(item (var alpha) (stack_var beta)) - ~aft:(item (var alpha) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.(dip hole))] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[beta] - ~bef:(item (var alpha) (stack_var beta)) - ~aft:(stack_var beta) - ~replacement:[Context_blind (fun () -> M.Instructions.drop)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[beta] - ~bef:(item (var alpha) (stack_var beta)) - ~aft:(item (var alpha) (item (var alpha) (stack_var beta))) - ~replacement:[Context_blind (fun () -> M.Instructions.dup)] - (); - replacement - ~fresh:[] - ~fresh_stack:[alpha] - ~bef:(stack_var alpha) - ~aft:(item int (stack_var alpha)) - ~replacement: - [ - (* TODO : push random integer? *) - Context_blind - (fun () -> M.Instructions.push M.int_ty (M.Data.integer 100)); - ] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (item (var beta) (stack_var gamma))) - ~aft:(item (var beta) (item (var alpha) (stack_var gamma))) - ~replacement:[Context_blind (fun () -> M.Instructions.swap)] - (); - (* control *) - replacement - ~fresh_stack:[alpha] - ~bef:(item bool (stack_var alpha)) - ~aft:(stack_var alpha) - ~replacement:[Context_blind (fun () -> M.Instructions.(loop hole))] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (or_ (var alpha) (var beta)) (stack_var gamma)) - ~aft:(item (var beta) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.(loop_left hole))] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[beta; gamma] - ~bef:(item (option (var alpha)) (stack_var beta)) - ~aft:(stack_var gamma) - ~replacement: - [Context_blind (fun () -> M.Instructions.(if_none hole hole))] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma; delta] - ~bef:(item (or_ (var alpha) (var beta)) (stack_var gamma)) - ~aft:(stack_var delta) - ~replacement: - [Context_blind (fun () -> M.Instructions.(if_left hole hole))] - (); - replacement - ~fresh:[] - ~fresh_stack:[alpha; beta] - ~bef:(item bool (stack_var alpha)) - ~aft:(stack_var beta) - ~replacement:[Context_blind (fun () -> M.Instructions.(if_ hole hole))] - (); - replacement - ~fresh_stack:[alpha; beta] - ~bef:(stack_var alpha) - ~aft:(stack_var beta) - ~replacement: - [ - Context_blind - (fun () -> M.seq [M.Instructions.hole; M.Instructions.hole]); - ] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (stack_var gamma)) - ~aft:(item (or_ (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.left)] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (var beta) (stack_var gamma)) - ~aft:(item (or_ (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.right)] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(stack_var gamma) - ~aft:(item (lambda (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.(lambda [hole]))] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(stack_var gamma) - ~aft:(item (lambda (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.(lambda [hole]))] - (); - (* set/map/list*) - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef: - (item - (var alpha) - (item bool (item (set (var alpha)) (stack_var gamma)))) - ~aft:(item (set (var alpha)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.update_set)] - (); - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef:(stack_var gamma) - ~aft:(item (set (var alpha)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.empty_set)] - (); - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef:(item (set (var alpha)) (stack_var gamma)) - ~aft:(stack_var gamma) - ~replacement: - [Context_blind (fun () -> M.Instructions.(iter_set [hole]))] - (); - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (item (set (var alpha)) (stack_var gamma))) - ~aft:(item bool (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.mem_set)] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef: - (item - (var alpha) - (item - (option (var beta)) - (item (map (var alpha) (var beta)) (stack_var gamma)))) - ~aft:(item (map (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.update_map)] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(stack_var gamma) - ~aft:(item (map (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.empty_map)] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (map (var alpha) (var beta)) (stack_var gamma)) - ~aft:(stack_var gamma) - ~replacement: - [Context_blind (fun () -> M.Instructions.(iter_map [hole]))] - (); - replacement - ~fresh:[Cmp alpha; Plain beta; Plain delta] - ~fresh_stack:[gamma] - ~bef:(item (map (var alpha) (var beta)) (stack_var gamma)) - ~aft:(item (map (var alpha) (var delta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.(map_map [hole]))] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef: - (item - (var alpha) - (item (map (var alpha) (var beta)) (stack_var gamma))) - ~aft:(item bool (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.mem_map)] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef: - (item - (var alpha) - (item (map (var alpha) (var beta)) (stack_var gamma))) - ~aft:(item (option (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.get_map)] - (); - (* lists *) - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(stack_var gamma) - ~aft:(item (list (var alpha)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.nil)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (item (list (var alpha)) (stack_var gamma))) - ~aft:(item (list (var alpha)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.cons)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(item (list (var alpha)) (stack_var gamma)) - ~aft:(stack_var gamma) - ~replacement: - [Context_blind (fun () -> M.Instructions.(iter_list [hole]))] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (list (var alpha)) (stack_var gamma)) - ~aft:(item (list (var beta)) (stack_var gamma)) - ~replacement: - [Context_blind (fun () -> M.Instructions.(map_list [hole]))] - (); - (* sizes *) - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef:(item (set (var alpha)) (stack_var gamma)) - ~aft:(item nat (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.size_set)] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (map (var alpha) (var beta)) (stack_var gamma)) - ~aft:(item nat (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.size_map)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(item (list (var alpha)) (stack_var gamma)) - ~aft:(item nat (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.size_list)] - (); - replacement - ~fresh:[] - ~fresh_stack:[gamma] - ~bef:(item string (stack_var gamma)) - ~aft:(item nat (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.size_string)] - (); - replacement - ~fresh:[] - ~fresh_stack:[gamma] - ~bef:(item bytes (stack_var gamma)) - ~aft:(item nat (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.size_bytes)] - (); - (* pack/unpack *) - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (stack_var gamma)) - ~aft:(item bytes (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.pack)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(item bytes (stack_var gamma)) - ~aft:(item (option (var alpha)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.unpack)] - (); - ] - - let rules = - [ - replace_any_instr_by_hole; - {rule_patt = match_instr_hole; replacements = instructions}; - ] -end - -module Data_rewrite_leaves - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) = -struct - let hole_patt = - let open Patt in - prim_pred (fun prim -> prim = D_Hole) list_empty - - (* Matches a data hole *) - let match_hole = - let open Patt in - Pattern (focus hole_patt) - - (* Matches an integer literal *) - let match_int = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Int) list_any)) - - (* Matches a list literal *) - let match_list = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_List) list_any)) - - (* Matches a set literal *) - let match_set = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Set) list_any)) - - (* Matches a map literal *) - let match_map = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Map) list_any)) - - (* Matches a timestamp literal *) - let match_timestamp = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Timestamp) list_any)) - - (* Matches a mutez literal *) - let match_mutez = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Mutez) list_any)) - - (* Matches a key_hash literal *) - let match_key_hash = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Key_hash) list_any)) - - let match_int_mutez_timestamp_key_hash_key_or_none = - let open Patt in - Pattern - (focus - (prim_pred - (function - | A_Int | A_Nat | A_Mutez | A_Timestamp | A_Key_hash | A_Key - | D_None -> - true - | _ -> false) - list_any)) - - (* Matches an empty list, set or map literal *) - let match_empty_list_set_or_map = - let open Patt in - Pattern - (focus - (prim_pred - (function A_List | A_Set | A_Map -> true | _ -> false) - (list_cons (seq list_empty) list_empty))) - - (* Matches a pair containing two holes*) - let match_empty_pair = - let open Patt in - Pattern - (focus - (prim_pred - (fun prim -> prim = D_Pair) - (list_cons hole_patt (list_cons hole_patt list_empty)))) - - (* Match a Some, Left or Right containing a hole *) - let match_empty_some_left_or_right = - let open Patt in - Pattern - (focus - (prim_pred - (function D_Left | D_Right | D_Some -> true | _ -> false) - (list_cons hole_patt list_empty))) - - (* Match a None constructor *) - let match_none = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = D_None) list_empty)) - - (* rules *) - - (* fresh type variables *) - let alpha, beta = (-1, -2) - - let replacement ~fresh ~typ ~replacement = - { - type_constraint = Data_cnstrnt {cnstrnt = typ; fresh}; - replacement = [Context_blind (fun () -> replacement)]; - } - - let replacement_gen ~fresh ~typ ~replacement = - { - type_constraint = Data_cnstrnt {cnstrnt = typ; fresh}; - replacement = [Context_blind replacement]; - } - - let fill_in_hole rng_state = - let replace_by_singleton_list = - replacement - ~fresh:[alpha] - ~typ:Type.(list (var alpha)) - ~replacement:Mikhailsky.Data.(list [hole]) - in - let replace_by_empty_pair = - replacement - ~fresh:[alpha; beta] - ~typ:Type.(pair (var alpha) (var beta)) - ~replacement:Mikhailsky.Data.(pair hole hole) - in - let replace_by_singleton_set = - replacement - ~fresh:[alpha] - ~typ:Type.(set (var alpha)) - ~replacement:Mikhailsky.Data.(set [hole]) - in - let replace_by_singleton_map = - replacement - ~fresh:[alpha; beta] - ~typ:Type.(map (var alpha) (var beta)) - ~replacement:Mikhailsky.Data.(map [map_elt hole hole]) - in - let replace_by_random_int rng_state = - let type_constraint = Data_cnstrnt {cnstrnt = Type.int; fresh = []} in - let replacement = - Context_blind - (fun () -> - Mikhailsky.Data.big_integer - (Protocol.Script_int.to_zint (Michelson_base.int rng_state))) - in - {type_constraint; replacement = [replacement]} - in - let replace_by_left = - replacement - ~fresh:[alpha; beta] - ~typ:Type.(or_ (var alpha) (var beta)) - ~replacement:Mikhailsky.Data.(left hole) - in - let replace_by_right = - replacement - ~fresh:[alpha; beta] - ~typ:Type.(or_ (var alpha) (var beta)) - ~replacement:Mikhailsky.Data.(right hole) - in - let replace_by_some = - replacement - ~fresh:[alpha] - ~typ:Type.(option (var alpha)) - ~replacement:Mikhailsky.Data.(some hole) - in - let replace_by_none = - replacement - ~fresh:[alpha] - ~typ:Type.(option (var alpha)) - ~replacement:Mikhailsky.Data.none - in - let replace_by_mutez rng_state = - replacement_gen ~fresh:[] ~typ:Type.mutez ~replacement:(fun () -> - Mikhailsky.Data.mutez (Michelson_base.tez rng_state)) - in - let replace_by_key_hash rng_state = - replacement_gen ~fresh:[] ~typ:Type.key_hash ~replacement:(fun () -> - Mikhailsky.Data.key_hash (Crypto_samplers.pkh rng_state)) - in - let replace_by_key rng_state = - replacement_gen ~fresh:[] ~typ:Type.key ~replacement:(fun () -> - Mikhailsky.Data.key (Crypto_samplers.pk rng_state)) - in - { - rule_patt = match_hole; - replacements = - [ - replace_by_singleton_list; - replace_by_empty_pair; - replace_by_singleton_set; - replace_by_singleton_map; - replace_by_random_int rng_state; - replace_by_left; - replace_by_right; - replace_by_some; - replace_by_none; - replace_by_mutez rng_state; - replace_by_key_hash rng_state; - replace_by_key rng_state; - ]; - } - - let kill_empty_pair = - { - rule_patt = match_empty_pair; - replacements = - [ - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.Data.hole)]; - }; - ]; - } - - let kill_int_mutez_timestamp_key_hash_none = - { - rule_patt = match_int_mutez_timestamp_key_hash_key_or_none; - replacements = - [ - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.Data.hole)]; - }; - ]; - } - - let kill_empty_list_set_or_map = - { - rule_patt = match_empty_list_set_or_map; - replacements = - [ - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.Data.hole)]; - }; - ]; - } - - let kill_empty_some_left_or_right = - { - rule_patt = match_empty_some_left_or_right; - replacements = - [ - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.Data.hole)]; - }; - ]; - } - - let modify_set = - let grow_ungrow_set = - { - type_constraint = No_cnstrnt; - replacement = - [ - Context_aware - (fun set -> - match set with - | Micheline.Prim (_, A_Set, [Micheline.Seq (_, elements)], _) -> - Mikhailsky.Data.(set (hole :: elements)) - | _ -> assert false); - Context_aware - (fun set -> - match set with - | Micheline.Prim (_, A_Set, [Micheline.Seq (_, elements)], _) - -> ( - match elements with - | [] -> Mikhailsky.Data.hole - | _ :: tl -> Mikhailsky.Data.set tl) - | _ -> assert false); - ]; - } - in - {rule_patt = match_set; replacements = [grow_ungrow_set]} - - let modify_map = - let grow_ungrow_map = - { - type_constraint = No_cnstrnt; - replacement = - [ - Context_aware - (fun set -> - match set with - | Micheline.Prim (_, A_Map, [Micheline.Seq (_, elements)], _) -> - Mikhailsky.Data.(map (map_elt hole hole :: elements)) - | _ -> assert false); - Context_aware - (fun set -> - match set with - | Micheline.Prim (_, A_Map, [Micheline.Seq (_, elements)], _) - -> ( - match elements with - | [] -> Mikhailsky.Data.hole - | _ :: tl -> Mikhailsky.Data.map tl) - | _ -> assert false); - ]; - } - in - {rule_patt = match_map; replacements = [grow_ungrow_map]} - - let modify_list = - let grow_ungrow_list = - { - type_constraint = No_cnstrnt; - replacement = - [ - Context_aware - (fun list -> - match list with - | Micheline.Prim (_, A_List, [Micheline.Seq (_, terms)], _) -> - Mikhailsky.Data.(list (hole :: terms)) - | _ -> assert false); - Context_aware - (fun list -> - match list with - | Micheline.Prim (_, A_List, [Micheline.Seq (_, terms)], _) -> ( - match terms with - | [] -> Mikhailsky.Data.hole - | _ :: tl -> Mikhailsky.Data.list tl) - | _ -> assert false); - ]; - } - in - {rule_patt = match_list; replacements = [grow_ungrow_list]} - - let rules rng_state = - [ - fill_in_hole rng_state; - kill_empty_pair; - kill_empty_list_set_or_map; - kill_empty_some_left_or_right; - kill_int_mutez_timestamp_key_hash_none; - modify_list; - modify_set; - modify_map; - ] -end - -module Data - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) = -struct - let match_data_node = - let open Patt in - Pattern - (focus - (prim_pred - (function - | Mikhailsky_prim.D_Elt | D_Hole -> false - | D_False | D_Left | D_None | D_Pair | D_Right | D_Some | D_True - | D_Unit | A_Int | A_Nat | A_Set | A_List | A_Map | A_Key_hash - | A_Mutez | A_Timestamp | A_Key -> - true - | _ -> false) - list_any)) - - let match_list = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_List) list_any)) - - let match_data_hole = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = D_Hole) list_any)) - - let replace_by_hole = - let replace_by_hole = - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.Data.hole)]; - } - in - {rule_patt = match_data_node; replacements = [replace_by_hole]} - - let pack_root = - let replacement = - [ - Context_aware (fun node -> Mikhailsky.Data.list [node]); - Context_aware (fun node -> Mikhailsky.Data.(pair node hole)); - Context_aware (fun node -> Mikhailsky.Data.(pair hole node)); - ] - in - let guarded_replacements = [{type_constraint = No_cnstrnt; replacement}] in - {rule_patt = Root; replacements = guarded_replacements} - - module Data_rewrite_leaves_rules = - Data_rewrite_leaves (Michelson_base) (Crypto_samplers) - - let rules rng_state = - [ - Data_rewrite_leaves_rules.fill_in_hole rng_state; - replace_by_hole; - Data_rewrite_leaves_rules.modify_list; - Data_rewrite_leaves_rules.modify_map; - Data_rewrite_leaves_rules.modify_set; - ] -end diff --git a/src/proto_020_PsParisC/lib_benchmark/sampling_helpers.ml b/src/proto_020_PsParisC/lib_benchmark/sampling_helpers.ml deleted file mode 100644 index b371a6aa1e1e..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/sampling_helpers.ml +++ /dev/null @@ -1,41 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(* ------------------------------------------------------------------------- *) - -(* TODO: use Statz's def. of sampler once upstreamed. *) -type 'a sampler = Random.State.t -> 'a - -module M = struct - let ( let* ) : 'a sampler -> ('a -> 'b sampler) -> 'b sampler = - fun sampler f rng_state -> - let x = sampler rng_state in - f x rng_state - [@@inline] - - let bind = ( let* ) - - let return x _ = x -end diff --git a/src/proto_020_PsParisC/lib_benchmark/state_space.ml b/src/proto_020_PsParisC/lib_benchmark/state_space.ml deleted file mode 100644 index 60d14970e610..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/state_space.ml +++ /dev/null @@ -1,78 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 state of rewriting is a typed term *) -type t = {typing : Inference.state lazy_t; term : Mikhailsky.node} - -let compare (term1 : t) (term2 : t) = - let tag1 = Mikhailsky.tag term1.term in - let tag2 = Mikhailsky.tag term2.term in - if tag1 < tag2 then -1 else if tag1 > tag2 then 1 else 0 - -let equal (term1 : t) (term2 : t) = - let tag1 = Mikhailsky.tag term1.term in - let tag2 = Mikhailsky.tag term2.term in - tag1 = tag2 - -let hash (t : t) = Mikhailsky.hash t.term - -type node_statistics = { - mutable size : int; - mutable bytes : int; - mutable holes : int; - mutable depth : int; -} - -let pp_statistics fmtr stats = - Format.fprintf - fmtr - "{ size = %d ; bytes = %d ; holes = %d }" - stats.size - stats.bytes - stats.holes - -let rec statistics stats depth (n : Mikhailsky.node) = - stats.size <- stats.size + 1 ; - stats.depth <- max depth stats.depth ; - match n with - | Micheline.Int (_, z) -> stats.bytes <- stats.bytes + (Z.numbits z / 8) - | Micheline.String (_, s) -> stats.bytes <- stats.bytes + String.length s - | Micheline.Bytes (_, b) -> stats.bytes <- stats.bytes + Bytes.length b - | Micheline.Prim (_, Mikhailsky_prim.I_Hole, _, _) - | Micheline.Prim (_, Mikhailsky_prim.D_Hole, _, _) -> - stats.holes <- stats.holes + 1 - | Micheline.Prim (_, _, subterms, _) | Micheline.Seq (_, subterms) -> - List.iter (statistics stats (depth + 1)) subterms - -let statistics {term; _} = - let stats = {size = 0; bytes = 0; holes = 0; depth = 0} in - statistics stats 0 term ; - stats - -let pp fmtr (state : t) = - Format.fprintf fmtr "current term:@." ; - Format.fprintf fmtr "%a@." Mikhailsky.pp state.term ; - Format.fprintf fmtr "stats:@." ; - Format.fprintf fmtr "%a:@." pp_statistics (statistics state) diff --git a/src/proto_020_PsParisC/lib_benchmark/type_helpers.ml b/src/proto_020_PsParisC/lib_benchmark/type_helpers.ml deleted file mode 100644 index 989ee7782901..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/type_helpers.ml +++ /dev/null @@ -1,88 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 conversion helpers *) - -open Protocol - -exception Type_helpers_error of string - -let helpers_error msg = raise (Type_helpers_error msg) - -(* Convert a Micheline-encoded type to its internal GADT format. *) -let michelson_type_to_ex_ty (typ : Alpha_context.Script.expr) - (ctxt : Alpha_context.t) = - Script_ir_translator.parse_ty - ctxt - ~legacy:false - ~allow_lazy_storage:false - ~allow_operation:false - ~allow_contract:false - ~allow_ticket:false - (Micheline.root typ) - |> Environment.wrap_tzresult - |> function - | Ok (ex_ty, _ctxt) -> ex_ty - | Error errs -> - let msg = - Format.asprintf - "Michelson_generation.michelson_type_to_ex_ty (%a)" - Error_monad.pp_print_trace - errs - in - helpers_error msg - -(* Convert a list of Micheline-encoded Michelson types to the - internal GADT format. *) -let rec michelson_type_list_to_ex_stack_ty - (stack_ty : Alpha_context.Script.expr list) ctxt = - let open Script_ir_translator in - let open Script_typed_ir in - match stack_ty with - | [] -> Ex_stack_ty Bot_t - | hd :: tl -> ( - let ex_ty = michelson_type_to_ex_ty hd ctxt in - match ex_ty with - | Ex_ty ty -> ( - let ex_stack_ty = michelson_type_list_to_ex_stack_ty tl ctxt in - match ex_stack_ty with - | Ex_stack_ty tl -> Ex_stack_ty (Item_t (ty, tl)))) - -let base_type_to_michelson_type (typ : Type.Base.t) = - let typ = Mikhailsky.map_var (fun _ -> Mikhailsky.unit_ty) typ in - Mikhailsky.to_michelson typ - -(* Convert a Mikhailsky stack to a list of Micheline-encoded types *) -let rec stack_type_to_michelson_type_list (typ : Type.Stack.t) = - let node = typ.node in - match node with - | Type.Stack.Stack_var_t _ -> - helpers_error "stack_type_to_michelson_type_list: bug found" - | Type.Stack.Empty_t -> [] - | Type.Stack.Item_t (ty, tl) -> - base_type_to_michelson_type ty :: stack_type_to_michelson_type_list tl - -let base_type_to_ex_ty ty = - michelson_type_to_ex_ty (base_type_to_michelson_type ty) diff --git a/src/proto_020_PsParisC/lib_benchmark/type_helpers.mli b/src/proto_020_PsParisC/lib_benchmark/type_helpers.mli deleted file mode 100644 index 0cf310d3afcf..000000000000 --- a/src/proto_020_PsParisC/lib_benchmark/type_helpers.mli +++ /dev/null @@ -1,57 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 conversion helpers *) - -open Protocol - -(** Exception raised in case an error occurs in this module. *) -exception Type_helpers_error of string - -(** [michelson_type_list_to_ex_stack_ty] converts a list of types in - Micheline form to a stack type in IR form. - - @raise Type_helpers_error if parsing the Michelson type fails. - *) -val michelson_type_list_to_ex_stack_ty : - Alpha_context.Script.expr list -> - Alpha_context.t -> - Script_ir_translator.ex_stack_ty - -(** [michelson_type_to_ex_ty ty ctxt] parses the type [ty]. - - @raise Type_helpers_error if an error arises during parsing. *) -val michelson_type_to_ex_ty : - Alpha_context.Script.expr -> Alpha_context.t -> Script_typed_ir.ex_ty - -(** [stack_type_to_michelson_type_list] converts a Mikhailsky stack type - to a stack represented as a list of Micheline expressions, each - element denoting a type on the stack type. - - @raise Type_helpers_error if the stack type contains variables. *) -val stack_type_to_michelson_type_list : Type.Stack.t -> Script_repr.expr list - -(** [base_type_to_ex_ty] converts a Mikhailsky type to a Michelson one. *) -val base_type_to_ex_ty : Type.Base.t -> Alpha_context.t -> Script_typed_ir.ex_ty diff --git a/src/proto_020_PsParisC/lib_dal/RPC_directory.ml b/src/proto_020_PsParisC/lib_dal/RPC_directory.ml deleted file mode 100644 index 291f6b08e925..000000000000 --- a/src/proto_020_PsParisC/lib_dal/RPC_directory.ml +++ /dev/null @@ -1,40 +0,0 @@ -(*****************************************************************************) -(* *) -(* SPDX-License-Identifier: MIT *) -(* SPDX-FileCopyrightText: 2024 Functori, *) -(* SPDX-FileCopyrightText: 2024 Nomadic Labs, *) -(* *) -(*****************************************************************************) - -module Dal_proto_services = Dal_services -open Protocol - -module Skip_list_handlers = struct - let cell (rpc_context, cell_hash) () () = - let open Lwt_result_syntax in - let hash = - Dal_proto_types.Skip_list_hash.of_proto - Alpha_context.Dal.Slots_history.Pointer_hash.encoding - cell_hash - in - let* cell = Dal_store_sqlite3.Skip_list_cells.find rpc_context hash in - return - @@ Dal_proto_types.Skip_list_cell.to_proto - Alpha_context.Dal.Slots_history.encoding - cell -end - -let add_service registerer subst service handler directory = - registerer directory (subst service) handler - -let register_commitments_history ctxt directory = - directory - |> add_service - Tezos_rpc.Directory.register - Tezos_rpc.Service.subst1 - Dal_proto_services.Commitments_history.hash_content - Skip_list_handlers.cell - |> Tezos_rpc.Directory.map (fun _prefix -> Lwt.return ctxt) - -let directory rpc_ctxt = - register_commitments_history rpc_ctxt Tezos_rpc.Directory.empty diff --git a/src/proto_020_PsParisC/lib_dal/RPC_directory.mli b/src/proto_020_PsParisC/lib_dal/RPC_directory.mli deleted file mode 100644 index 5cec068fc5ff..000000000000 --- a/src/proto_020_PsParisC/lib_dal/RPC_directory.mli +++ /dev/null @@ -1,11 +0,0 @@ -(*****************************************************************************) -(* *) -(* SPDX-License-Identifier: MIT *) -(* SPDX-FileCopyrightText: 2024 Functori, *) -(* SPDX-FileCopyrightText: 2024 Nomadic Labs, *) -(* *) -(*****************************************************************************) - -(** The RPCs directory of the protocol part of DAL nodes. *) -val directory : - Dal_store_sqlite3.Skip_list_cells.t -> unit Environment.RPC_directory.t diff --git a/src/proto_020_PsParisC/lib_dal/dal_plugin_registration.ml b/src/proto_020_PsParisC/lib_dal/dal_plugin_registration.ml deleted file mode 100644 index 03fbc81402ee..000000000000 --- a/src/proto_020_PsParisC/lib_dal/dal_plugin_registration.ml +++ /dev/null @@ -1,365 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 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 Protocol -open Alpha_context - -let wrap = Environment.wrap_tzresult - -module Plugin = struct - module Proto = Registerer.Registered - - type block_info = Protocol_client_context.Alpha_block_services.block_info - - type dal_attestation = Bitset.t - - type attestation_operation = Kind.attestation Alpha_context.operation - - let parametric_constants chain block ctxt = - let cpctxt = new Protocol_client_context.wrap_rpc_context ctxt in - Protocol.Constants_services.parametric cpctxt (chain, block) - - let get_constants chain block ctxt = - let open Lwt_result_syntax in - let* parametric = parametric_constants chain block ctxt in - let { - Constants.Parametric.feature_enable; - incentives_enable; - number_of_slots; - attestation_lag; - attestation_threshold; - cryptobox_parameters; - } = - parametric.dal - in - return - { - Dal_plugin.feature_enable; - incentives_enable; - number_of_slots; - attestation_lag; - attestation_threshold; - traps_fraction = Q.(1 // 1000); - (* not used in proto_020 *) - cryptobox_parameters; - sc_rollup_challenge_window_in_blocks = - parametric.sc_rollup.challenge_window_in_blocks; - commitment_period_in_blocks = - parametric.sc_rollup.commitment_period_in_blocks; - dal_attested_slots_validity_lag = - parametric.sc_rollup.reveal_activation_level - .dal_attested_slots_validity_lag; - blocks_per_cycle = parametric.blocks_per_cycle; - } - - type error += DAL_accusation_not_available - - let () = - register_error_kind - `Permanent - ~id:"dal_accusation_not_available_paris" - ~title:"DAL accusation not available on Paris" - ~description:"DAL accusation is not available in protocol Paris." - ~pp:(fun fmt () -> - Format.fprintf fmt "DAL accusation is not available in protocol Paris") - Data_encoding.unit - (function DAL_accusation_not_available -> Some () | _ -> None) - (fun () -> DAL_accusation_not_available) - - let inject_entrapment_evidence _cctxt ~attested_level:_ _attestation - ~slot_index:_ ~shard:_ ~proof:_ = - let open Lwt_result_syntax in - (* This is supposed to be dead code, but we implement a fallback to be defensive. *) - fail [DAL_accusation_not_available] - - let block_info ?chain ?block ~metadata ctxt = - let cpctxt = new Protocol_client_context.wrap_rpc_context ctxt in - Protocol_client_context.Alpha_block_services.info - cpctxt - ?chain - ?block - ~metadata - () - - let block_shell_header (block_info : block_info) = block_info.header.shell - - let get_round fitness = - let open Result_syntax in - let* round = Fitness.round_from_raw fitness |> wrap in - return @@ Round.to_int32 round - - (* Turn the given value of type {!Protocol.Apply_operation_result.operation_result} - into a value of type {!Dal_plugin.operation_application_result}. *) - let status_of_result = function - | Protocol.Apply_operation_result.Applied _ -> Dal_plugin.Succeeded - | _ -> Dal_plugin.Failed - - let get_published_slot_headers (block : block_info) = - let open Lwt_result_syntax in - let open Protocol.Alpha_context in - let apply_internal acc ~source:_ _op _res = acc in - let apply (type kind) acc ~source:_ (op : kind manager_operation) - (result : (kind, _, _) Protocol.Apply_operation_result.operation_result) - = - match op with - | Dal_publish_commitment operation -> - (operation.slot_index, operation.commitment, status_of_result result) - :: acc - | _ -> acc - in - Layer1_services.( - process_manager_operations [] block.operations {apply; apply_internal}) - |> List.map_es (fun (slot_index, commitment, status) -> - let published_level = block.header.shell.level in - let slot_index = Dal.Slot_index.to_int slot_index in - return Dal_plugin.({published_level; slot_index; commitment}, status)) - - let get_attestations block_info = - let open Protocol.Alpha_context in - let open Protocol_client_context.Alpha_block_services in - match block_info.operations with - | [consensus_ops; _anonymous; _votes; _managers] -> - List.filter_map - (fun operation -> - let (Operation_data operation_data) = operation.protocol_data in - match operation_data.contents with - | Single (Attestation attestation) -> ( - let packed_operation : Kind.attestation Alpha_context.operation - = - { - Alpha_context.shell = operation.shell; - protocol_data = operation_data; - } - in - let tb_slot = Slot.to_int attestation.consensus_content.slot in - let dal_attestation : dal_attestation option = - Option.map - (fun x -> (x.attestation :> dal_attestation)) - attestation.dal_content - in - match operation.receipt with - | Receipt (Operation_metadata operation_metadata) -> ( - match operation_metadata.contents with - | Single_result (Attestation_result result) -> - Some - ( tb_slot, - Some result.delegate, - packed_operation, - dal_attestation ) - | _ -> - Some (tb_slot, None, packed_operation, dal_attestation)) - | Empty | Too_large | Receipt No_operation_metadata -> - Some (tb_slot, None, packed_operation, dal_attestation)) - | _ -> None) - consensus_ops - | _ -> - (* that should be unreachable, as there are 4 operation passes *) - [] - - let get_committee ctxt ~level = - let open Lwt_result_syntax in - let cpctxt = new Protocol_client_context.wrap_rpc_context ctxt in - let*? level = Raw_level.of_int32 level |> wrap in - let+ pkh_to_shards = - Plugin.RPC.Dal.dal_shards cpctxt (`Main, `Head 0) ~level () - in - List.fold_left - (fun acc ({delegate; indexes} : Plugin.RPC.Dal.S.shards_assignment) -> - Signature.Public_key_hash.Map.add delegate indexes acc) - Signature.Public_key_hash.Map.empty - pkh_to_shards - - let dal_attestation (block : block_info) = - let open Result_syntax in - let* metadata = - Option.to_result - block.metadata - ~none: - (TzTrace.make @@ Layer1_services.Cannot_read_block_metadata block.hash) - in - return (metadata.protocol_data.dal_attestation :> Bitset.t) - - let is_attested attestation slot_index = - match Bitset.mem attestation slot_index with Ok b -> b | Error _ -> false - - let is_delegate _ctxt ~pkh:_ = - failwith "Plugin.ParisC.is_delegate is not available" - - (* Section of helpers for Skip lists *) - - module Skip_list = struct - type cell = Dal.Slots_history.t - - type hash = Dal.Slots_history.Pointer_hash.t - - let cell_encoding = Dal.Slots_history.encoding - - let hash_encoding = Dal.Slots_history.Pointer_hash.encoding - - let cell_equal = Dal.Slots_history.equal - - let hash_equal = Dal.Slots_history.Pointer_hash.equal - - let cell_hash = Dal.Slots_history.hash - - (* - This function mimics what the protocol does in - {!Dal_slot_storage.finalize_pending_slot_headers}. Given a block_info at - some level L, an RPC context, the DAL constants for level L, and for level - L - attestation_lag - 1, the this function computes the cells produced by the - DAL skip list during the level L using: - - - The information telling which slot headers were waiting for attestation - at level [L - attestation_lag]; - - - The bitset of attested slots at level [L] in the block's metadata. - - It is assumed that at level L the DAL is enabled. - - The ordering of the elements in the returned list is not relevant. - *) - let cells_of_level (block_info : block_info) ctxt ~dal_constants - ~pred_publication_level_dal_constants = - let open Lwt_result_syntax in - (* 0. Let's call [attested_level] the block's level. *) - let attested_level = block_info.header.shell.level in - let published_level = - Int32.sub - attested_level - (Int32.of_int dal_constants.Dal_plugin.attestation_lag) - in - (* 1. There are no cells for [published_level = 0]. *) - if published_level <= 0l then return [] - else - let* feature_enable, prev_number_of_slots = - if published_level = 1l then - (* For this level, cannot retrieve the constants (as [pred - publication_level = 0]), but dummy values will suffice. *) - return (false, 0) - else - let* prev_constants = - Lazy.force pred_publication_level_dal_constants - in - return - ( prev_constants.Dal_plugin.feature_enable, - prev_constants.number_of_slots ) - in - let cpctxt = new Protocol_client_context.wrap_rpc_context ctxt in - (* 2. We retrieve the last cell of the DAL skip list from the context, - if any. It's the one stored in the context at [attested_level - - 1]. If no cell is stored yet, we return the genesis cell. *) - let* previous_cell = - let* previous_cell_opt = - (* Should not be negative as [attestation_lag > 0]. *) - let prev_level = Int32.pred attested_level in - Plugin.RPC.Dal.dal_commitments_history - cpctxt - (`Main, `Level prev_level) - in - return - @@ Option.value previous_cell_opt ~default:Dal.Slots_history.genesis - in - let* attested_slot_headers = - if not feature_enable then - (* There are no published headers, because the DAL was not enabled, - and therefore there are no attested headers. *) - return [] - else - (* 3. We retrieve the slot headers published at level [level - - attestation_lag] from the context. *) - let* published_slot_headers = - if published_level = 1l then return [] - else - Plugin.RPC.Dal.dal_published_slot_headers - cpctxt - (`Main, `Level published_level) - () - in - (* 4. We retrieve the bitset of attested slots at level [level]. *) - let* attested_slots = - let*? metadata = - Option.to_result - block_info.metadata - ~none: - (TzTrace.make - @@ Layer1_services.Cannot_read_block_metadata block_info.hash - ) - in - return metadata.protocol_data.dal_attestation - in - let is_slot_attested slot = - Dal.Attestation.is_attested - attested_slots - slot.Dal.Slot.Header.id.index - in - (* 5. We filter the list of slot headers published at [level - - attestation_lag] and keep only those attested at level [level]. *) - let attested_slot_headers, _attested_slots_bitset = - Dal.Slot.compute_attested_slot_headers - ~is_slot_attested - published_slot_headers - in - return attested_slot_headers - in - let*? published_level = - Raw_level.of_int32 published_level |> Environment.wrap_tzresult - in - (* 6. Starting from the [previous_cell], we insert the successive cells - of level [level] in the skip list thanks to function - {!add_confirmed_slot_headers}. The function is fed with an empty - history cache, so the returned [cache] contains exactly the cells - produced for this [level]. *) - let*? _last_cell, cache = - let capacity = - Int64.of_int - @@ max prev_number_of_slots dal_constants.number_of_slots - in - Dal.Slots_history.add_confirmed_slot_headers - previous_cell - (Dal.Slots_history.History_cache.empty ~capacity) - published_level - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997 - - Not resilient to DAL parameters change. *) - ~number_of_slots:dal_constants.number_of_slots - attested_slot_headers - |> Environment.wrap_tzresult - in - (* 7. We finally export and return the cells alongside their hashes as a - list. *) - let last_cells = - let open Dal.Slots_history.History_cache in - view cache |> Map.bindings - in - return last_cells - end - - module RPC = struct - let directory skip_list_cells_store = - RPC_directory.directory skip_list_cells_store - end -end - -let () = Dal_plugin.register (module Plugin) diff --git a/src/proto_020_PsParisC/lib_dal/dal_proto_client.ml b/src/proto_020_PsParisC/lib_dal/dal_proto_client.ml deleted file mode 100644 index 48ab4668bc55..000000000000 --- a/src/proto_020_PsParisC/lib_dal/dal_proto_client.ml +++ /dev/null @@ -1,37 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2024 Functori, *) -(* Copyright (c) 2024 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 cctxt = Dal_node_client.cctxt - -let get_commitments_history_hash_content (cctxt : cctxt) hash = - Dal_node_client.call - cctxt - (Tezos_rpc.Service.prefix - Tezos_rpc.Path.(root / "plugin") - Dal_services.Commitments_history.hash_content) - ((), hash) - () - () diff --git a/src/proto_020_PsParisC/lib_dal/dal_proto_client.mli b/src/proto_020_PsParisC/lib_dal/dal_proto_client.mli deleted file mode 100644 index 96c2cd4ffe42..000000000000 --- a/src/proto_020_PsParisC/lib_dal/dal_proto_client.mli +++ /dev/null @@ -1,30 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2024 Functori, *) -(* Copyright (c) 2024 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. *) -(* *) -(*****************************************************************************) - -val get_commitments_history_hash_content : - Dal_node_client.cctxt -> - Dal_plugin_registration.Plugin.Skip_list.hash -> - Dal_plugin_registration.Plugin.Skip_list.cell tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_dal/dal_services.ml b/src/proto_020_PsParisC/lib_dal/dal_services.ml deleted file mode 100644 index 0fae899bf1ca..000000000000 --- a/src/proto_020_PsParisC/lib_dal/dal_services.ml +++ /dev/null @@ -1,51 +0,0 @@ -(*****************************************************************************) -(* *) -(* SPDX-License-Identifier: MIT *) -(* SPDX-FileCopyrightText: 2024 Functori, *) -(* SPDX-FileCopyrightText: 2024 Nomadic Labs, *) -(* *) -(*****************************************************************************) - -open Protocol.Alpha_context -open Tezos_rpc - -type 'rpc service = - ('meth, 'prefix, 'params, 'query, 'input, 'output) Service.service - constraint - 'rpc = - < meth : 'meth - ; prefix : 'prefix - ; params : 'params - ; query : 'query - ; input : 'input - ; output : 'output > - -module Commitments_history = struct - let cell_hash_arg : Dal.Slots_history.Pointer_hash.t Arg.t = - Arg.make - ~descr:"The hash of a DAL skip list cell" - ~name:"skip_list_cell_hash" - ~construct:Dal.Slots_history.Pointer_hash.to_b58check - ~destruct:(fun h -> - match Dal.Slots_history.Pointer_hash.of_b58check_opt h with - | Some b -> Ok b - | None -> Error "Cannot parse skip list cell hash") - () - - let hash_content : - < meth : [`GET] - ; input : unit - ; output : Dal.Slots_history.t - ; prefix : unit - ; params : unit * Dal.Slots_history.Pointer_hash.t - ; query : unit > - service = - Service.get_service - ~description:"Returns the DAL skip list cell of the given hash" - ~query:Query.empty - ~output:Dal.Slots_history.encoding - Path.( - open_root - / Protocol_hash.to_b58check Protocol.hash - / "commitments_history" / "hash" /: cell_hash_arg) -end diff --git a/src/proto_020_PsParisC/lib_dal/dal_services.mli b/src/proto_020_PsParisC/lib_dal/dal_services.mli deleted file mode 100644 index 61f8ae00466c..000000000000 --- a/src/proto_020_PsParisC/lib_dal/dal_services.mli +++ /dev/null @@ -1,32 +0,0 @@ -(*****************************************************************************) -(* *) -(* SPDX-License-Identifier: MIT *) -(* SPDX-FileCopyrightText: 2024 Functori, *) -(* SPDX-FileCopyrightText: 2024 Nomadic Labs, *) -(* *) -(*****************************************************************************) - -open Protocol.Alpha_context - -type 'rpc service = - ('meth, 'prefix, 'params, 'query, 'input, 'output) Tezos_rpc.Service.service - constraint - 'rpc = - < meth : 'meth - ; prefix : 'prefix - ; params : 'params - ; query : 'query - ; input : 'input - ; output : 'output > - -module Commitments_history : sig - (** Service for returning the skip list cell of the given hash. *) - val hash_content : - < meth : [`GET] - ; input : unit - ; output : Dal.Slots_history.t - ; prefix : unit - ; params : unit * Dal.Slots_history.Pointer_hash.t - ; query : unit > - service -end diff --git a/src/proto_020_PsParisC/lib_dal/dal_slot_frame_encoding.ml b/src/proto_020_PsParisC/lib_dal/dal_slot_frame_encoding.ml deleted file mode 100644 index f89360351623..000000000000 --- a/src/proto_020_PsParisC/lib_dal/dal_slot_frame_encoding.ml +++ /dev/null @@ -1,257 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* 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 -open Protocol_client_context - -type error += - | Slot_size_is_too_big of {actual_size : int; max_size : int} - | Wrong_slot_frame_version of {expected : int; provided : int} - | Could_not_deserialize_slot - -let () = - register_error_kind - `Permanent - ~id:"slot_size_is_too_big" - ~title:"Slot size is too big" - ~description:"Slot cannot fit in maximum size" - ~pp:(fun ppf (actual_size, max_size) -> - Format.fprintf - ppf - "Actual size: %d, Maximum size: %d" - actual_size - max_size) - Data_encoding.(obj2 (req "actual_size" int31) (req "maximum_size" int31)) - (function - | Slot_size_is_too_big {actual_size; max_size} -> - Some (actual_size, max_size) - | _ -> None) - (fun (actual_size, max_size) -> - Slot_size_is_too_big {actual_size; max_size}) ; - register_error_kind - `Permanent - ~id:"wrong_slot_frame_version" - ~title:"Wrong slot frame version" - ~description:"Wrong slot frame version" - ~pp:(fun ppf (expected, provided) -> - Format.fprintf - ppf - "Version expected: %d, Version provided: %d" - expected - provided) - Data_encoding.( - obj2 (req "version_expected" uint8) (req "version_provided" uint8)) - (function - | Wrong_slot_frame_version {expected; provided} -> - Some (expected, provided) - | _ -> None) - (fun (expected, provided) -> Wrong_slot_frame_version {expected; provided}) ; - register_error_kind - `Permanent - ~id:"could_not_deserialize_slot" - ~title:"Slot could not be deserialized" - ~description:"Error when recovering slot contents from binary" - ~pp:(fun ppf () -> - Format.fprintf ppf "Error when recovering slot contents from binary") - Data_encoding.(unit) - (function Could_not_deserialize_slot -> Some () | _ -> None) - (fun () -> Could_not_deserialize_slot) - -type version = int - -type message = string - -module Rollups_map = Map.Make (Sc_rollup.Address) - -type t = message list Rollups_map.t - -module type Slot_version = sig - val version_prefix : version - - val expected_slot_size : t -> int - - val serialize : max_size:int -> t -> string tzresult Lwt.t - - val deserialize : max_size:int -> string -> t tzresult Lwt.t -end - -let version_encoding = Data_encoding.uint8 - -module V0 = struct - let version_prefix = 0 - - (* Binary representation of string uses 4 bytes as a header, - containing the string length. This conforms to the specification - given for messages. *) - let message_encoding = Data_encoding.string - - (* Binary representation of lists uses 4 bytes as a header, containing - the length of the list in bytes. This conforms to the - specification given for messages frames. *) - let messages_frame_encoding = Data_encoding.(list message_encoding) - - (* Binary representation of lists uses 4 bytes as a header, containing - the size of the encoded list contents in bytes. - `all_messages_frame_encoding` encodes not only the encoded messages - frames, but also the 4 bytes containing the length of all messages - frames that separate the rollups frame from the messages frame. - *) - let all_messages_frames_encoding = - Data_encoding.(list messages_frame_encoding) - - (* Binary representation of a [Sc_rollup.Address.t] uses 20 bytes, - while the encoding of a [int32] uses 4 bytes. These are - concatenated together by `rollup_offset_entry_encoding`. *) - let rollup_offset_entry_encoding = - Data_encoding.(tup2 Sc_rollup.Address.encoding int32) - - (* Binary representation of lists uses 4 bytes as a header, containing - the size of the encoded list contents in bytes. - the size in bytes of the rollups frame. containing - the length of the list in bytes. Thus the rollups_frame_encoding - conforms to the specification given*) - let rollups_frame_encoding = Data_encoding.(list rollup_offset_entry_encoding) - - let slot_encoding ~max_size = - Data_encoding.( - check_size max_size - @@ tup3 - version_encoding - rollups_frame_encoding - all_messages_frames_encoding) - - module Internal = struct - let size_of_opt size = match size with None -> assert false | Some n -> n - - let message_size = Data_encoding.Binary.length message_encoding - - let messages_frame_size = - Data_encoding.Binary.length messages_frame_encoding - - let all_messages_frames_size = - Data_encoding.Binary.length all_messages_frames_encoding - - let frame_prefix_size = - size_of_opt Data_encoding.(Binary.fixed_length int32) - - let frame_version_size = - size_of_opt Data_encoding.(Binary.fixed_length uint8) - - let rollup_entry_size = - size_of_opt - @@ Data_encoding.Binary.fixed_length rollup_offset_entry_encoding - - let rollups_frame_size number_of_rollups = - (rollup_entry_size * number_of_rollups) + frame_prefix_size - end - - let expected_slot_size all_rollups_messages = - let bindings = Rollups_map.bindings all_rollups_messages in - let number_of_rollups = bindings |> List.length in - let messages = List.map snd bindings in - Internal.( - frame_version_size - + rollups_frame_size number_of_rollups - + all_messages_frames_size messages) - - let serialize ~max_size all_rollups_messages = - let open Lwt_result_syntax in - let first_messages_frame_offset = - Internal.( - frame_version_size - + rollups_frame_size - (Rollups_map.bindings all_rollups_messages |> List.length) - + frame_prefix_size) - in - let rev_rollups_frame, rev_messages_frames, expected_slot_size = - Rollups_map.fold - (fun rollup messages (rollups_frame, messages_frames, next_offset) -> - let rollups_frame = - (rollup, Int32.of_int next_offset) :: rollups_frame - in - let messages_frames = messages :: messages_frames in - let next_offset = - next_offset + Internal.messages_frame_size messages - in - (rollups_frame, messages_frames, next_offset)) - all_rollups_messages - ([], [], first_messages_frame_offset) - in - let* () = - fail_unless - (expected_slot_size <= max_size) - (Slot_size_is_too_big {actual_size = expected_slot_size; max_size}) - in - let rollups_frame = List.rev rev_rollups_frame in - let messages_frames = List.rev rev_messages_frames in - let*? result = - Data_encoding.Binary.to_string - (slot_encoding ~max_size) - (version_prefix, rollups_frame, messages_frames) - |> Result.map_error (fun _ -> assert false) - in - return result - - (* Deserialization of slot contents will be done by WASM PVM kernels, as - per #3374. However, we should still provide a function to - deserialize the contents of a slot, as other components other than the - PVM kernel may need to inspect it. *) - let deserialize ~max_size serialized = - let open Lwt_result_syntax in - let actual_size = String.length serialized in - let* () = - fail_unless - (actual_size <= max_size) - (Slot_size_is_too_big {actual_size; max_size}) - in - let version_prefix, rollups_frame, messages_frames = - Data_encoding.Binary.of_string_exn (slot_encoding ~max_size) serialized - in - let* () = - fail_when - (version_prefix <> 0) - (Wrong_slot_frame_version {expected = 0; provided = version_prefix}) - in - let* () = - fail_when - (List.compare_length_with messages_frames @@ List.length rollups_frame - <> 0) - Could_not_deserialize_slot - in - let*? deserialized = - List.map2 - ~when_different_lengths:[] - (fun (rollup, _offset) messages -> (rollup, messages)) - rollups_frame - messages_frames - |> Result.map_error (fun _ -> [Could_not_deserialize_slot]) - |> Result.map (fun rollups_with_messages -> - Rollups_map.add_seq - (List.to_seq rollups_with_messages) - Rollups_map.empty) - in - return deserialized -end diff --git a/src/proto_020_PsParisC/lib_dal/dal_slot_frame_encoding.mli b/src/proto_020_PsParisC/lib_dal/dal_slot_frame_encoding.mli deleted file mode 100644 index 2b6134c2b089..000000000000 --- a/src/proto_020_PsParisC/lib_dal/dal_slot_frame_encoding.mli +++ /dev/null @@ -1,182 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* Library for encoding messages from distinct rollups into a slot. This - library contains encoding and decoding functions for different versions of - the slot-frame encoding. Currently, only one version, V0, exists. As the - structure of slot-frame progresses, new versions will be added. *) - -open Protocol -open Alpha_context - -type error += - | Slot_size_is_too_big of {actual_size : int; max_size : int} - | Wrong_slot_frame_version of {expected : int; provided : int} - | Could_not_deserialize_slot - -type version = int - -module Rollups_map : Map.S with type key = Sc_rollup.Address.t - -type message = string - -(* The type that will be used to serialize and deserialize a slot into a - slot-frame. It consists of a map from rollup addresses to list of - messages. *) -type t = message list Rollups_map.t - -(* Common interface for all slot versions. *) -module type Slot_version = sig - (* [version_prefix] denotes the version of the slot-frame encoding. - It must be a value between 0 and 255, and two different slot-frame - econdings cannot have the same version prefix. *) - val version_prefix : version - - (* [expected_slot_size rollups_messages] returns the value of the - size (in bytes) of a slot-frame that includes all the messages - in [rollups_messages]. It must satisfy the following property: - `expected_slot_size rollups_messages = - String.length @@ serialize rollups_messages`. - *) - val expected_slot_size : t -> int - - (* [serialize ~max_size rollups_messages] returns the encoding - of [rollups_messages] as a string, provided that the result - does not occupy more then [~max_size] byted. - When it succeeds, it must satisfy the following property: - `deserialize ~max_size @@ serialize ~max_size rollups_messages = - rollups_messages` - - May fail with: - {ul - {li [Slot_size_is_too_big {actual_size; max_size}] if the encoding of the - slot would take [actual_size] bytes, where `actual_size > max_size`} - } - *) - val serialize : max_size:int -> t -> string tzresult Lwt.t - - (* [deserialize ~max_size slot_frame] returns the rollup-address indexed map - of messages whose encoding corresponds to [slot_frame], as long as the - [slot_frame] does not occupy more then [~max_size] bytes, and [slot_frame] - contains the correct version_prefix, i.e. the first byte [slot_frame] - is set to `\000`. When it succeeds, it must satisfy the following property: - `serialize ~max_size @@ deserialize ~max_size slot_frame = - slot_frame` - - May fail with: - {ul - {li [Slot_size_is_too_big {actual_size; max_size}] if - [String.length slot_frame = actual_size], where - `actual_size > max_size`. - } - {li [Wrong_slot_frame_version of {expected; provided = 0}] if the first - byte of [slot_frame] is set to the binary encoding of [expected]. - } - {li [Could_not_deserialize_slot] if [slot_frame] does not correspond to - the serialization of a valid rollup-address indexed map of messages. - } - } - *) - val deserialize : max_size:int -> string -> t tzresult Lwt.t -end - -(*'V0' version of the slot-frame encoding. - Suppose that we want to include messages from rollups `r_1, ..., r_n`. - Specifically, for `i=1, ..., n`, suppose that rollup `r_i` wants to include - an arbitrary number j of messages `[m_{i,1}; ... m_{i, j} ]` into the slot. - The number of messages j to be included in a slot may be different for each - rollup. The encoded slot will consist of a string where: - {ul - {li The first byte contains the slot-frame version, currently set to `0x00`,} - {li The next `n * 24 + 4` bytes contain the `rollups-frame`, which contains - the information about where the messages for the rollups - `r_1, .., r_n` are stored. Specifically, the first 4 bytes denote the - length (in bytes) of the remaining part of the rollups-frame, which is - `n * 24`. This is followed by `n` entries of `24` bytes each. For each - entry, the first `20` bytes contain the encoded address of the rollup - node, while the other `4` contain the offset - from the start of the - slot - to the start of the rollup's messages-frame (described next). - } - {li The `4` bytes following the rollups frame contain the length of the - rest of the encoded slot, } - {li Next, there are n messages-frames, one for each rollup. For - `i = 1, ..., n`, the size of the i-th messages-frame is - `4 * n_i + (\sum_{j=1}^{n_i} |m_{i, j}|) + 4` bytes. The first four - bytes denote the length of the messages-frame. Then we have the - sequence of the encoded messages `m_{i,1}, ..., m_{i, j}`. The encoded - message `m_{i,j}` consists of 4 bytes representing `|m_{i,j}|`, - followed by `m_{i,j}` itself. - } - } - - As an example, suppose that we have two rollups `r1` and `r2`. For - simplicity, let's assume that the binary represenation of `r1` and `r2` are - `ROLLUP_ADDRESS_1XXXX` and `ROLLUP_ADDRESS_2YYYY`. Suppose that we want to - include in the slot messages [["hello"; "world"]] from `r1`, and messages - [["CAFEBABE"; "CAFEDEAD"]] from `r2` (in this order). The overall encoded - frame will be - "\000 - \000\000\000\048 - ROLLUP_ADDRESS_1XXXX\000\000\000\057 - ROLLUP_ADDRESS_2YYYY\000\000\000\079 - \000\000\000\050 - \000\000\000\018\000\000\000\005hello\000\000\000\005world - \000\000\000\024\000\000\000\008CAFEBABE\000\000\000\008CAFEDEAD". -*) -module V0 : sig - include Slot_version - - (* Functions used internally by the V0 version of the slot. These functions - are exposed so that they can be used in tests. This is necessary as we - will have implementations of the deserialization for the slot functions in - different programming languages. Checking the values returned by these - functions in tests will serve as documentation for developers wanting to - implement their own version of the V0 slot-frame deserialization. *) - module Internal : sig - (* [messages_size message] returns the size in bytes that [message] - would take in a slot-frame. *) - val message_size : message -> int - - (* [messages_frame_size messages] returns the size in bytes that the - encoding of messages as a messages frame would take in a slot-frame. *) - val messages_frame_size : message list -> int - - (* [all_messages_frame all_messages] returns the size in bytes - that the encoding of [all_messages] would take in a slot-frame. - This value includes the 4 bytes that separate the rollups-frame - from the rest of the slot frame in the encoding. *) - val all_messages_frames_size : message list list -> int - - (* [rollup_entry_size] returns the size in bytes - that one rollup would take in the rollups-frame. - *) - val rollup_entry_size : int - - (* [rollups_frame_size number_of_rollups] returns the size - in bytes that the rollups-frame would take in a slot-frame, - if the latter contains messages for [number_of_rollups] rollups. *) - val rollups_frame_size : int -> int - end -end diff --git a/src/proto_020_PsParisC/lib_dal/dune b/src/proto_020_PsParisC/lib_dal/dune deleted file mode 100644 index fd0e4457c4c1..000000000000 --- a/src/proto_020_PsParisC/lib_dal/dune +++ /dev/null @@ -1,38 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tezos_dal_020_PsParisC) - (public_name octez-protocol-020-PsParisC-libs.dal) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - octez-protocol-compiler.registerer - octez-libs.stdlib-unix - octez-shell-libs.shell-services - tezos-dal-node-lib - octez-protocol-020-PsParisC-libs.client - octez-protocol-020-PsParisC-libs.plugin - tezos-protocol-020-PsParisC.embedded-protocol - octez-protocol-020-PsParisC-libs.layer2-utils - tezos-protocol-020-PsParisC.protocol) - (inline_tests - (flags -verbose) - (modes native) - (executable - (link_flags -linkall -cclib -lblst -cclib -loctez_rustzcash_deps)) - (libraries bls12-381.archive octez-rustzcash-deps)) - (preprocess (pps ppx_expect)) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_protocol_registerer - -open Tezos_stdlib_unix - -open Tezos_shell_services - -open Tezos_dal_node_lib - -open Tezos_client_020_PsParisC - -open Tezos_protocol_plugin_020_PsParisC - -open Tezos_embedded_protocol_020_PsParisC - -open Tezos_layer2_utils_020_PsParisC - -open Tezos_protocol_020_PsParisC)) diff --git a/src/proto_020_PsParisC/lib_delegate/abstract_context_index.ml b/src/proto_020_PsParisC/lib_delegate/abstract_context_index.ml deleted file mode 100644 index 6dbf6c21d4b3..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/abstract_context_index.ml +++ /dev/null @@ -1,38 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 = { - sync_fun : unit -> unit Lwt.t; - checkout_fun : - Context_hash.t -> Tezos_protocol_environment.Context.t option Lwt.t; - finalize_fun : unit -> unit Lwt.t; -} - -let abstract index = - { - sync_fun = (fun () -> Context_ops.sync index); - checkout_fun = Context_ops.checkout index; - finalize_fun = (fun () -> Context_ops.close index); - } diff --git a/src/proto_020_PsParisC/lib_delegate/abstract_context_index.mli b/src/proto_020_PsParisC/lib_delegate/abstract_context_index.mli deleted file mode 100644 index 4e2f52596c68..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/abstract_context_index.mli +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 = { - sync_fun : unit -> unit Lwt.t; - checkout_fun : - Context_hash.t -> Tezos_protocol_environment.Context.t option Lwt.t; - finalize_fun : unit -> unit Lwt.t; -} - -val abstract : Context_ops.index -> t diff --git a/src/proto_020_PsParisC/lib_delegate/baking_actions.ml b/src/proto_020_PsParisC/lib_delegate/baking_actions.ml deleted file mode 100644 index 0e63577655e3..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_actions.ml +++ /dev/null @@ -1,1205 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context -open Baking_state -module Events = Baking_events.Actions - -module Profiler = (val Profiler.wrap Baking_profiler.baker_profiler) - -module Operations_source = struct - type error += - | Failed_operations_fetch of { - path : string; - reason : string; - details : Data_encoding.json option; - } - - let operations_encoding = - Data_encoding.(list (dynamic_size Operation.encoding)) - - let retrieve = - let open Lwt_result_syntax in - function - | None -> Lwt.return_none - | Some operations -> ( - let fail reason details = - let path = - match operations with - | Baking_configuration.Operations_source.Local {filename} -> - filename - | Baking_configuration.Operations_source.Remote {uri; _} -> - Uri.to_string uri - in - tzfail (Failed_operations_fetch {path; reason; details}) - in - let decode_operations json = - protect - ~on_error:(fun _ -> - fail "cannot decode the received JSON into operations" (Some json)) - (fun () -> - return (Data_encoding.Json.destruct operations_encoding json)) - in - match operations with - | Baking_configuration.Operations_source.Local {filename} -> - if Sys.file_exists filename then - let*! result = - Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file filename - in - match result with - | Error _ -> - let*! () = Events.(emit invalid_json_file filename) in - Lwt.return_none - | Ok json -> ( - let*! operations = decode_operations json in - match operations with - | Ok operations -> Lwt.return_some operations - | Error errs -> - let*! () = Events.(emit cannot_fetch_operations errs) in - Lwt.return_none) - else - let*! () = Events.(emit no_operations_found_in_file filename) in - Lwt.return_none - | Baking_configuration.Operations_source.Remote {uri; http_headers} -> ( - let*! operations_opt = - let* result = - with_timeout - (Systime_os.sleep (Time.System.Span.of_seconds_exn 5.)) - (fun _ -> - Tezos_rpc_http_client_unix.RPC_client_unix - .generic_media_type_call - ~accept:[Media_type.json] - ?headers:http_headers - `GET - uri) - in - let* rest = - match result with - | `Json json -> return json - | _ -> fail "json not returned" None - in - let* json = - match rest with - | `Ok json -> return json - | `Unauthorized json -> fail "unauthorized request" json - | `Gone json -> fail "gone" json - | `Error json -> fail "error" json - | `Not_found json -> fail "not found" json - | `Forbidden json -> fail "forbidden" json - | `Conflict json -> fail "conflict" json - in - decode_operations json - in - match operations_opt with - | Ok operations -> Lwt.return_some operations - | Error errs -> - let*! () = Events.(emit cannot_fetch_operations errs) in - Lwt.return_none)) -end - -type action = - | Do_nothing - | Prepare_block of {block_to_bake : block_to_bake} - | Prepare_preattestations of {preattestations : unsigned_consensus_vote_batch} - | Prepare_attestations of {attestations : unsigned_consensus_vote_batch} - | Prepare_consensus_votes of { - preattestations : unsigned_consensus_vote_batch; - attestations : unsigned_consensus_vote_batch; - } - | Inject_block of { - prepared_block : prepared_block; - force_injection : bool; - asynchronous : bool; - } - | Inject_preattestation of {signed_preattestation : signed_consensus_vote} - | Inject_attestations of {signed_attestations : signed_consensus_vote_batch} - | Update_to_level of level_update - | Synchronize_round of round_update - | Watch_prequorum - | Watch_quorum - -and level_update = { - new_level_proposal : proposal; - compute_new_state : - current_round:Round.t -> - delegate_slots:delegate_slots -> - next_level_delegate_slots:delegate_slots -> - dal_attestable_slots:dal_attestable_slots -> - next_level_dal_attestable_slots:dal_attestable_slots -> - (state * action) Lwt.t; -} - -and round_update = { - new_round_proposal : proposal; - handle_proposal : state -> (state * action) Lwt.t; -} - -type t = action - -let pp_action fmt = function - | Do_nothing -> Format.fprintf fmt "do nothing" - | Prepare_block _ -> Format.fprintf fmt "prepare block" - | Prepare_preattestations _ -> Format.fprintf fmt "prepare preattestations" - | Prepare_attestations _ -> Format.fprintf fmt "prepare attestations" - | Prepare_consensus_votes _ -> Format.fprintf fmt "prepare consensus votes" - | Inject_block _ -> Format.fprintf fmt "inject block" - | Inject_preattestation _ -> Format.fprintf fmt "inject preattestation" - | Inject_attestations _ -> Format.fprintf fmt "inject multiple attestations" - | Update_to_level _ -> Format.fprintf fmt "update to level" - | Synchronize_round _ -> Format.fprintf fmt "synchronize round" - | Watch_prequorum -> Format.fprintf fmt "watch prequorum" - | Watch_quorum -> Format.fprintf fmt "watch quorum" - -let generate_seed_nonce_hash ?timeout config delegate level = - let open Lwt_result_syntax in - if level.Level.expected_commitment then - let* seed_nonce = - (Baking_nonces.generate_seed_nonce - ?timeout - config - delegate - level.level - [@profiler.record_s {verbosity = Debug} "generate seed nonce"]) - in - return_some seed_nonce - else return_none - -let sign ?timeout ?watermark ~signing_request cctxt secret_key_uri msg = - let open Lwt_result_syntax in - let*! result = - match timeout with - | None -> - let*! res = Client_keys.sign cctxt secret_key_uri ?watermark msg in - Lwt.return (`Signature_result res) - | Some timeout -> - Lwt.pick - [ - (let*! () = Lwt_unix.sleep timeout in - Lwt.return (`Signature_timeout timeout)); - (let*! signature = - Client_keys.sign cctxt secret_key_uri ?watermark msg - in - Lwt.return (`Signature_result signature)); - ] - in - match result with - | `Signature_timeout timeout -> - let*! () = Events.(emit signature_timeout timeout) in - tzfail (Baking_errors.Signature_timeout (timeout, signing_request)) - | `Signature_result (Error errs) -> - let*! () = Events.(emit signature_error errs) in - Lwt.return (Error errs) - | `Signature_result (Ok res) -> Lwt.return (Ok res) - -let sign_block_header global_state proposer unsigned_block_header = - let open Lwt_result_syntax in - let cctxt = global_state.cctxt in - let chain_id = global_state.chain_id in - let force = global_state.config.force in - let {Block_header.shell; protocol_data = {contents; _}} = - unsigned_block_header - in - let unsigned_header = - Data_encoding.Binary.to_bytes_exn - Alpha_context.Block_header.unsigned_encoding - (shell, contents) - in - let level = shell.level in - let*? round = Baking_state.round_of_shell_header shell in - let open Baking_highwatermarks in - let* result = - cctxt#with_lock (fun () -> - let block_location = - Baking_files.resolve_location ~chain_id `Highwatermarks - in - let* may_sign = - (may_sign_block - cctxt - block_location - ~delegate:proposer.public_key_hash - ~level - ~round [@profiler.record_s {verbosity = Debug} "may sign"]) - in - match may_sign with - | true -> - let* () = - (record_block - cctxt - block_location - ~delegate:proposer.public_key_hash - ~level - ~round [@profiler.record_s {verbosity = Debug} "record block"]) - in - return_true - | false -> - let*! () = Events.(emit potential_double_baking (level, round)) in - return force) - in - match result with - | false -> tzfail (Block_previously_baked {level; round}) - | true -> - let* signature = - (sign - ?timeout:global_state.config.remote_calls_timeout - ~signing_request:`Block_header - cctxt - proposer.secret_key_uri - ~watermark:Block_header.(to_watermark (Block_header chain_id)) - unsigned_header - [@profiler.record_s {verbosity = Debug} "sign : block header"]) - in - return {Block_header.shell; protocol_data = {contents; signature}} - -let prepare_block (global_state : global_state) (block_to_bake : block_to_bake) - = - let open Lwt_result_syntax in - let { - predecessor; - round; - delegate = (consensus_key, _) as delegate; - kind; - force_apply; - } = - block_to_bake - in - let*! () = - Events.( - emit - prepare_forging_block - (Int32.succ predecessor.shell.level, round, delegate)) - in - let cctxt = global_state.cctxt in - let chain_id = global_state.chain_id in - let simulation_mode = global_state.validation_mode in - let round_durations = global_state.round_durations in - let*? timestamp = - Environment.wrap_tzresult - (Round.timestamp_of_round - round_durations - ~predecessor_timestamp:predecessor.shell.timestamp - ~predecessor_round:predecessor.round - ~round) - in - let external_operation_source = global_state.config.extra_operations in - let*! extern_ops = Operations_source.retrieve external_operation_source in - let simulation_kind, payload_round = - match kind with - | Fresh pool -> - let pool = - let node_pool = Operation_pool.Prioritized.of_pool pool in - match extern_ops with - | None -> node_pool - | Some ops -> - Operation_pool.Prioritized.merge_external_operations node_pool ops - in - (Block_forge.Filter pool, round) - | Reproposal {consensus_operations; payload_hash; payload_round; payload} -> - ( Block_forge.Apply - { - ordered_pool = - Operation_pool.ordered_pool_of_payload - ~consensus_operations - payload; - payload_hash; - }, - payload_round ) - in - let*! () = - Events.( - emit forging_block (Int32.succ predecessor.shell.level, round, delegate)) - in - let* injection_level = - Plugin.RPC.current_level - cctxt - ~offset:1l - (`Hash global_state.chain_id, `Hash (predecessor.hash, 0)) - in - let* seed_nonce_opt = - (generate_seed_nonce_hash - ?timeout:global_state.config.remote_calls_timeout - global_state.config.Baking_configuration.nonce - consensus_key - injection_level - [@profiler.record_s {verbosity = Info} "generate seed nonce hash"]) - in - let seed_nonce_hash = Option.map fst seed_nonce_opt in - let user_activated_upgrades = global_state.config.user_activated_upgrades in - (* Set liquidity_baking_toggle_vote for this block *) - let { - Baking_configuration.vote_file; - liquidity_baking_vote; - adaptive_issuance_vote; - } = - global_state.config.per_block_votes - in - (* Prioritize reading from the [vote_file] if it exists. *) - let*! {liquidity_baking_vote; adaptive_issuance_vote} = - let default = - Protocol.Alpha_context.Per_block_votes. - {liquidity_baking_vote; adaptive_issuance_vote} - in - match vote_file with - | Some per_block_vote_file -> - Per_block_vote_file.read_per_block_votes_no_fail - ~default - ~per_block_vote_file - [@profiler.record_s {verbosity = Info} "read per block votes file"] - | None -> Lwt.return default - in - let*! () = - Events.(emit vote_for_liquidity_baking_toggle) liquidity_baking_vote - in - let*! () = Events.(emit vote_for_adaptive_issuance) adaptive_issuance_vote in - let chain = `Hash global_state.chain_id in - let pred_block = `Hash (predecessor.hash, 0) in - let* pred_resulting_context_hash = - (Shell_services.Blocks.resulting_context_hash - cctxt - ~chain - ~block:pred_block - () [@profiler.record_s {verbosity = Info} "pred resulting context hash"]) - in - let* pred_live_blocks = - (Chain_services.Blocks.live_blocks - cctxt - ~chain - ~block:pred_block - () [@profiler.record_s {verbosity = Info} "live blocks"]) - in - let* {unsigned_block_header; operations; manager_operations_infos} = - (Block_forge.forge - cctxt - ~chain_id - ~pred_info:predecessor - ~pred_live_blocks - ~pred_resulting_context_hash - ~timestamp - ~round - ~seed_nonce_hash - ~payload_round - ~liquidity_baking_toggle_vote:liquidity_baking_vote - ~adaptive_issuance_vote - ~user_activated_upgrades - ~force_apply - global_state.config.fees - simulation_mode - simulation_kind - global_state.constants.parametric - [@profiler.record_s {verbosity = Info} "forge block"]) - in - let* signed_block_header = - (sign_block_header - global_state - consensus_key - unsigned_block_header - [@profiler.record_s {verbosity = Info} "sign block header"]) - in - let* () = - match seed_nonce_opt with - | None -> - (* Nothing to do *) - return_unit - | Some (_, nonce) -> - let block_hash = Block_header.hash signed_block_header in - (Baking_nonces.register_nonce - cctxt - ~chain_id - block_hash - nonce - ~cycle:injection_level.cycle - ~level:injection_level.level - ~round [@profiler.record_s {verbosity = Info} "register nonce"]) - in - let baking_votes = - {Per_block_votes.liquidity_baking_vote; adaptive_issuance_vote} - in - return - { - signed_block_header; - round; - delegate; - operations; - manager_operations_infos; - baking_votes; - } - -let only_if_dal_feature_enabled = - let no_dal_node_warning_counter = ref 0 in - fun state ~default_value f -> - let open Lwt_syntax in - let open Constants in - let Parametric.{dal = {feature_enable; _}; _} = - state.global_state.constants.parametric - in - if feature_enable then - match state.global_state.dal_node_rpc_ctxt with - | None -> - incr no_dal_node_warning_counter ; - let* () = - if !no_dal_node_warning_counter mod 10 = 1 then - Events.(emit no_dal_node_running ()) - else return_unit - in - return default_value - | Some ctxt -> f ctxt - else return default_value - -let process_dal_rpc_result state delegate level round = - let open Lwt_result_syntax in - function - | `RPC_timeout -> - let*! () = - Events.(emit failed_to_get_dal_attestations_in_time delegate) - in - return_none - | `RPC_result (Error errs) -> - let*! () = - Events.(emit failed_to_get_dal_attestations (delegate, errs)) - in - return_none - | `RPC_result (Ok res) -> ( - match res with - | Tezos_dal_node_services.Types.Not_in_committee -> - let*! () = Events.(emit not_in_dal_committee (delegate, level)) in - return_none - | Attestable_slots {slots; published_level} -> - let number_of_slots = - state.global_state.constants.parametric.dal.number_of_slots - in - let dal_attestation = - List.fold_left_i - (fun i acc flag -> - match Dal.Slot_index.of_int_opt ~number_of_slots i with - | Some index when flag -> Dal.Attestation.commit acc index - | None | Some _ -> acc) - Dal.Attestation.empty - slots - in - let*! () = - let bitset_int = Bitset.to_z (dal_attestation :> Bitset.t) in - Events.( - emit - attach_dal_attestation - (delegate, bitset_int, published_level, level, round)) - in - return_some {attestation = dal_attestation}) - -let may_get_dal_content state consensus_vote = - let open Lwt_result_syntax in - let {delegate = _consensus_key, pkh; vote_consensus_content; _} = - consensus_vote - in - let level, round = - ( Raw_level.to_int32 vote_consensus_content.level, - vote_consensus_content.round ) - in - let promise_opt = - List.assoc_opt - ~equal:Signature.Public_key_hash.equal - pkh - state.level_state.dal_attestable_slots - in - match promise_opt with - | None -> return_none - | Some promise -> - let*! res = - (* Normally we'd just check the state of the promise and return the - resolved value or an error if the promise is still pending. However, - tests that bake in the past would fail, because there would not be - sufficient time to get the answer from the DAL node. Therefore, we - wait for a bit for the DAL node to provide an answer. *) - Lwt.pick - [ - (let*! () = Lwt_unix.sleep 0.5 in - Lwt.return `RPC_timeout); - (let*! tz_res = promise in - Lwt.return (`RPC_result tz_res)); - ] - in - process_dal_rpc_result state pkh level round res - -let is_authorized (global_state : global_state) highwatermarks consensus_vote = - let {delegate = consensus_key, _; vote_consensus_content; _} = - consensus_vote - in - let level, round = - ( Raw_level.to_int32 vote_consensus_content.level, - vote_consensus_content.round ) - in - let may_sign = - match consensus_vote.vote_kind with - | Preattestation -> - Baking_highwatermarks.may_sign_preattestation - highwatermarks - ~delegate:consensus_key.public_key_hash - ~level - ~round - | Attestation -> - Baking_highwatermarks.may_sign_attestation - highwatermarks - ~delegate:consensus_key.public_key_hash - ~level - ~round - in - may_sign || global_state.config.force - -let authorized_consensus_votes global_state - (unsigned_consensus_vote_batch : unsigned_consensus_vote_batch) = - let open Lwt_result_syntax in - (* Hypothesis: all consensus votes have the same round and level *) - let { - batch_kind; - batch_content = ({level; round; _} : batch_content); - batch_branch = _; - unsigned_consensus_votes; - } = - unsigned_consensus_vote_batch - in - let level = Raw_level.to_int32 level in - let cctxt = global_state.cctxt in - let chain_id = global_state.chain_id in - let block_location = - Baking_files.resolve_location ~chain_id `Highwatermarks - in - (* Filter all operations that don't satisfy the highwatermark and - record the ones that do. *) - let* authorized_votes, unauthorized_votes = - cctxt#with_lock (fun () -> - let* highwatermarks = Baking_highwatermarks.load cctxt block_location in - let authorized_votes, unauthorized_votes = - List.partition - (fun consensus_vote -> - is_authorized global_state highwatermarks consensus_vote) - unsigned_consensus_votes - in - (* Record all consensus votes new highwatermarks as one batch *) - let delegates = - List.map - (fun {delegate = ck, _; _} -> ck.public_key_hash) - authorized_votes - in - let record_all_consensus_vote = - match batch_kind with - | Preattestation -> Baking_highwatermarks.record_all_preattestations - | Attestation -> Baking_highwatermarks.record_all_attestations - in - (* We exit the client's lock as soon as this function returns *) - let* () = - record_all_consensus_vote - highwatermarks - cctxt - block_location - ~delegates - ~level - ~round - in - return (authorized_votes, unauthorized_votes)) - in - let*! () = - List.iter_s - (fun {vote_kind; delegate; _} -> - let error = - match vote_kind with - | Preattestation -> - Baking_highwatermarks.Block_previously_preattested {round; level} - | Attestation -> - Baking_highwatermarks.Block_previously_attested {round; level} - in - Events.( - emit - skipping_consensus_vote - (vote_kind, delegate, level, round, [error]))) - unauthorized_votes - in - return authorized_votes - -let forge_and_sign_consensus_vote global_state ~branch unsigned_consensus_vote : - signed_consensus_vote tzresult Lwt.t = - let open Lwt_result_syntax in - let cctxt = global_state.cctxt in - let chain_id = global_state.chain_id in - let {vote_kind; vote_consensus_content; delegate = ck, _; dal_content} = - unsigned_consensus_vote - in - let shell = {Tezos_base.Operation.branch} in - let watermark = - match vote_kind with - | Preattestation -> Operation.(to_watermark (Preattestation chain_id)) - | Attestation -> Operation.(to_watermark (Attestation chain_id)) - in - let (Contents_list contents) = - match vote_kind with - | Preattestation -> - Contents_list (Single (Preattestation vote_consensus_content)) - | Attestation -> - Contents_list - (Single - (Attestation - {consensus_content = vote_consensus_content; dal_content})) - in - let signing_request = - match vote_kind with - | Preattestation -> `Preattestation - | Attestation -> `Attestation - in - let unsigned_operation = (shell, Contents_list contents) in - let unsigned_operation_bytes = - Data_encoding.Binary.to_bytes_exn - Operation.unsigned_encoding - unsigned_operation - in - let sk_uri = ck.secret_key_uri in - let* signature = - sign - ?timeout:global_state.config.remote_calls_timeout - ~signing_request - cctxt - ~watermark - sk_uri - unsigned_operation_bytes - in - let protocol_data = Operation_data {contents; signature = Some signature} in - let signed_operation : Operation.packed = {shell; protocol_data} in - return {unsigned_consensus_vote; signed_operation} - -let sign_consensus_votes (global_state : global_state) - ({batch_kind; batch_content; batch_branch; _} as - unsigned_consensus_vote_batch : - unsigned_consensus_vote_batch) = - let open Lwt_result_syntax in - let* authorized_consensus_votes = - (authorized_consensus_votes - global_state - unsigned_consensus_vote_batch - [@profiler.record_s {verbosity = Info} "authorized consensus votes"]) - in - let* signed_consensus_votes = - List.filter_map_es - (fun ({delegate; vote_kind; vote_consensus_content; _} as - unsigned_consensus_vote) -> - let*! () = Events.(emit signing_consensus_vote (vote_kind, delegate)) in - let*! signed_consensus_vote_r = - (forge_and_sign_consensus_vote - global_state - ~branch:batch_branch - unsigned_consensus_vote - [@profiler.record_s - {verbosity = Info} "forge and sign consensus vote"]) - in - match signed_consensus_vote_r with - | Error err -> - let level, round = - ( Raw_level.to_int32 vote_consensus_content.level, - vote_consensus_content.round ) - in - let*! () = - Events.( - emit - skipping_consensus_vote - (vote_kind, delegate, level, round, err)) - in - return_none - | Ok signed_consensus_vote -> return_some signed_consensus_vote) - authorized_consensus_votes - in - let*? signed_consensus_vote_batch = - make_signed_consensus_vote_batch - batch_kind - batch_content - ~batch_branch - signed_consensus_votes - in - return signed_consensus_vote_batch - -let inject_consensus_vote state (signed_consensus_vote : signed_consensus_vote) - = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - let chain_id = state.global_state.chain_id in - let unsigned_consensus_vote = signed_consensus_vote.unsigned_consensus_vote in - let delegate = unsigned_consensus_vote.delegate in - let vote_consensus_content = unsigned_consensus_vote.vote_consensus_content in - let level, round = - ( Raw_level.to_int32 vote_consensus_content.level, - vote_consensus_content.round ) - in - protect - ~on_error:(fun err -> - let*! () = - Events.( - emit - failed_to_inject_consensus_vote - (unsigned_consensus_vote.vote_kind, delegate, err)) - in - return_unit) - (fun () -> - let* oph = - (Node_rpc.inject_operation - cctxt - ~chain:(`Hash chain_id) - signed_consensus_vote.signed_operation - [@profiler.record_s - {verbosity = Debug} - (Format.sprintf - "injecting consensus vote: %s" - (match unsigned_consensus_vote.vote_kind with - | Preattestation -> "preattestation" - | Attestation -> "attestation"))]) - in - let*! () = - Events.( - emit - consensus_vote_injected - (unsigned_consensus_vote.vote_kind, oph, delegate, level, round)) - in - return_unit) - -let inject_consensus_votes state signed_consensus_vote_batch = - List.iter_ep - (inject_consensus_vote state) - signed_consensus_vote_batch.signed_consensus_votes - -let inject_block ?(force_injection = false) ?(asynchronous = true) state - prepared_block = - let open Lwt_result_syntax in - let { - signed_block_header; - round; - delegate; - operations; - manager_operations_infos; - baking_votes; - } = - prepared_block - in - (* Cache last per-block votes to use in case of vote file errors *) - let new_state = - { - state with - global_state = - { - state.global_state with - config = - { - state.global_state.config with - per_block_votes = - { - state.global_state.config.per_block_votes with - liquidity_baking_vote = baking_votes.liquidity_baking_vote; - adaptive_issuance_vote = baking_votes.adaptive_issuance_vote; - }; - }; - }; - } - in - let inject_block () = - let*! () = - Events.( - emit injecting_block (signed_block_header.shell.level, round, delegate)) - in - let* bh = - (Node_rpc.inject_block - state.global_state.cctxt - ~force:state.global_state.config.force - ~chain:(`Hash state.global_state.chain_id) - signed_block_header - operations [@profiler.record_s {verbosity = Info} "injecting block"]) - in - let*! () = - Events.( - emit - block_injected - ( bh, - signed_block_header.shell.level, - round, - delegate, - manager_operations_infos )) - in - return_unit - in - let now = Time.System.now () in - let block_time = - Time.System.of_protocol_exn signed_block_header.shell.timestamp - in - (* Blocks might be ready before their actual timestamp: when this - happens, we wait asynchronously until our clock reaches the - block's timestamp before injecting. *) - let* () = - let delay = Ptime.diff block_time now in - if Ptime.Span.(compare delay zero < 0) || force_injection then - inject_block () - else - let*! () = - Events.( - emit - delayed_block_injection - (delay, signed_block_header.shell.level, round, delegate)) - in - let t = - let*! _ = - protect - ~on_error:(fun err -> - let*! () = - Events.( - emit - block_injection_failed - (Block_header.hash signed_block_header, err)) - in - return_unit) - (fun () -> - let*! () = Lwt_unix.sleep (Ptime.Span.to_float_s delay) in - inject_block ()) - in - Lwt.return_unit - in - let*! () = - if asynchronous then ( - Lwt.dont_wait (fun () -> t) (fun _exn -> ()) ; - Lwt.return_unit) - else t - in - return_unit - in - return new_state - -let prepare_waiting_for_quorum state = - let consensus_threshold = - state.global_state.constants.parametric.consensus_threshold - in - let get_slot_voting_power ~slot = - Delegate_slots.voting_power state.level_state.delegate_slots ~slot - in - let latest_proposal = state.level_state.latest_proposal.block in - (* assert (latest_proposal.block.round = state.round_state.current_round) ; *) - let candidate = - { - Operation_worker.hash = latest_proposal.hash; - round_watched = latest_proposal.round; - payload_hash_watched = latest_proposal.payload_hash; - } - in - (consensus_threshold, get_slot_voting_power, candidate) - -let start_waiting_for_preattestation_quorum state = - let consensus_threshold, get_slot_voting_power, candidate = - prepare_waiting_for_quorum state - in - let operation_worker = state.global_state.operation_worker in - Operation_worker.monitor_preattestation_quorum - operation_worker - ~consensus_threshold - ~get_slot_voting_power - candidate - -let start_waiting_for_attestation_quorum state = - let consensus_threshold, get_slot_voting_power, candidate = - prepare_waiting_for_quorum state - in - let operation_worker = state.global_state.operation_worker in - Operation_worker.monitor_attestation_quorum - operation_worker - ~consensus_threshold - ~get_slot_voting_power - candidate - -let compute_round proposal round_durations = - let open Protocol in - let open Baking_state in - let timestamp = Time.System.now () |> Time.System.to_protocol in - let predecessor_block = proposal.predecessor in - Environment.wrap_tzresult - @@ Alpha_context.Round.round_of_timestamp - round_durations - ~predecessor_timestamp:predecessor_block.shell.timestamp - ~predecessor_round:predecessor_block.round - ~timestamp - -let notice_delegates_without_slots all_delegates delegate_slots level = - let delegates_without_slots = - List.filter - (fun {Baking_state.public_key_hash; _} -> - not - @@ List.exists - (fun {consensus_key_and_delegate = _, pkh_with_rights; _} -> - public_key_hash = pkh_with_rights) - (Baking_state.Delegate_slots.own_delegates delegate_slots)) - all_delegates - in - match delegates_without_slots with - | [] -> Lwt.return_unit - | delegates -> Events.(emit delegates_without_slots (delegates, level)) - -let update_to_level state level_update = - let open Lwt_result_syntax in - let {new_level_proposal; compute_new_state} = level_update in - let cctxt = state.global_state.cctxt in - let delegates = state.global_state.delegates in - let new_level = new_level_proposal.block.shell.level in - let chain = `Hash state.global_state.chain_id in - (* Sync the context to clean-up potential GC artifacts *) - let*! () = - match state.global_state.validation_mode with - | Node -> Lwt.return_unit - | Local index -> index.sync_fun () - in - let* delegate_slots = - if Int32.(new_level = succ state.level_state.current_level) then - return state.level_state.next_level_delegate_slots - else - Baking_state.compute_delegate_slots - cctxt - delegates - ~level:new_level - ~chain - [@profiler.record_s - {verbosity = Debug} "compute predecessor delegate slots"] - in - let* next_level_delegate_slots = - (Baking_state.compute_delegate_slots - cctxt - delegates - ~level:(Int32.succ new_level) - ~chain - [@profiler.record_s {verbosity = Debug} "compute current delegate slots"]) - in - let*! () = - notice_delegates_without_slots delegates delegate_slots new_level - in - let round_durations = state.global_state.round_durations in - let*? current_round = - (compute_round - new_level_proposal - round_durations [@profiler.record_f {verbosity = Debug} "compute round"]) - in - let*! dal_attestable_slots, next_level_dal_attestable_slots = - only_if_dal_feature_enabled - state - ~default_value:([], []) - (fun dal_node_rpc_ctxt -> - let dal_attestable_slots = - if Int32.(new_level = succ state.level_state.current_level) then - state.level_state.next_level_dal_attestable_slots - else - Node_rpc.dal_attestable_slots - dal_node_rpc_ctxt - ~attestation_level:new_level - (Delegate_slots.own_delegates delegate_slots) - in - let next_level_dal_attestable_slots = - Node_rpc.dal_attestable_slots - dal_node_rpc_ctxt - ~attestation_level:(Int32.succ new_level) - (Delegate_slots.own_delegates next_level_delegate_slots) - in - Lwt.return (dal_attestable_slots, next_level_dal_attestable_slots)) - in - let*! new_state = - (compute_new_state - ~current_round - ~delegate_slots - ~next_level_delegate_slots - ~dal_attestable_slots - ~next_level_dal_attestable_slots - [@profiler.record_s {verbosity = Debug} "compute new state"]) - in - return new_state - -let synchronize_round state {new_round_proposal; handle_proposal} = - let open Lwt_result_syntax in - let*! () = - Events.(emit synchronizing_round new_round_proposal.predecessor.hash) - in - let round_durations = state.global_state.round_durations in - let*? current_round = - (compute_round - new_round_proposal - round_durations [@profiler.record_f {verbosity = Debug} "compute round"]) - in - if Round.(current_round < new_round_proposal.block.round) then - (* impossible *) - failwith - "synchronize_round: current round (%a) is behind the new proposal's \ - round (%a)" - Round.pp - current_round - Round.pp - new_round_proposal.block.round - else - let new_round_state = - { - current_round; - current_phase = Idle; - delayed_quorum = None; - early_attestations = []; - awaiting_unlocking_pqc = false; - } - in - let new_state = {state with round_state = new_round_state} in - let*! new_state = handle_proposal new_state in - return new_state - -let prepare_block_request state block_to_bake = - let open Lwt_result_syntax in - let request = Forge_and_sign_block block_to_bake in - state.global_state.forge_worker_hooks.push_request request ; - return state - -let prepare_preattestations_request state unsigned_preattestations = - let open Lwt_result_syntax in - let request = Forge_and_sign_preattestations {unsigned_preattestations} in - state.global_state.forge_worker_hooks.push_request request ; - return state - -let prepare_attestations_request state unsigned_attestations = - let open Lwt_result_syntax in - let*! unsigned_attestations_with_dal = - dal_content_map_p (may_get_dal_content state) unsigned_attestations - in - let request = - Forge_and_sign_attestations - {unsigned_attestations = unsigned_attestations_with_dal} - in - state.global_state.forge_worker_hooks.push_request request ; - return state - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/4539 - Avoid updating the state here. - (See also comment in {!State_transitions.step}.) - - TODO: https://gitlab.com/tezos/tezos/-/issues/4538 - Improve/clarify when the state is recorded. -*) -let rec perform_action state (action : action) = - let open Lwt_result_syntax in - match action with - | Do_nothing -> return state - | Prepare_block {block_to_bake} -> - prepare_block_request - state - block_to_bake - [@profiler.record_s {verbosity = Info} "action : prepare block"] - | Prepare_preattestations {preattestations} -> - let* new_state = - (prepare_preattestations_request - state - preattestations - [@profiler.record_s - {verbosity = Info} "action : prepare preattestations"]) - in - (* We wait for preattestations to trigger the [Prequorum_reached] - event *) - perform_action new_state Watch_prequorum - | Prepare_attestations {attestations} -> - let* new_state = - (prepare_attestations_request - state - attestations - [@profiler.record_s {verbosity = Info} "action : prepare attestations"]) - in - (* We wait for attestations to trigger the [Quorum_reached] - event *) - perform_action new_state Watch_quorum - | Prepare_consensus_votes {preattestations; attestations} -> - let* state = - (prepare_preattestations_request - state - preattestations - [@profiler.record_s - {verbosity = Info} "action : prepare preattestations"]) - in - let* state = - (prepare_attestations_request - state - attestations - [@profiler.record_s {verbosity = Info} "action : prepare attestations"]) - in - (* We wait for preattestations to trigger the [Prequorum_reached] - event *) - perform_action state Watch_prequorum - | Inject_block {prepared_block; force_injection; asynchronous} -> - let* new_state = - (inject_block - ~force_injection - ~asynchronous - state - prepared_block - [@profiler.record_s {verbosity = Info} "action : inject block"]) - in - return new_state - | Inject_preattestation {signed_preattestation} -> - let* () = - (inject_consensus_vote - state - signed_preattestation - [@profiler.record_s - {verbosity = Info} "action : inject preattestation"]) - in - (* Here, we do not need to wait for the prequorum, it has - already been triggered by the - [Prepare_(preattestation|consensus_votes)] action *) - return state - | Inject_attestations {signed_attestations} -> - let* () = - (inject_consensus_votes - state - signed_attestations - [@profiler.record_s {verbosity = Info} "action : inject attestations"]) - in - (* We wait for attestations to trigger the [Quorum_reached] - event *) - perform_action state Watch_quorum - | Update_to_level level_update -> - let* new_state, new_action = - (update_to_level - state - level_update - [@profiler.record_s {verbosity = Info} "action : update to level"]) - in - perform_action new_state new_action - | Synchronize_round round_update -> - let* new_state, new_action = - (synchronize_round - state - round_update - [@profiler.record_s {verbosity = Info} "action : synchronize round"]) - in - perform_action new_state new_action - | Watch_prequorum -> - let*! () = - (start_waiting_for_preattestation_quorum - state - [@profiler.record_s - {verbosity = Info} "action : wait for preattestation quorum"]) - in - return state - | Watch_quorum -> - let*! () = - (start_waiting_for_attestation_quorum - state - [@profiler.record_s - {verbosity = Info} "action : wait for attestation quorum"]) - in - return state diff --git a/src/proto_020_PsParisC/lib_delegate/baking_actions.mli b/src/proto_020_PsParisC/lib_delegate/baking_actions.mli deleted file mode 100644 index 72705ab1e6e0..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_actions.mli +++ /dev/null @@ -1,121 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context -open Baking_state - -type action = - | Do_nothing - | Prepare_block of {block_to_bake : block_to_bake} - | Prepare_preattestations of {preattestations : unsigned_consensus_vote_batch} - | Prepare_attestations of {attestations : unsigned_consensus_vote_batch} - | Prepare_consensus_votes of { - preattestations : unsigned_consensus_vote_batch; - attestations : unsigned_consensus_vote_batch; - } - | Inject_block of { - prepared_block : prepared_block; - force_injection : bool; - asynchronous : bool; - } - | Inject_preattestation of {signed_preattestation : signed_consensus_vote} - | Inject_attestations of {signed_attestations : signed_consensus_vote_batch} - | Update_to_level of level_update - | Synchronize_round of round_update - | Watch_prequorum - | Watch_quorum - -and level_update = { - new_level_proposal : proposal; - compute_new_state : - current_round:Round.t -> - delegate_slots:delegate_slots -> - next_level_delegate_slots:delegate_slots -> - dal_attestable_slots:dal_attestable_slots -> - next_level_dal_attestable_slots:dal_attestable_slots -> - (state * action) Lwt.t; -} - -and round_update = { - new_round_proposal : proposal; - handle_proposal : state -> (state * action) Lwt.t; -} - -type t = action - -val pp_action : Format.formatter -> action -> unit - -val generate_seed_nonce_hash : - ?timeout:float -> - Baking_configuration.nonce_config -> - consensus_key -> - Level.t -> - (Nonce_hash.t * Nonce.t) option tzresult Lwt.t - -val prepare_block : - global_state -> block_to_bake -> prepared_block tzresult Lwt.t - -val inject_block : - ?force_injection:bool -> - ?asynchronous:bool -> - state -> - prepared_block -> - state tzresult Lwt.t - -val may_get_dal_content : - state -> unsigned_consensus_vote -> dal_content option tzresult Lwt.t - -val authorized_consensus_votes : - global_state -> - unsigned_consensus_vote_batch -> - unsigned_consensus_vote list tzresult Lwt.t - -val forge_and_sign_consensus_vote : - global_state -> - branch:Block_hash.t -> - unsigned_consensus_vote -> - signed_consensus_vote tzresult Lwt.t - -val sign_consensus_votes : - global_state -> - unsigned_consensus_vote_batch -> - signed_consensus_vote_batch tzresult Lwt.t - -val inject_consensus_votes : - state -> signed_consensus_vote_batch -> unit tzresult Lwt.t - -val prepare_waiting_for_quorum : - state -> int * (slot:Slot.t -> int option) * Operation_worker.candidate - -val start_waiting_for_preattestation_quorum : state -> unit Lwt.t - -val start_waiting_for_attestation_quorum : state -> unit Lwt.t - -val update_to_level : state -> level_update -> (state * t) tzresult Lwt.t - -val compute_round : proposal -> Round.round_durations -> Round.t tzresult - -val perform_action : state -> t -> state tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/baking_cache.ml b/src/proto_020_PsParisC/lib_delegate/baking_cache.ml deleted file mode 100644 index 2af2842c7777..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_cache.ml +++ /dev/null @@ -1,84 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(** Cache structures used to memoize costly RPCs/computations. *) - -open Protocol.Alpha_context - -type round = Round.t - -module Block_cache = - Aches.Vache.Map (Aches.Vache.LRU_Precise) (Aches.Vache.Strong) (Block_hash) - -(** The [Timestamp_of_round_tbl] module allows to create memoization tables - to store function calls of [Round.timestamp_of_round]. *) -module Timestamp_of_round_cache = - Aches.Vache.Map (Aches.Vache.LRU_Precise) (Aches.Vache.Strong) - (struct - (* The type of keys is a tuple that corresponds to the arguments - of [Round.timestamp_of_round]. *) - type t = Timestamp.time * round * round - - let hash k = Hashtbl.hash k - - let equal (ts, r1, r2) (ts', r1', r2') = - Timestamp.(ts = ts') && Round.(r1 = r1') && Round.(r2 = r2') - end) - -module Round_cache_key = struct - type ts_interval = Timestamp.time * Timestamp.time - - (** The values that are intended to be used here are the - arguments are: predecessor_timestamp * predecessor_round * - timestamp_interval *) - type t = { - predecessor_timestamp : Timestamp.time; - predecessor_round : round; - time_interval : ts_interval; - } - - let hash {predecessor_timestamp; predecessor_round; _} = - Stdlib.Hashtbl.hash (predecessor_timestamp, predecessor_round) - - let equal - { - predecessor_timestamp = pred_t; - predecessor_round = pred_r; - time_interval = t_beg, t_end; - } - { - predecessor_timestamp = pred_t'; - predecessor_round = pred_r'; - time_interval = t_beg', t_end'; - } = - Timestamp.(pred_t = pred_t') - && Round.(pred_r = pred_r') - && Timestamp.(t_beg' <= t_beg) - && Timestamp.(t_end < t_end') -end - -module Round_timestamp_interval_cache = - Aches.Vache.Map (Aches.Vache.LRU_Precise) (Aches.Vache.Strong) - (Round_cache_key) diff --git a/src/proto_020_PsParisC/lib_delegate/baking_commands.ml b/src/proto_020_PsParisC/lib_delegate/baking_commands.ml deleted file mode 100644 index 3c5cb7cd4002..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_commands.ml +++ /dev/null @@ -1,879 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Client_proto_args -open Baking_errors -module Events = Baking_events.Commands - -let pidfile_arg = - let open Lwt_result_syntax in - Tezos_clic.arg - ~doc:"write process id in file" - ~short:'P' - ~long:"pidfile" - ~placeholder:"filename" - (Tezos_clic.parameter (fun _ s -> return s)) - -let may_lock_pidfile pidfile_opt f = - match pidfile_opt with - | None -> f () - | Some pidfile -> - Lwt_lock_file.with_lock - ~when_locked: - (`Fail (Exn (Failure ("Failed to create the pidfile: " ^ pidfile)))) - ~filename:pidfile - f - -let check_node_version cctxt bypass allowed = - let open Lwt_result_syntax in - (* Parse and check allowed versions *) - let*? allowed = - let open Result_syntax in - Option.map_e - (fun allowed -> - match - Tezos_version_parser.version_commit (Lexing.from_string allowed) - with - | None -> tzfail (Node_version_malformatted allowed) - | Some x -> return x) - allowed - in - let is_allowed node_version - (node_commit_info : Tezos_version.Octez_node_version.commit_info option) = - match allowed with - | None -> false - | Some (v, c) -> ( - let c = - Option.map - (fun commit_hash -> - Tezos_version.Octez_node_version.{commit_hash; commit_date = ""}) - c - in - match - Tezos_version.Octez_node_version.partially_compare - v - c - node_version - node_commit_info - with - | None -> false - | Some x -> x = 0) - in - if bypass then - let*! () = Events.(emit node_version_check_bypass ()) in - return_unit - else - let baker_version = Tezos_version_value.Current_git_info.octez_version in - let (baker_commit_info - : Tezos_version.Octez_node_version.commit_info option) = - Some - { - commit_hash = Tezos_version_value.Current_git_info.commit_hash; - commit_date = Tezos_version_value.Current_git_info.committer_date; - } - in - let* node_version = Version_services.version cctxt in - let*! () = - Events.( - emit - node_version_check - ( node_version.version, - node_version.commit_info, - baker_version, - baker_commit_info )) - in - if is_allowed node_version.version node_version.commit_info then return_unit - else - match - Tezos_version.Octez_node_version.partially_compare - baker_version - baker_commit_info - node_version.version - node_version.commit_info - with - | Some r when r <= 0 -> return_unit - | _ -> - tzfail - (Node_version_incompatible - { - node_version = node_version.version; - node_commit_info = node_version.commit_info; - baker_version; - baker_commit_info; - }) - -let http_headers_env_variable = - "TEZOS_CLIENT_REMOTE_OPERATIONS_POOL_HTTP_HEADERS" - -let http_headers = - match Sys.getenv_opt http_headers_env_variable with - | None -> None - | Some contents -> - let lines = String.split_on_char '\n' contents in - Some - (List.fold_left - (fun acc line -> - match String.index_opt line ':' with - | None -> - invalid_arg - (Printf.sprintf - "Http headers: invalid %s environment variable, missing \ - colon" - http_headers_env_variable) - | Some pos -> - let header = String.trim (String.sub line 0 pos) in - let header = String.lowercase_ascii header in - if header <> "host" then - invalid_arg - (Printf.sprintf - "Http headers: invalid %s environment variable, only \ - 'host' headers are supported" - http_headers_env_variable) ; - let value = - String.trim - (String.sub line (pos + 1) (String.length line - pos - 1)) - in - (header, value) :: acc) - [] - lines) - -let operations_arg = - Tezos_clic.arg - ~long:"operations-pool" - ~placeholder:"file|uri" - ~doc: - (Printf.sprintf - "When specified, the baker will try to fetch operations from this \ - file (or uri) and to include retrieved operations in the block. The \ - expected format of the contents is a list of operations [ \ - alpha.operation ]. Environment variable '%s' may also be specified \ - to add headers to the requests (only 'host' headers are supported). \ - If the resource cannot be retrieved, e.g., if the file is absent, \ - unreadable, or the web service returns a 404 error, the resource is \ - simply ignored." - http_headers_env_variable) - (Tezos_clic.map_parameter - ~f:(fun uri -> - let open Baking_configuration in - match Uri.scheme uri with - | Some "http" | Some "https" -> - Operations_source.(Remote {uri; http_headers}) - | None | Some _ -> - (* acts as if it were file even though it might no be *) - Operations_source.(Local {filename = Uri.to_string uri})) - uri_parameter) - -let context_path_arg = - Tezos_clic.arg - ~long:"context" - ~placeholder:"path" - ~doc: - "When specified, the client will read in the local context at the \ - provided path in order to build the block, instead of relying on the \ - 'preapply' RPC." - string_parameter - -let force_apply_switch_arg = - Tezos_clic.switch - ~long:"force-apply" - ~doc:"Force the baker to not only validate but also apply operations." - () - -let attestation_force_switch_arg = - Tezos_clic.switch - ~long:"force" - ~short:'f' - ~doc: - "Disable consistency, injection and double signature checks for \ - (pre)attestations." - () - -let do_not_monitor_node_mempool_arg = - Tezos_clic.switch - ~long:"ignore-node-mempool" - ~doc: - "Ignore mempool operations from the node and do not subsequently monitor \ - them. Use in conjunction with --operations option to restrict the \ - observed operations to those of the mempool file." - () - -let keep_alive_arg = - Tezos_clic.switch - ~doc: - "Keep the daemon process alive: when the connection with the node is \ - lost, the daemon periodically tries to reach it." - ~short:'K' - ~long:"keep-alive" - () - -let per_block_vote_parameter = - let open Lwt_result_syntax in - Tezos_clic.parameter - ~autocomplete:(fun _ctxt -> return ["on"; "off"; "pass"]) - (let open Protocol.Alpha_context.Per_block_votes in - fun _ctxt -> function - | "on" -> return Per_block_vote_on - | "off" -> return Per_block_vote_off - | "pass" -> return Per_block_vote_pass - | s -> - failwith - "unexpected vote: %s, expected either \"on\", \"off\", or \ - \"pass\"." - s) - -let liquidity_baking_toggle_vote_arg = - Tezos_clic.arg - ~doc: - "Vote to continue or end the liquidity baking subsidy. The possible \ - values for this option are: \"off\" to request ending the subsidy, \ - \"on\" to request continuing or restarting the subsidy, and \"pass\" to \ - abstain. Note that this \"option\" is mandatory!" - ~long:"liquidity-baking-toggle-vote" - ~placeholder:"vote" - per_block_vote_parameter - -let adaptive_issuance_vote_arg = - Tezos_clic.arg - ~doc: - "Vote to adopt or not the adaptive issuance feature. The possible values \ - for this option are: \"off\" to request not activating it, \"on\" to \ - request activating it, and \"pass\" to abstain. If you do not vote, \ - default value is \"pass\"." - ~long:"adaptive-issuance-vote" - ~placeholder:"vote" - per_block_vote_parameter - -let state_recorder_switch_arg = - let open Lwt_result_syntax in - let open Baking_configuration in - Tezos_clic.map_arg - ~f:(fun _cctxt flag -> if flag then return Filesystem else return Memory) - (Tezos_clic.switch - ~long:"record-state" - ~doc: - "If record-state flag is set, the baker saves all its internal \ - consensus state in the filesystem, otherwise just in memory." - ()) - -let node_version_check_bypass_arg = - Tezos_clic.switch - ~long:"node-version-check-bypass" - ~doc: - "If node-version-check-bypass flag is set, the baker will not check its \ - compatibility with the version of the node to which it is connected." - () - -let node_version_allowed_arg = - Tezos_clic.arg - ~long:"node-version-allowed" - ~placeholder:"-[v].[.0][:]" - ~doc: - "When specified the baker will accept to run with a node of this \ - version. The specified version is composed of the product, for example \ - 'octez'; the major and the minor versions that are positive integers; \ - the info, for example '-rc', '-beta1+dev' or realese if none is \ - provided; optionally the commit that is the hash of the last git commit \ - or a prefix of at least 8 characters long." - string_parameter - -let get_delegates (cctxt : Protocol_client_context.full) - (pkhs : Signature.public_key_hash list) = - let open Lwt_result_syntax in - let proj_delegate (alias, public_key_hash, public_key, secret_key_uri) = - { - Baking_state.alias = Some alias; - public_key_hash; - public_key; - secret_key_uri; - } - in - let* delegates = - if pkhs = [] then - let* keys = Client_keys.get_keys cctxt in - List.map proj_delegate keys |> return - else - List.map_es - (fun pkh -> - let* result = Client_keys.get_key cctxt pkh in - match result with - | alias, pk, sk_uri -> return (proj_delegate (alias, pkh, pk, sk_uri))) - pkhs - in - let* () = - Tezos_signer_backends.Encrypted.decrypt_list - cctxt - (List.filter_map - (function - | {Baking_state.alias = Some alias; _} -> Some alias | _ -> None) - delegates) - in - let delegates_no_duplicates = List.sort_uniq compare delegates in - let*! () = - if List.compare_lengths delegates delegates_no_duplicates <> 0 then - cctxt#warning - "Warning: the list of public key hash aliases contains duplicate \ - hashes, which are ignored" - else Lwt.return_unit - in - return delegates_no_duplicates - -let sources_param = - Tezos_clic.seq_of_param - (Client_keys.Public_key_hash.source_param - ~name:"baker" - ~desc: - "name of the delegate owning the attestation/baking right or name of \ - the consensus key signing on the delegate's behalf") - -let endpoint_arg = - let open Lwt_result_syntax in - Tezos_clic.arg - ~long:"dal-node" - ~placeholder:"uri" - ~doc:"endpoint of the DAL node, e.g. 'http://localhost:8933'" - (Tezos_clic.parameter (fun _ s -> return @@ Uri.of_string s)) - -let without_dal_arg = - Tezos_clic.switch - ~long:"without-dal" - ~doc: - "If without-dal flag is set, the daemon will not try to connect to a DAL \ - node." - () - -let block_count_arg = - Tezos_clic.default_arg - ~long:"count" - ~short:'n' - ~placeholder:"block count" - ~doc:"number of blocks to bake" - ~default:"1" - @@ Client_proto_args.positive_int_parameter () - -let delegate_commands () : Protocol_client_context.full Tezos_clic.command list - = - let open Lwt_result_syntax in - let open Tezos_clic in - let group = - {name = "delegate.client"; title = "Tenderbake client commands"} - in - [ - command - ~group - ~desc:"Benchmark the proof of work challenge resolution" - (args2 - (default_arg - ~doc:"Proof of work threshold" - ~long:"threshold" - ~placeholder:"int" - ~default: - (Int64.to_string - Default_parameters.constants_mainnet.proof_of_work_threshold) - (parameter (fun (cctxt : Protocol_client_context.full) x -> - try return (Int64.of_string x) - with _ -> cctxt#error "Expect an integer"))) - (arg - ~doc:"Random seed" - ~long:"seed" - ~placeholder:"int" - (parameter (fun (cctxt : Protocol_client_context.full) x -> - try return (int_of_string x) - with _ -> cctxt#error "Expect an integer")))) - (prefix "bench" - @@ param - ~name:"nb_draw" - ~desc:"number of draws" - (parameter (fun (cctxt : Protocol_client_context.full) x -> - match int_of_string x with - | x when x >= 1 -> return x - | _ | (exception _) -> - cctxt#error "Expect a strictly positive integer")) - @@ fixed ["baking"; "PoW"; "challenges"]) - (fun (proof_of_work_threshold, seed) nb_draw cctxt -> - let open Lwt_result_syntax in - let*! () = - cctxt#message - "Running %d iterations of proof-of-work challenge..." - nb_draw - in - let rstate = - match seed with - | None -> Random.State.make_self_init () - | Some s -> Random.State.make [|s|] - in - let* all = - List.map_es - (fun i -> - let level = Int32.of_int (Random.State.int rstate (1 lsl 29)) in - let shell_header = - Tezos_base.Block_header. - { - level; - proto_level = 1; - (* uint8 *) - predecessor = Tezos_crypto.Hashed.Block_hash.zero; - timestamp = Time.Protocol.epoch; - validation_passes = 3; - (* uint8 *) - operations_hash = - Tezos_crypto.Hashed.Operation_list_list_hash.zero; - fitness = []; - context = Tezos_crypto.Hashed.Context_hash.zero; - } - in - let now = Time.System.now () in - let* _ = - Baking_pow.mine - ~proof_of_work_threshold - shell_header - (fun proof_of_work_nonce -> - Protocol.Alpha_context. - { - Block_header.payload_hash = - Protocol.Block_payload_hash.zero; - payload_round = Round.zero; - seed_nonce_hash = None; - proof_of_work_nonce; - per_block_votes = - { - liquidity_baking_vote = Per_block_vote_pass; - adaptive_issuance_vote = Per_block_vote_pass; - }; - }) - in - let _then = Time.System.now () in - let x = Ptime.diff _then now in - let*! () = cctxt#message "%d/%d: %a" i nb_draw Ptime.Span.pp x in - return x) - (1 -- nb_draw) - in - let sum = List.fold_left Ptime.Span.add Ptime.Span.zero all in - let base, tail = Stdlib.List.(hd all, tl all) in - let max = - List.fold_left - (fun x y -> if Ptime.Span.compare x y > 0 then x else y) - base - tail - in - let min = - List.fold_left - (fun x y -> if Ptime.Span.compare x y <= 0 then x else y) - base - tail - in - let div = Ptime.Span.to_float_s sum /. float (List.length all) in - let*! () = - cctxt#message - "%d runs: min: %a, max: %a, average: %a" - nb_draw - Ptime.Span.pp - min - Ptime.Span.pp - max - (Format.pp_print_option Ptime.Span.pp) - (Ptime.Span.of_float_s div) - in - return_unit); - command - ~group - ~desc:"Forge and inject block using the delegates' rights." - (args13 - minimal_fees_arg - minimal_nanotez_per_gas_unit_arg - minimal_nanotez_per_byte_arg - minimal_timestamp_switch - force_apply_switch_arg - force_switch - operations_arg - context_path_arg - adaptive_issuance_vote_arg - do_not_monitor_node_mempool_arg - endpoint_arg - block_count_arg - state_recorder_switch_arg) - (prefixes ["bake"; "for"] @@ sources_param) - (fun ( minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - minimal_timestamp, - force_apply, - force, - extra_operations, - context_path, - adaptive_issuance_vote, - do_not_monitor_node_mempool, - dal_node_endpoint, - block_count, - state_recorder ) - pkhs - cctxt -> - let* delegates = get_delegates cctxt pkhs in - Baking_lib.bake - cctxt - ~minimal_nanotez_per_gas_unit - ~minimal_timestamp - ~minimal_nanotez_per_byte - ~minimal_fees - ~force_apply - ~force - ~monitor_node_mempool:(not do_not_monitor_node_mempool) - ?extra_operations - ?context_path - ?dal_node_endpoint - ~count:block_count - ?votes: - (Option.map - (fun adaptive_issuance_vote -> - { - Baking_configuration.default_votes_config with - adaptive_issuance_vote; - }) - adaptive_issuance_vote) - ~state_recorder - delegates); - command - ~group - ~desc:"Forge and inject an attestation operation." - (args1 attestation_force_switch_arg) - (prefixes ["attest"; "for"] @@ sources_param) - (fun force pkhs cctxt -> - let* delegates = get_delegates cctxt pkhs in - Baking_lib.attest ~force cctxt delegates); - command - ~group - ~desc: - "Deprecated, use **attest for** instead. Forge and inject an \ - attestation operation." - (args1 attestation_force_switch_arg) - (prefixes ["endorse"; "for"] @@ sources_param) - (fun force pkhs cctxt -> - let* delegates = get_delegates cctxt pkhs in - Baking_lib.attest ~force cctxt delegates); - command - ~group - ~desc:"Forge and inject a preattestation operation." - (args1 attestation_force_switch_arg) - (prefixes ["preattest"; "for"] @@ sources_param) - (fun force pkhs cctxt -> - let* delegates = get_delegates cctxt pkhs in - Baking_lib.preattest ~force cctxt delegates); - command - ~group - ~desc: - "Deprecated, use **preattest for** instead. Forge and inject a \ - preattestation operation." - (args1 attestation_force_switch_arg) - (prefixes ["preendorse"; "for"] @@ sources_param) - (fun force pkhs cctxt -> - let* delegates = get_delegates cctxt pkhs in - Baking_lib.preattest ~force cctxt delegates); - command - ~group - ~desc:"Send a Tenderbake proposal" - (args9 - minimal_fees_arg - minimal_nanotez_per_gas_unit_arg - minimal_nanotez_per_byte_arg - minimal_timestamp_switch - force_apply_switch_arg - force_switch - operations_arg - context_path_arg - state_recorder_switch_arg) - (prefixes ["propose"; "for"] @@ sources_param) - (fun ( minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - minimal_timestamp, - force_apply, - force, - extra_operations, - context_path, - state_recorder ) - sources - cctxt -> - let* delegates = get_delegates cctxt sources in - Baking_lib.propose - cctxt - ~minimal_nanotez_per_gas_unit - ~minimal_timestamp - ~minimal_nanotez_per_byte - ~minimal_fees - ~force_apply - ~force - ?extra_operations - ?context_path - ~state_recorder - delegates); - ] - -let directory_parameter = - let open Lwt_result_syntax in - Tezos_clic.parameter (fun _ p -> - let*! exists = Lwt_utils_unix.dir_exists p in - if not exists then failwith "Directory doesn't exist: '%s'" p - else return p) - -let per_block_vote_file_arg = - Tezos_clic.arg - ~doc:"read per block votes as json file" - ~short:'V' - ~long:"votefile" - ~placeholder:"filename" - (Tezos_clic.parameter (fun (_cctxt : Protocol_client_context.full) file -> - let open Lwt_result_syntax in - let* file_exists = - protect - ~on_error:(fun _ -> tzfail (Block_vote_file_not_found file)) - (fun () -> - let*! b = Lwt_unix.file_exists file in - return b) - in - if file_exists then return file - else tzfail (Block_vote_file_not_found file))) - -let pre_emptive_forge_time_arg = - Tezos_clic.arg - ~long:"pre-emptive-forge-time" - ~placeholder:"seconds" - ~doc: - "Sets the pre-emptive forge time optimization, in seconds. When set, the \ - baker, if it is the next level round 0 proposer, will start forging \ - after quorum has been reached in the current level while idly waiting \ - for it to end. When it is its time to propose, the baker will inject \ - the pre-emptively forged block immediately, allowing more time for the \ - network to reach quorum on it. Operators should note that the higher \ - this value `t`, the lower the operation inclusion window (specifically \ - `block_time - t`) which may lead to lower baking rewards. Defaults to \ - 15/% of block time. Set to 0 to ignore pre-emptive forging." - (Tezos_clic.parameter (fun _ s -> - try Lwt_result_syntax.return (Q.of_string s) - with _ -> failwith "pre-emptive-forge-time expected int or float.")) - -let remote_calls_timeout_arg = - let open Lwt_result_syntax in - Tezos_clic.arg - ~long:"remote-calls-timeout" - ~placeholder:"seconds" - ~doc: - "Sets a timeout for client calls such as signing block header or \ - attestation and for the creation of deterministic nonce. Use only if \ - your remote signer can handle concurrent requests." - (Tezos_clic.parameter (fun _ s -> - try return (Q.of_string s) - with _ -> failwith "remote-calls-timeout expected int or float.")) - -let lookup_default_vote_file_path (cctxt : Protocol_client_context.full) = - let open Lwt_syntax in - let default_filename = Per_block_vote_file.default_vote_json_filename in - let file_exists path = - Lwt.catch (fun () -> Lwt_unix.file_exists path) (fun _ -> return_false) - in - let when_s pred x g = - let* b = pred x in - if b then return_some x else g () - in - (* Check in current working directory *) - when_s file_exists default_filename @@ fun () -> - (* Check in the baker directory *) - let base_dir_file = Filename.Infix.(cctxt#get_base_dir // default_filename) in - when_s file_exists base_dir_file @@ fun () -> return_none - -(* This function checks that a DAL node endpoint was given, - and that the specified DAL node is "healthy", - (the DAL's nodes 'health' RPC is used for that). *) -let check_dal_node without_dal dal_node_rpc_ctxt = - let open Lwt_result_syntax in - let result_emit f x = - let*! () = Events.emit f x in - return_unit - in - match (dal_node_rpc_ctxt, without_dal) with - | None, true -> - (* The user is aware that no DAL node is running, since they explicitly - used the [--without-dal] option. However, we do not want to reduce the - exposition of bakers to warnings about DAL, so we keep it. *) - result_emit Events.no_dal_node_running () - | None, false -> result_emit Events.no_dal_deprecation () - | Some _, true -> tzfail Incompatible_dal_options - | Some ctxt, false -> ( - let*! health = Node_rpc.get_dal_health ctxt in - match health with - | Ok health -> ( - match health.status with - | Tezos_dal_node_services.Types.Health.Up -> return_unit - | _ -> result_emit Events.unhealthy_dal_node (ctxt#base, health)) - | Error _ -> result_emit Events.unreachable_dal_node ctxt#base) - -type baking_mode = Local of {local_data_dir_path : string} | Remote - -let baker_args = - Tezos_clic.args17 - pidfile_arg - node_version_check_bypass_arg - node_version_allowed_arg - minimal_fees_arg - minimal_nanotez_per_gas_unit_arg - minimal_nanotez_per_byte_arg - force_apply_switch_arg - keep_alive_arg - liquidity_baking_toggle_vote_arg - adaptive_issuance_vote_arg - per_block_vote_file_arg - operations_arg - endpoint_arg - without_dal_arg - state_recorder_switch_arg - pre_emptive_forge_time_arg - remote_calls_timeout_arg - -let run_baker - ( pidfile, - node_version_check_bypass, - node_version_allowed, - minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - force_apply, - keep_alive, - liquidity_baking_vote, - adaptive_issuance_vote, - per_block_vote_file, - extra_operations, - dal_node_endpoint, - without_dal, - state_recorder, - pre_emptive_forge_time, - remote_calls_timeout ) baking_mode sources cctxt = - let open Lwt_result_syntax in - may_lock_pidfile pidfile @@ fun () -> - let* () = - check_node_version cctxt node_version_check_bypass node_version_allowed - in - let*! per_block_vote_file = - if per_block_vote_file = None then - (* If the votes file was not explicitly given, we - look into default locations. *) - lookup_default_vote_file_path cctxt - else Lwt.return per_block_vote_file - in - (* We don't let the user run the baker without providing some - option (CLI, file path, or file in default location) for - the per-block votes. *) - let* votes = - Per_block_vote_file.load_per_block_votes_config - ~default_liquidity_baking_vote:liquidity_baking_vote - ~default_adaptive_issuance_vote:adaptive_issuance_vote - ~per_block_vote_file - in - let dal_node_rpc_ctxt = - Option.map Baking_scheduling.create_dal_node_rpc_ctxt dal_node_endpoint - in - let* () = check_dal_node without_dal dal_node_rpc_ctxt in - let* delegates = get_delegates cctxt sources in - let context_path = - match baking_mode with - | Local {local_data_dir_path} -> Some local_data_dir_path - | Remote -> None - in - Client_daemon.Baker.run - cctxt - ~minimal_fees - ~minimal_nanotez_per_gas_unit - ~minimal_nanotez_per_byte - ~votes - ?extra_operations - ?dal_node_endpoint - ?pre_emptive_forge_time - ~force_apply - ?remote_calls_timeout - ~chain:cctxt#chain - ?context_path - ~keep_alive - ~state_recorder - delegates - -let baker_commands () : Protocol_client_context.full Tezos_clic.command list = - let open Tezos_clic in - let group = - { - Tezos_clic.name = "delegate.baker"; - title = "Commands related to the baker daemon."; - } - in - [ - command - ~group - ~desc:"Launch the baker daemon." - baker_args - (prefixes ["run"; "with"; "local"; "node"] - @@ param - ~name:"node_data_path" - ~desc:"Path to the node data directory (e.g. $HOME/.tezos-node)" - directory_parameter - @@ sources_param) - (fun args local_data_dir_path sources cctxt -> - let baking_mode = Local {local_data_dir_path} in - run_baker args baking_mode sources cctxt); - command - ~group - ~desc:"Launch the baker daemon using RPCs only." - baker_args - (prefixes ["run"; "remotely"] @@ sources_param) - (fun args sources cctxt -> - let baking_mode = Remote in - run_baker args baking_mode sources cctxt); - command - ~group - ~desc:"Launch the VDF daemon" - (args2 pidfile_arg keep_alive_arg) - (prefixes ["run"; "vdf"] @@ stop) - (fun (pidfile, keep_alive) cctxt -> - may_lock_pidfile pidfile @@ fun () -> - Client_daemon.VDF.run cctxt ~chain:cctxt#chain ~keep_alive); - ] - -let accuser_commands () = - let open Tezos_clic in - let group = - { - Tezos_clic.name = "delegate.accuser"; - title = "Commands related to the accuser daemon."; - } - in - [ - command - ~group - ~desc:"Launch the accuser daemon" - (args3 pidfile_arg Client_proto_args.preserved_levels_arg keep_alive_arg) - (prefixes ["run"] @@ stop) - (fun (pidfile, preserved_levels, keep_alive) cctxt -> - may_lock_pidfile pidfile @@ fun () -> - Client_daemon.Accuser.run - cctxt - ~chain:cctxt#chain - ~preserved_levels - ~keep_alive); - ] diff --git a/src/proto_020_PsParisC/lib_delegate/baking_commands.mli b/src/proto_020_PsParisC/lib_delegate/baking_commands.mli deleted file mode 100644 index 02e2819da4b9..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_commands.mli +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -val delegate_commands : - unit -> Protocol_client_context.full Tezos_clic.command list - -val baker_commands : - unit -> Protocol_client_context.full Tezos_clic.command list - -val accuser_commands : - unit -> Protocol_client_context.full Tezos_clic.command list diff --git a/src/proto_020_PsParisC/lib_delegate/baking_commands_registration.ml b/src/proto_020_PsParisC/lib_delegate/baking_commands_registration.ml deleted file mode 100644 index 7a1b3cd90c68..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_commands_registration.ml +++ /dev/null @@ -1,29 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -let () = - Client_commands.register Protocol.hash @@ fun _network -> - List.map (Tezos_clic.map_command (new Protocol_client_context.wrap_full)) - @@ Baking_commands.delegate_commands () diff --git a/src/proto_020_PsParisC/lib_delegate/baking_configuration.ml b/src/proto_020_PsParisC/lib_delegate/baking_configuration.ml deleted file mode 100644 index 19c9d2303ea0..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_configuration.ml +++ /dev/null @@ -1,376 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Operations_source = struct - type t = - | Local of {filename : string} - | Remote of {uri : Uri.t; http_headers : (string * string) list option} - - let pp ppf = function - | Local {filename} -> Format.pp_print_string ppf filename - | Remote {uri; _} -> Format.fprintf ppf "%a" Uri.pp uri - - let encoding = - let open Data_encoding in - union - ~tag_size:`Uint8 - [ - case - (Tag 1) - ~title:"Local" - (obj2 (req "filename" string) (req "kind" (constant "Local"))) - (function Local {filename} -> Some (filename, ()) | _ -> None) - (fun (filename, ()) -> Local {filename}); - case - (Tag 2) - ~title:"Remote" - (obj3 - (req "uri" string) - (opt "http_headers" (list (tup2 string string))) - (req "kind" (constant "Remote"))) - (function - | Remote {uri; http_headers} -> - Some (Uri.to_string uri, http_headers, ()) - | _ -> None) - (fun (uri_str, http_headers, ()) -> - Remote {uri = Uri.of_string uri_str; http_headers}); - ] -end - -open Protocol.Alpha_context - -type fees_config = { - minimal_fees : Tez.t; - minimal_nanotez_per_gas_unit : Q.t; - minimal_nanotez_per_byte : Q.t; -} - -type validation_config = - | Local of {context_path : string} - | Node - | ContextIndex of Abstract_context_index.t - -type nonce_config = Deterministic | Random - -type state_recorder_config = Filesystem | Memory - -type per_block_votes_config = { - vote_file : string option; - liquidity_baking_vote : Protocol.Alpha_context.Per_block_votes.per_block_vote; - adaptive_issuance_vote : Protocol.Alpha_context.Per_block_votes.per_block_vote; -} - -type t = { - fees : fees_config; - nonce : nonce_config; - validation : validation_config; - retries_on_failure : int; - user_activated_upgrades : (int32 * Protocol_hash.t) list; - per_block_votes : per_block_votes_config; - force_apply : bool; - force : bool; - state_recorder : state_recorder_config; - extra_operations : Operations_source.t option; - dal_node_endpoint : Uri.t option; - pre_emptive_forge_time : Time.System.Span.t; - remote_calls_timeout : float option; -} - -let default_fees_config = - { - minimal_fees = - (match Tez.of_mutez 100L with None -> assert false | Some t -> t); - minimal_nanotez_per_gas_unit = Q.of_int 100; - minimal_nanotez_per_byte = Q.of_int 1000; - } - -let default_validation_config = Node - -(* Unclear if determinist nonces, and more importantly, if - [supports_deterministic_nonces] is supported. *) -let default_nonce_config = Random - -let default_retries_on_failure_config = 5 - -let default_user_activated_upgrades = [] - -let default_votes_config = - { - vote_file = None; - liquidity_baking_vote = - Protocol.Alpha_context.Per_block_votes.Per_block_vote_pass; - adaptive_issuance_vote = - Protocol.Alpha_context.Per_block_votes.Per_block_vote_pass; - } - -let default_force = false - -let default_force_apply = false - -let default_state_recorder_config = Memory - -let default_extra_operations = None - -let default_pre_emptive_forge_time = Time.System.Span.of_seconds_exn 0. - -let default_remote_calls_timeout = None - -let default_config = - { - fees = default_fees_config; - nonce = default_nonce_config; - validation = default_validation_config; - retries_on_failure = default_retries_on_failure_config; - user_activated_upgrades = default_user_activated_upgrades; - per_block_votes = default_votes_config; - force_apply = default_force_apply; - force = default_force; - state_recorder = default_state_recorder_config; - extra_operations = default_extra_operations; - dal_node_endpoint = None; - pre_emptive_forge_time = default_pre_emptive_forge_time; - remote_calls_timeout = default_remote_calls_timeout; - } - -let make ?(minimal_fees = default_fees_config.minimal_fees) - ?(minimal_nanotez_per_gas_unit = - default_fees_config.minimal_nanotez_per_gas_unit) - ?(minimal_nanotez_per_byte = default_fees_config.minimal_nanotez_per_byte) - ?(nonce = default_nonce_config) ?context_path - ?(retries_on_failure = default_retries_on_failure_config) - ?(user_activated_upgrades = default_user_activated_upgrades) - ?(votes = default_votes_config) ?(force_apply = default_force_apply) - ?(force = default_force) ?(state_recorder = default_state_recorder_config) - ?extra_operations ?dal_node_endpoint - ?(pre_emptive_forge_time = default_pre_emptive_forge_time) - ?remote_calls_timeout () = - let fees = - {minimal_fees; minimal_nanotez_per_gas_unit; minimal_nanotez_per_byte} - in - let validation = - match context_path with - | None -> Node - | Some context_path -> Local {context_path} - in - { - fees; - validation; - nonce; - retries_on_failure; - user_activated_upgrades; - per_block_votes = votes; - force_apply; - force; - state_recorder; - extra_operations; - dal_node_endpoint; - pre_emptive_forge_time; - remote_calls_timeout; - } - -let fees_config_encoding : fees_config Data_encoding.t = - let open Data_encoding in - let q_encoding = - conv (fun q -> Q.to_string q) (fun s -> Q.of_string s) string - in - conv - (fun {minimal_fees; minimal_nanotez_per_gas_unit; minimal_nanotez_per_byte} -> - (minimal_fees, minimal_nanotez_per_gas_unit, minimal_nanotez_per_byte)) - (fun (minimal_fees, minimal_nanotez_per_gas_unit, minimal_nanotez_per_byte) -> - {minimal_fees; minimal_nanotez_per_gas_unit; minimal_nanotez_per_byte}) - (obj3 - (req "minimal_fees" Tez.encoding) - (req "minimal_nanotez_per_gas_unit" q_encoding) - (req "minimal_nanotez_per_byte" q_encoding)) - -let validation_config_encoding = - let open Data_encoding in - union - ~tag_size:`Uint8 - [ - case - ~title:"Local" - (Tag 0) - (obj1 (req "local" string)) - (function Local {context_path} -> Some context_path | _ -> None) - (fun context_path -> Local {context_path}); - case - ~title:"Node" - (Tag 1) - (constant "node") - (function Node -> Some () | _ -> None) - (fun () -> Node); - ] - -let nonce_config_encoding = - let open Data_encoding in - union - ~tag_size:`Uint8 - [ - case - ~title:"Deterministic" - (Tag 0) - (constant "deterministic") - (function Deterministic -> Some () | _ -> None) - (fun () -> Deterministic); - case - ~title:"Random" - (Tag 1) - (constant "Random") - (function Random -> Some () | _ -> None) - (fun () -> Random); - ] - -let retries_on_failure_config_encoding = Data_encoding.int31 - -let user_activate_upgrades_config_encoding = - let open Data_encoding in - list (tup2 int32 Protocol_hash.encoding) - -let liquidity_baking_toggle_vote_config_encoding = - Protocol.Alpha_context.Per_block_votes.liquidity_baking_vote_encoding - -let adaptive_issuance_vote_config_encoding = - Protocol.Alpha_context.Per_block_votes.adaptive_issuance_vote_encoding - -let per_block_votes_config_encoding = - let open Data_encoding in - def (String.concat "." [Protocol.name; "per_block_votes_config"]) - @@ conv - (fun {vote_file; liquidity_baking_vote; adaptive_issuance_vote} -> - (vote_file, liquidity_baking_vote, adaptive_issuance_vote)) - (fun (vote_file, liquidity_baking_vote, adaptive_issuance_vote) -> - {vote_file; liquidity_baking_vote; adaptive_issuance_vote}) - (obj3 - (opt "per_block_vote_file" string) - (req - "liquidity_baking_vote" - liquidity_baking_toggle_vote_config_encoding) - (req "adaptive_issuance_vote" adaptive_issuance_vote_config_encoding)) - -let force_config_encoding = Data_encoding.bool - -let force_apply_config_encoding = Data_encoding.bool - -let state_recorder_config_encoding = - let open Data_encoding in - union - ~tag_size:`Uint8 - [ - case - ~title:"Filesystem" - (Tag 0) - (constant "filesystem") - (function Filesystem -> Some () | _ -> None) - (fun () -> Filesystem); - case - ~title:"Memory" - (Tag 1) - (constant "memory") - (function Memory -> Some () | _ -> None) - (fun () -> Memory); - ] - -let encoding : t Data_encoding.t = - let open Data_encoding in - def - (String.concat "." [Protocol.name; "baking_configuration"]) - ~title:"Baking configuration" - ~description:"Baking configuration" - @@ conv - (fun { - fees; - validation; - nonce; - retries_on_failure; - user_activated_upgrades; - per_block_votes; - force_apply; - force; - state_recorder; - extra_operations; - dal_node_endpoint; - pre_emptive_forge_time; - remote_calls_timeout; - } -> - ( ( fees, - validation, - nonce, - retries_on_failure, - user_activated_upgrades, - per_block_votes, - force_apply, - force, - state_recorder, - pre_emptive_forge_time ), - (extra_operations, dal_node_endpoint, remote_calls_timeout) )) - (fun ( ( fees, - validation, - nonce, - retries_on_failure, - user_activated_upgrades, - per_block_votes, - force_apply, - force, - state_recorder, - pre_emptive_forge_time ), - (extra_operations, dal_node_endpoint, remote_calls_timeout) ) -> - { - fees; - validation; - nonce; - retries_on_failure; - user_activated_upgrades; - per_block_votes; - force_apply; - force; - state_recorder; - extra_operations; - dal_node_endpoint; - pre_emptive_forge_time; - remote_calls_timeout; - }) - (merge_objs - (obj10 - (req "fees" fees_config_encoding) - (req "validation" validation_config_encoding) - (req "nonce" nonce_config_encoding) - (req "retries_on_failure" retries_on_failure_config_encoding) - (req - "user_activated_upgrades" - user_activate_upgrades_config_encoding) - (req "votes" per_block_votes_config_encoding) - (req "force_apply" force_apply_config_encoding) - (req "force" force_config_encoding) - (req "state_recorder" state_recorder_config_encoding) - (req "pre_emptive_forge_time" Time.System.Span.encoding)) - (obj3 - (opt "extra_operations" Operations_source.encoding) - (opt "dal_node_endpoint" Tezos_rpc.Encoding.uri_encoding) - (opt "remote_calls_timeout" float))) - -let pp fmt t = - let json = Data_encoding.Json.construct encoding t in - Format.fprintf fmt "%a" Data_encoding.Json.pp json diff --git a/src/proto_020_PsParisC/lib_delegate/baking_configuration.mli b/src/proto_020_PsParisC/lib_delegate/baking_configuration.mli deleted file mode 100644 index 0c39553bfc7b..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_configuration.mli +++ /dev/null @@ -1,142 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Operations_source abstraction} *) -module Operations_source : sig - type t = - | Local of {filename : string} - (** local mempool resource located in [filename] *) - | Remote of {uri : Uri.t; http_headers : (string * string) list option} - (** remote resource located a [uri], with additional [http_headers] - parameters *) - - val encoding : t Data_encoding.t - - val pp : Format.formatter -> t -> unit -end - -type fees_config = { - minimal_fees : Protocol.Alpha_context.Tez.t; - minimal_nanotez_per_gas_unit : Q.t; - minimal_nanotez_per_byte : Q.t; -} - -type validation_config = - | Local of {context_path : string} - | Node - | ContextIndex of Abstract_context_index.t - -type nonce_config = Deterministic | Random - -type state_recorder_config = Filesystem | Memory - -type per_block_votes_config = { - vote_file : string option; - liquidity_baking_vote : Protocol.Alpha_context.Per_block_votes.per_block_vote; - adaptive_issuance_vote : Protocol.Alpha_context.Per_block_votes.per_block_vote; -} - -type t = { - fees : fees_config; - nonce : nonce_config; - validation : validation_config; - retries_on_failure : int; - user_activated_upgrades : (int32 * Protocol_hash.t) list; - per_block_votes : per_block_votes_config; - force_apply : bool; - force : bool; - state_recorder : state_recorder_config; - extra_operations : Operations_source.t option; - dal_node_endpoint : Uri.t option; - pre_emptive_forge_time : Time.System.Span.t; - remote_calls_timeout : float option; -} - -val default_fees_config : fees_config - -val default_validation_config : validation_config - -val default_nonce_config : nonce_config - -val default_retries_on_failure_config : int - -val default_user_activated_upgrades : (int32 * Protocol_hash.t) list - -val default_votes_config : per_block_votes_config - -val default_force_apply : bool - -val default_force : bool - -val default_state_recorder_config : state_recorder_config - -val default_extra_operations : Operations_source.t option - -val default_pre_emptive_forge_time : Time.System.Span.t - -val default_remote_calls_timeout : float option - -val default_config : t - -val make : - ?minimal_fees:Protocol.Alpha_context.Tez.t -> - ?minimal_nanotez_per_gas_unit:Q.t -> - ?minimal_nanotez_per_byte:Q.t -> - ?nonce:nonce_config -> - ?context_path:string -> - ?retries_on_failure:int -> - ?user_activated_upgrades:(int32 * Protocol_hash.t) list -> - ?votes:per_block_votes_config -> - ?force_apply:bool -> - ?force:bool -> - ?state_recorder:state_recorder_config -> - ?extra_operations:Operations_source.t -> - ?dal_node_endpoint:Uri.t -> - ?pre_emptive_forge_time:Time.System.Span.t -> - ?remote_calls_timeout:float -> - unit -> - t - -val fees_config_encoding : fees_config Data_encoding.t - -val validation_config_encoding : validation_config Data_encoding.t - -val nonce_config_encoding : nonce_config Data_encoding.t - -val retries_on_failure_config_encoding : int Data_encoding.t - -val user_activate_upgrades_config_encoding : - (int32 * Protocol_hash.t) list Data_encoding.t - -val liquidity_baking_toggle_vote_config_encoding : - Protocol.Alpha_context.Per_block_votes.per_block_vote Data_encoding.t - -val adaptive_issuance_vote_config_encoding : - Protocol.Alpha_context.Per_block_votes.per_block_vote Data_encoding.t - -val per_block_votes_config_encoding : per_block_votes_config Data_encoding.t - -val encoding : t Data_encoding.t - -val pp : Format.formatter -> t -> unit diff --git a/src/proto_020_PsParisC/lib_delegate/baking_errors.ml b/src/proto_020_PsParisC/lib_delegate/baking_errors.ml deleted file mode 100644 index 1ebc51e5a8f6..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_errors.ml +++ /dev/null @@ -1,437 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 += Node_connection_lost - -type error += - | Node_version_incompatible of { - node_version : Tezos_version_parser.t; - node_commit_info : Tezos_version.Octez_node_version.commit_info option; - baker_version : Tezos_version_parser.t; - baker_commit_info : Tezos_version.Octez_node_version.commit_info option; - } - -type error += Node_version_malformatted of string - -type error += Cannot_load_local_file of string - -type error += Broken_locked_values_invariant - -let register_error_kind category ~id ~title ~description ~pp encoding from_error - to_error = - Error_monad.register_error_kind - category - ~id:(String.concat "." ["baker"; Protocol.name; id]) - ~title - ~description - ~pp - encoding - from_error - to_error - -let () = - register_error_kind - `Temporary - ~id:"Baking_scheduling.node_connection_lost" - ~title:"Node connection lost" - ~description:"The connection with the node was lost." - ~pp:(fun fmt () -> Format.fprintf fmt "Lost connection with the node") - Data_encoding.empty - (function Node_connection_lost -> Some () | _ -> None) - (fun () -> Node_connection_lost) ; - register_error_kind - `Temporary - ~id:"Baking_commands.node_version_incompatible" - ~title:"Node version is incompatible" - ~description:"The node version is incompatible with this baker" - ~pp:(fun - fmt - ((node_version, node_commit_info, baker_version, baker_commit_info) : - Tezos_version_parser.t - * Tezos_version.Octez_node_version.commit_info option - * Tezos_version_parser.t - * Tezos_version.Octez_node_version.commit_info option) - -> - Format.fprintf - fmt - "@[Node version is %a (%a) but it is expected to be more recent than \ - %a (%a).@ This check can be bypassed at your own risk with the flag \ - --node-version-check-bypass or the argument --node-version-allowed \ - %a%a .@]" - Tezos_version.Version.pp - node_version - (Format.pp_print_option - ~none:(fun ppf () -> Format.pp_print_string ppf "none") - Tezos_version.Octez_node_version.commit_info_pp_short) - node_commit_info - Tezos_version.Version.pp - baker_version - (Format.pp_print_option - ~none:(fun ppf () -> Format.pp_print_string ppf "none") - Tezos_version.Octez_node_version.commit_info_pp_short) - baker_commit_info - Tezos_version.Version.pp_arg - node_version - (Format.pp_print_option - ~none:(fun _ppf () -> ()) - (fun ppf -> - Format.fprintf - ppf - ":%a" - Tezos_version.Octez_node_version.commit_info_pp_short)) - node_commit_info) - Data_encoding.( - obj4 - (req "node_version" Tezos_version.Octez_node_version.version_encoding) - (opt - "node_commit_info" - Tezos_version.Octez_node_version.commit_info_encoding) - (req "baker_version" Tezos_version.Octez_node_version.version_encoding) - (opt - "baker_commit_info" - Tezos_version.Octez_node_version.commit_info_encoding)) - (function - | Node_version_incompatible - {node_version; node_commit_info; baker_version; baker_commit_info} -> - Some (node_version, node_commit_info, baker_version, baker_commit_info) - | _ -> None) - (fun (node_version, node_commit_info, baker_version, baker_commit_info) -> - Node_version_incompatible - {node_version; node_commit_info; baker_version; baker_commit_info}) ; - register_error_kind - `Temporary - ~id:"Baking_commands.node_version_malformatted" - ~title:"Node version in command argument is malformatted" - ~description:"The node version provided in command argument is malformatted" - ~pp:(fun fmt version -> - Format.fprintf - fmt - "The node version provided in command argument: '%s' is a malformatted \ - version" - version) - Data_encoding.(obj1 (req "provided_version" string)) - (function Node_version_malformatted v -> Some v | _ -> None) - (fun v -> Node_version_malformatted v) ; - register_error_kind - `Temporary - ~id:"Baking_scheduling.cannot_load_local_file" - ~title:"Cannot load local file" - ~description:"Cannot load local file." - ~pp:(fun fmt filename -> - Format.fprintf fmt "Cannot load the local file %s" filename) - Data_encoding.(obj1 (req "file" string)) - (function Cannot_load_local_file s -> Some s | _ -> None) - (fun s -> Cannot_load_local_file s) ; - register_error_kind - `Permanent - ~id:"Baking_state.broken_locked_values_invariant" - ~title:"Broken locked values invariant" - ~description: - "The expected consistency invariant on locked values does not hold" - ~pp:(fun ppf () -> - Format.fprintf - ppf - "The expected consistency invariant on locked values does not hold") - Data_encoding.unit - (function Broken_locked_values_invariant -> Some () | _ -> None) - (fun () -> Broken_locked_values_invariant) - -type signing_request = [`Preattestation | `Attestation | `Block_header] - -let signing_request_encoding : signing_request Data_encoding.t = - let open Data_encoding in - union - [ - case - ~title:"preattestation" - (Tag 0) - (constant "preattestation") - (function `Preattestation -> Some () | _ -> None) - (function () -> `Preattestation); - case - ~title:"attestation" - (Tag 1) - (constant "attestation") - (function `Attestation -> Some () | _ -> None) - (function () -> `Attestation); - case - ~title:"block_header" - (Tag 2) - (constant "block_header") - (function `Block_header -> Some () | _ -> None) - (function () -> `Block_header); - ] - -let pp_signing_request fmt = function - | `Preattestation -> Format.fprintf fmt "a preattestation" - | `Attestation -> Format.fprintf fmt "an attestation" - | `Block_header -> Format.fprintf fmt "a block header" - -type error += Signature_timeout of (float * signing_request) - -let () = - register_error_kind - `Permanent - ~id:"Signature_timeout" - ~title:"Signature timeout" - ~description:"Signature call reached a timeout." - ~pp:(fun ppf (timeout, request) -> - Format.fprintf - ppf - "@[A call for signing %a has reached the timeout of %f seconds.@]" - pp_signing_request - request - timeout) - Data_encoding.( - obj2 (req "timeout" float) (req "request" signing_request_encoding)) - (function - | Signature_timeout (timeout, request) -> Some (timeout, request) - | _ -> None) - (fun (timeout, request) -> Signature_timeout (timeout, request)) - -type error += Deterministic_nonce_timeout of float - -let () = - register_error_kind - `Permanent - ~id:"Deterministic_nonce_timeout" - ~title:"Deterministic timeout" - ~description:"Deterministic nonce call reached a timeout." - ~pp:(fun ppf timeout -> - Format.fprintf - ppf - "@[A deterministic nonce call has reached the timeout of %f seconds.@]" - timeout) - Data_encoding.(obj1 (req "timeout" float)) - (function Deterministic_nonce_timeout timeout -> Some timeout | _ -> None) - (fun timeout -> Deterministic_nonce_timeout timeout) - -type error += Block_vote_file_not_found of string - -type error += Block_vote_file_invalid of string - -type error += Block_vote_file_wrong_content of string - -type error += Block_vote_file_missing_liquidity_baking_toggle_vote of string - -type error += Missing_vote_on_startup - -let () = - register_error_kind - `Permanent - ~id:"Per_block_vote_file.block_vote_file_not_found" - ~title: - "The provided block vote file path does not point to an existing file." - ~description: - "A block vote file path was provided on the command line but the path \ - does not point to an existing file." - ~pp:(fun ppf file_path -> - Format.fprintf - ppf - "@[The provided block vote file path \"%s\" does not point to an \ - existing file.@]" - file_path) - Data_encoding.(obj1 (req "file_path" string)) - (function - | Block_vote_file_not_found file_path -> Some file_path | _ -> None) - (fun file_path -> Block_vote_file_not_found file_path) ; - register_error_kind - `Permanent - ~id:"Per_block_vote_file.block_vote_file_invalid" - ~title: - "The provided block vote file path does not point to a valid JSON file." - ~description: - "A block vote file path was provided on the command line but the path \ - does not point to a valid JSON file." - ~pp:(fun ppf file_path -> - Format.fprintf - ppf - "@[The provided block vote file path \"%s\" does not point to a valid \ - JSON file. The file exists but its content is not valid JSON.@]" - file_path) - Data_encoding.(obj1 (req "file_path" string)) - (function Block_vote_file_invalid file_path -> Some file_path | _ -> None) - (fun file_path -> Block_vote_file_invalid file_path) ; - register_error_kind - `Permanent - ~id:"Per_block_vote_file.block_vote_file_wrong_content" - ~title:"The content of the provided block vote file is unexpected." - ~description: - "The block vote file is valid JSON but its content is not the expected \ - one." - ~pp:(fun ppf file_path -> - Format.fprintf - ppf - "@[The provided block vote file \"%s\" is a valid JSON file but its \ - content is unexpected. Expecting a JSON file containing \ - '{\"liquidity_baking_toggle_vote\": value1, \ - \"adaptive_issuance_vote\": value2}' or '{\"adaptive_issuance_vote\": \ - value1, \"liquidity_baking_toggle_vote\": value2}', where value1 is \ - one of \"on\", \"off\", or \"pass\" and value2 is one of \"on\", \ - \"off\", or \"pass\", or '{\"liquidity_baking_toggle_vote\": value}' \ - where value is one of \"on\", \"off\", or \"pass\".@]" - file_path) - Data_encoding.(obj1 (req "file_path" string)) - (function - | Block_vote_file_wrong_content file_path -> Some file_path | _ -> None) - (fun file_path -> Block_vote_file_wrong_content file_path) ; - register_error_kind - `Permanent - ~id: - "Per_block_vote_file.block_vote_file_missing_liquidity_baking_toggle_vote" - ~title: - "In the provided block vote file, no entry for liquidity baking toggle \ - vote was found" - ~description: - "In the provided block vote file, no entry for liquidity baking toggle \ - vote was found." - ~pp:(fun ppf file_path -> - Format.fprintf - ppf - "@[In the provided block vote file \"%s\", the \ - \"liquidity_baking_toggle_vote\" field is missing. Expecting a JSON \ - file containing '{\"liquidity_baking_toggle_vote\": value1, \ - \"adaptive_issuance_vote\": value2}' or '{\"adaptive_issuance_vote\": \ - value1, \"liquidity_baking_toggle_vote\": value2}', where value1 is \ - one of \"on\", \"off\", or \"pass\" and value2 is one of \"on\", \ - \"off\", or \"pass\", or '{\"liquidity_baking_toggle_vote\": value}' \ - where value is one of \"on\", \"off\", or \"pass\".@]" - file_path) - Data_encoding.(obj1 (req "file_path" string)) - (function - | Block_vote_file_missing_liquidity_baking_toggle_vote file_path -> - Some file_path - | _ -> None) - (fun file_path -> - Block_vote_file_missing_liquidity_baking_toggle_vote file_path) ; - register_error_kind - `Permanent - ~id:"Per_block_vote_file.missing_vote_on_startup" - ~title:"Missing vote on startup" - ~description: - "No CLI flag, file path, or votes file in default location provided on \ - startup" - ~pp:(fun fmt () -> - Format.fprintf - fmt - "Missing liquidity baking toggle vote, please use either the \ - --liquidity-baking-toggle-vote option, or the --votefile option or a \ - votes file in the default location: per_block_votes.json in the \ - current working directory or in the baker directory.") - Data_encoding.empty - (function Missing_vote_on_startup -> Some () | _ -> None) - (fun () -> Missing_vote_on_startup) - -type error += Failed_to_checkout_context - -type error += Invalid_context - -let () = - register_error_kind - `Permanent - ~id:"Client_baking_simulator.failed_to_checkout_context" - ~title:"Failed to checkout context" - ~description:"The given context hash does not exist in the context." - ~pp:(fun ppf () -> Format.fprintf ppf "Failed to checkout the context") - Data_encoding.unit - (function Failed_to_checkout_context -> Some () | _ -> None) - (fun () -> Failed_to_checkout_context) ; - register_error_kind - `Permanent - ~id:"Client_baking_simulator.invalid_context" - ~title:"Invalid context" - ~description:"Occurs when the context is inconsistent." - ~pp:(fun ppf () -> Format.fprintf ppf "The given context is invalid.") - Data_encoding.unit - (function Invalid_context -> Some () | _ -> None) - (fun () -> Invalid_context) - -type error += - | Unexpected_empty_block_list of { - chain : string; - block_hash : Block_hash.t; - length : int; - } - -let () = - register_error_kind - `Permanent - ~id:"Client_baking_blocks.unexpected_empty_block_list" - ~title:"Unexpected empty blocklist" - ~description: - "The block list retrieved by Shell_services.Blocks.list is empty" - ~pp:(fun ppf (chain, block_hash, length) -> - Format.fprintf - ppf - "Unexpected empty block list retrieved from chain %s at block %a, \ - length %d" - chain - Block_hash.pp - block_hash - length) - Data_encoding.( - obj3 - (req "chain" string) - (req "block_hash" Block_hash.encoding) - (req "length" int31)) - (function - | Unexpected_empty_block_list {chain; block_hash; length} -> - Some (chain, block_hash, length) - | _ -> None) - (fun (chain, block_hash, length) -> - Unexpected_empty_block_list {chain; block_hash; length}) - -(* DAL node related errors *) - -type error += No_dal_node_endpoint | Incompatible_dal_options - -let () = - register_error_kind - `Permanent - ~id:"Client_commands.no_dal_node_endpoint" - ~title:"Missing_dal_node_argument" - ~description:"Explicit DAL node configuration is required." - ~pp:(fun ppf () -> - Format.fprintf - ppf - "Please connect a running DAL node using '--dal-node '. If \ - you do not want to run a DAL node, you have to opt-out using \ - '--without-dal'.") - Data_encoding.unit - (function No_dal_node_endpoint -> Some () | _ -> None) - (fun () -> No_dal_node_endpoint) ; - register_error_kind - `Permanent - ~id:"Client_commands.incompatible_dal_options" - ~title:"Incompatible_dal_options" - ~description:"'--dal-node' and '--without-dal' are incompatible." - ~pp:(fun ppf () -> - Format.fprintf - ppf - "'--dal-node ' and '--without-dal' are incompatible. Please \ - do not pass '--without-dal' option.") - Data_encoding.unit - (function Incompatible_dal_options -> Some () | _ -> None) - (fun () -> Incompatible_dal_options) diff --git a/src/proto_020_PsParisC/lib_delegate/baking_events.ml b/src/proto_020_PsParisC/lib_delegate/baking_events.ml deleted file mode 100644 index 27a904d4c5db..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_events.ml +++ /dev/null @@ -1,1472 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context - -let section = [Protocol.name; "baker"] - -let pp_int32 fmt n = Format.fprintf fmt "%ld" n - -let pp_int64 fmt n = Format.fprintf fmt "%Ld" n - -let waiting_color = Internal_event.Magenta - -module Commands = struct - include Internal_event.Simple - - let section = section @ ["commands"] - - let node_version_check_bypass = - declare_0 - ~section - ~name:"node_version_check_bypass" - ~level:Warning - ~msg:"Compatibility between node version and baker version by passed" - () - - let node_version_check = - declare_4 - ~section - ~name:"node_version_check" - ~level:Debug - ~msg: - "Checking compatibility between node version {node_version} \ - ({node_commit}) and baker version {baker_version} ({baker_commit})" - ~pp1:Tezos_version.Version.pp_simple - ("node_version", Tezos_version.Octez_node_version.version_encoding) - ~pp2: - (Format.pp_print_option - Tezos_version.Octez_node_version.commit_info_pp_short) - ( "node_commit", - Data_encoding.option - Tezos_version.Octez_node_version.commit_info_encoding ) - ~pp3:Tezos_version.Version.pp_simple - ("baker_version", Tezos_version.Octez_node_version.version_encoding) - ~pp4: - (Format.pp_print_option - Tezos_version.Octez_node_version.commit_info_pp_short) - ( "baker_commit", - Data_encoding.option - Tezos_version.Octez_node_version.commit_info_encoding ) - - let no_dal_node_running = - declare_0 - ~section - ~name:"no_dal_node_running" - ~level:Warning - ~msg: - "No DAL node endpoint has been provided.\n\ - It will soon be required to launch a DAL node before running the \ - baker. For instructions on running a DAL node, please visit \ - https://docs.tezos.com/tutorials/join-dal-baker." - () - - let unhealthy_dal_node = - declare_2 - ~section - ~name:"unhealthy_dal_node" - ~level:Error - ~msg: - "The DAL node running on {endpoint} is not healthy. DAL attestations \ - cannot be sent.\n\ - Its health is {health}.\n\ - Please check your DAL node and possibly restart it." - ~pp1:Uri.pp - ("endpoint", Tezos_rpc.Encoding.uri_encoding) - ~pp2:Tezos_dal_node_services.Types.Health.pp - ("health", Tezos_dal_node_services.Types.Health.encoding) - - let unreachable_dal_node = - declare_1 - ~section - ~name:"unreachable_dal_node" - ~level:Error - ~msg: - "The DAL node cannot be reached on endpoint: {endpoint}.\n\ - Please check your DAL node and possibly restart it." - ~pp1:Uri.pp - ("endpoint", Tezos_rpc.Encoding.uri_encoding) - - let no_dal_deprecation = - declare_0 - ~section - ~name:"no_dal_deprecation" - ~level:Warning - ~msg: - "DEPRECATED: Please use a DAL node to launch a baker. If you purposely \ - do not run a DAL node, the option --without-dal will soon be \ - mandatory." - () -end - -module State_transitions = struct - include Internal_event.Simple - - let section = section @ ["transitions"] - - let new_valid_proposal = - declare_3 - ~section - ~name:"new_valid_proposal" - ~level:Notice - ~msg:"received new proposal {block} at level {level}, round {round}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("round", Round.encoding) - - let new_head = - declare_3 - ~section - ~name:"new_head" - ~level:Notice - ~msg:"received new head {block} at level {level}, round {round}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("round", Round.encoding) - - let new_head_with_increasing_level = - declare_0 - ~section - ~name:"new_head_with_increasing_level" - ~level:Info - ~msg:"received new head with level increasing" - () - - let new_forge_event = - let open Baking_state in - declare_1 - ~section - ~name:"new_forge_event" - ~level:Notice - ~msg:"received new forge event: {event}" - ~pp1:pp_forge_event - ("event", forge_event_encoding) - - let no_proposal_slot = - declare_3 - ~section - ~name:"no_proposal_slot" - ~level:Info - ~msg: - "end of round {current_round}; no proposal slot at level {level}, \ - round {next_round}" - ~pp1:Round.pp - ("current_round", Round.encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("next_round", Round.encoding) - - let proposal_slot = - declare_4 - ~section - ~name:"proposal_slot" - ~level:Info - ~msg: - "end of round {current_round}; proposal slot at level {level}, round \ - {next_round} for {delegate}" - ~pp1:Round.pp - ("current_round", Round.encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("next_round", Round.encoding) - ~pp4:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let new_head_while_waiting_for_qc = - declare_0 - ~section - ~name:"new_head_while_waiting_for_qc" - ~level:Info - ~msg:"received new head while waiting for a quorum" - () - - let applied_expected_proposal_received = - declare_1 - ~section - ~name:"applied_expected_proposal_received" - ~level:Info - ~msg:"received the expected application notice for {proposal}" - ~pp1:Block_hash.pp - ("proposal", Block_hash.encoding) - - let unexpected_new_head_while_waiting_for_application = - declare_0 - ~section - ~name:"unexpected_new_head_while_waiting_for_application" - ~level:Info - ~msg:"received new head while waiting for another proposal's application" - () - - let new_valid_proposal_while_waiting_for_qc = - declare_0 - ~section - ~name:"new_valid_proposal_while_waiting_for_qc" - ~level:Info - ~msg:"received new valid proposal while waiting for a quorum" - () - - let valid_proposal_received_after_application = - declare_0 - ~section - ~name:"valid_proposal_received_after_application" - ~level:Info - ~msg:"received valid proposal for a block already applied" - () - - let unexpected_proposal_round = - declare_2 - ~section - ~name:"unexpected_proposal_round" - ~level:Info - ~msg: - "unexpected proposal round, expected: {expected_round}, got: \ - {proposal_round}" - ~pp1:Round.pp - ("expected_round", Round.encoding) - ~pp2:Round.pp - ("proposal_round", Round.encoding) - - let proposal_for_round_already_seen = - declare_3 - ~section - ~name:"proposal_for_round_already_seen" - ~level:Warning - ~msg: - "proposal {new_proposal} for current round ({current_round}) has \ - already been seen {previous_proposal}" - ~pp1:Block_hash.pp - ("new_proposal", Block_hash.encoding) - ~pp2:Round.pp - ("current_round", Round.encoding) - ~pp3:Block_hash.pp - ("previous_proposal", Block_hash.encoding) - - let updating_latest_proposal = - declare_1 - ~section - ~name:"updating_latest_proposal" - ~msg:"updating latest proposal to {block_hash}" - ~level:Info - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let baker_is_ahead_of_node = - declare_2 - ~section - ~name:"baker_is_ahead" - ~level:Info - ~msg: - "baker (level: {baker_level}) is ahead of the node (level: \ - {node_level})" - ~pp1:pp_int32 - ("baker_level", Data_encoding.int32) - ~pp2:pp_int32 - ("node_level", Data_encoding.int32) - - let new_proposal_is_on_another_branch = - declare_2 - ~section - ~name:"new_proposal_is_on_another_branch" - ~level:Info - ~msg: - "received a proposal on another branch - current: current \ - pred{current_branch}, new pred {new_branch}" - ~pp1:Block_hash.pp - ("current_branch", Block_hash.encoding) - ~pp2:Block_hash.pp - ("new_branch", Block_hash.encoding) - - let switching_branch = - declare_0 - ~section - ~name:"switching_branch" - ~level:Info - ~msg:"switching branch" - () - - let branch_proposal_has_better_fitness = - declare_0 - ~section - ~name:"branch_proposal_has_better_fitness" - ~level:Info - ~msg:"different branch proposal has a better fitness than us" - () - - let branch_proposal_has_no_prequorum = - declare_0 - ~section - ~name:"branch_proposal_has_no_prequorum" - ~level:Info - ~msg:"different branch proposal has no prequorum but we do" - () - - let branch_proposal_has_lower_prequorum = - declare_0 - ~section - ~name:"branch_proposal_has_lower_prequorum" - ~level:Info - ~msg:"different branch proposal has a lower prequorum than us" - () - - let branch_proposal_has_better_prequorum = - declare_0 - ~section - ~name:"branch_proposal_has_better_prequorum" - ~level:Info - ~msg:"different branch proposal has a better prequorum" - () - - let branch_proposal_has_same_prequorum = - declare_0 - ~section - ~name:"branch_proposal_has_same_prequorum" - ~level:Error - ~msg:"different branch proposal has the same prequorum" - () - - let attempting_preattest_proposal = - declare_1 - ~section - ~name:"attempting_preattest_proposal" - ~level:Info - ~msg:"attempting to preattest proposal {block_hash}" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let attempting_vote_proposal = - declare_1 - ~section - ~name:"attempting_vote_proposal" - ~level:Info - ~msg:"attempting to vote for proposal {block_hash}" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let skipping_invalid_proposal = - declare_0 - ~section - ~name:"skipping_invalid_proposal" - ~level:Info - ~msg:"invalid proposal, skipping" - () - - let outdated_proposal = - declare_1 - ~section - ~name:"outdated_proposal" - ~level:Debug - ~msg:"outdated proposal {block_hash}" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let preparing_fresh_block = - declare_2 - ~section - ~name:"preparing_fresh_block" - ~level:Info - ~msg:"preparing fresh block for {delegate} at round {round}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:Round.pp - ("round", Round.encoding) - - let no_attestable_payload_fresh_block = - declare_0 - ~section - ~name:"no_attestable_payload_fresh_block" - ~level:Info - ~msg:"no attestable payload, proposing fresh block" - () - - let repropose_block = - declare_1 - ~section - ~name:"repropose_block" - ~level:Info - ~msg:"repropose block with payload {payload}" - ~pp1:Block_payload_hash.pp - ("payload", Block_payload_hash.encoding) - - let unexpected_prequorum_received = - declare_2 - ~section - ~name:"unexpected_prequorum_received" - ~level:Info - ~msg: - "unexpected prequorum received for {received_hash} instead of \ - {expected_hash}" - ~pp1:Block_hash.pp - ("received_hash", Block_hash.encoding) - ~pp2:Block_hash.pp - ("expected_hash", Block_hash.encoding) - - let unexpected_quorum_received = - declare_2 - ~section - ~name:"unexpected_quorum_received" - ~level:Info - ~msg: - "unexpected quorum received for {received_hash} instead of \ - {expected_hash}" - ~pp1:Block_hash.pp - ("received_hash", Block_hash.encoding) - ~pp2:Block_hash.pp - ("expected_hash", Block_hash.encoding) - - let step_current_phase = - declare_2 - ~section - ~name:"step_current_phase" - ~level:Debug - ~msg:"automaton step: current phase {phase}, event {event}" - ~pp1:Baking_state.pp_phase - ("phase", Baking_state.phase_encoding) - ~pp2:Baking_state.pp_event - ("event", Baking_state.event_encoding) - - let discarding_preattestation = - declare_3 - ~section - ~name:"discarding_preattestation" - ~level:Info - ~msg: - "discarding outdated preattestation for {delegate} at level {level}, \ - round {round}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("round", Round.encoding) - - let discarding_attestation = - declare_3 - ~section - ~name:"discarding_attestation" - ~level:Info - ~msg: - "discarding outdated attestation for {delegate} at level {level}, \ - round {round}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("round", Round.encoding) - - let discarding_unexpected_preattestation_with_different_payload = - declare_5 - ~section - ~name:"discarding_unexpected_preattestation_with_different_payload" - ~level:Warning - ~msg: - "discarding preattestation for {delegate} with payload {payload} at \ - level {level}, round {round} where the prequorum was locked on a \ - different payload {state_payload}." - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:Block_payload_hash.pp - ("payload", Block_payload_hash.encoding) - ~pp3:pp_int32 - ("level", Data_encoding.int32) - ~pp4:Round.pp - ("round", Round.encoding) - ~pp5:Block_payload_hash.pp - ("state_payload", Block_payload_hash.encoding) - - let discarding_unexpected_attestation_without_prequorum_payload = - declare_3 - ~section - ~name:"discarding_unexpected_attestation_without_prequorum" - ~level:Warning - ~msg: - "discarding attestation for {delegate} at level {level}, round {round} \ - where no prequorum was reached." - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("round", Round.encoding) - - let discarding_unexpected_attestation_with_different_prequorum_payload = - declare_5 - ~section - ~name:"discarding_unexpected_attestation_with_different_prequorum" - ~level:Warning - ~msg: - "discarding attestation for {delegate} with payload {payload} at level \ - {level}, round {round} where the prequorum was on a different payload \ - {state_payload}." - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:Block_payload_hash.pp - ("payload", Block_payload_hash.encoding) - ~pp3:pp_int32 - ("level", Data_encoding.int32) - ~pp4:Round.pp - ("round", Round.encoding) - ~pp5:Block_payload_hash.pp - ("state_payload", Block_payload_hash.encoding) - - let discarding_unexpected_prequorum_reached = - declare_2 - ~section - ~name:"discarding_unexpected_prequorum_reached" - ~level:Info - ~msg: - "discarding unexpected prequorum reached for {candidate} while in \ - {phase} phase." - ~pp1:Block_hash.pp - ("candidate", Block_hash.encoding) - ~pp2:Baking_state.pp_phase - ("phase", Baking_state.phase_encoding) - - let discarding_unexpected_quorum_reached = - declare_2 - ~section - ~name:"discarding_unexpected_quorum_reached" - ~level:Info - ~msg: - "discarding unexpected quorum reached for {candidate} while in {phase} \ - phase." - ~pp1:Block_hash.pp - ("candidate", Block_hash.encoding) - ~pp2:Baking_state.pp_phase - ("phase", Baking_state.phase_encoding) -end - -module Node_rpc = struct - include Internal_event.Simple - - let section = section @ ["rpc"] - - let error_while_monitoring_heads = - declare_1 - ~section - ~name:"error_while_monitoring_heads" - ~level:Error - ~msg:"error while monitoring heads {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let error_while_monitoring_valid_proposals = - declare_1 - ~section - ~name:"error_while_monitoring_valid_proposals" - ~level:Error - ~msg:"error while monitoring valid proposals {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) -end - -module Delegates = struct - include Internal_event.Simple - - let section = section @ ["delegates"] - - let delegates_used = - declare_1 - ~section - ~alternative_color:Internal_event.Cyan - ~name:"delegates_used" - ~level:Notice - ~msg:"Baker will run with the following delegates:\n {delegates}" - ~pp1: - (Format.pp_print_list - (fun fmt (delegate : Baking_state.consensus_key) -> - Format.fprintf fmt "%a" Baking_state.pp_consensus_key delegate)) - ("delegates", Data_encoding.list Baking_state.consensus_key_encoding) -end - -module Scheduling = struct - include Internal_event.Simple - - let section = section @ ["scheduling"] - - let error_while_baking = - declare_1 - ~section - ~name:"error_while_baking" - ~level:Warning - ~msg:"error while baking {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let waiting_for_new_head = - declare_0 - ~section - ~alternative_color:waiting_color - ~name:"waiting_for_new_head" - ~level:Info - ~msg:"no possible timeout, waiting for a new head to arrive..." - () - - let compute_next_timeout_elected_block = - declare_2 - ~section - ~name:"compute_next_timeout_elected_block" - ~level:Debug - ~msg: - "found an elected block at level {level}, round {round}... checking \ - baking rights" - ~pp1:pp_int32 - ("level", Data_encoding.int32) - ~pp2:Round.pp - ("round", Round.encoding) - - let proposal_already_injected = - declare_0 - ~section - ~name:"proposal_already_injected" - ~level:Debug - ~msg:"proposal already injected for next level, skipping..." - () - - let next_potential_slot = - declare_4 - ~section - ~name:"next_potential_slot" - ~level:Info - ~msg: - "next potential slot for level {level} is at round {round} at \ - {timestamp} for {delegate}" - ~pp1:pp_int32 - ("level", Data_encoding.int32) - ~pp2:Round.pp - ("round", Round.encoding) - ~pp3:Timestamp.pp - ("timestamp", Timestamp.encoding) - ~pp4:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let waiting_end_of_round = - declare_3 - ~section - ~alternative_color:waiting_color - ~name:"waiting_end_of_round" - ~level:Info - ~msg:"waiting {timespan} until end of round {round} at {timestamp}" - ~pp1:Ptime.Span.pp - ("timespan", Time.System.Span.encoding) - ~pp2:pp_int32 - ("round", Data_encoding.int32) - ~pp3:Timestamp.pp - ("timestamp", Timestamp.encoding) - - let waiting_delayed_end_of_round = - declare_4 - ~section - ~alternative_color:waiting_color - ~name:"waiting_delayed_end_of_round" - ~level:Info - ~msg: - "waiting {timespan} until {timestamp} (end of round {round} plus \ - {delay}s delay)" - ~pp1:Ptime.Span.pp - ("timespan", Time.System.Span.encoding) - ~pp2:pp_int32 - ("round", Data_encoding.int32) - ~pp3:Timestamp.pp - ("timestamp", Timestamp.encoding) - ~pp4:pp_int64 - ("delay", Data_encoding.int64) - - let waiting_time_to_bake = - declare_2 - ~section - ~alternative_color:waiting_color - ~name:"waiting_time_to_bake" - ~level:Info - ~msg:"waiting {timespan} until it's time to bake at {timestamp}" - ~pp1:Ptime.Span.pp - ("timespan", Time.System.Span.encoding) - ~pp2:Timestamp.pp - ("timestamp", Timestamp.encoding) - - let no_need_to_wait_for_proposal = - declare_0 - ~section - ~name:"no_need_to_wait_for_proposal" - ~level:Info - ~msg:"no need to wait to propose a block" - () - - let state_synchronized_to_round = - declare_1 - ~section - ~name:"state_synchronized_to_round" - ~level:Debug - ~msg:"state synchronized to round {round}" - ~pp1:Round.pp - ("round", Round.encoding) - - let proposal_in_the_future = - declare_1 - ~section - ~name:"proposal_in_the_future" - ~level:Debug - ~msg:"received proposal in the future {block_hash}" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let process_proposal_in_the_future = - declare_1 - ~section - ~name:"process_proposal_in_the_future" - ~level:Debug - ~msg:"process proposal received in the future with hash {block_hash}" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let waiting_to_forge_block = - declare_2 - ~section - ~alternative_color:waiting_color - ~name:"waiting_to_forge_block" - ~level:Info - ~msg:"waiting {timespan} until it's time to forge block at {timestamp}" - ~pp1:Ptime.Span.pp - ("timespan", Time.System.Span.encoding) - ~pp2:Timestamp.pp - ("timestamp", Timestamp.encoding) - - let no_need_to_wait_to_forge_block = - declare_0 - ~section - ~name:"no_need_to_wait_to_forge_block" - ~level:Info - ~msg:"no need to wait to forge a block" - () - - let first_baker_of_next_level = - declare_0 - ~section - ~name:"first_baker_of_next_level" - ~level:Info - ~msg: - "first baker of next level found among delegates. pre-emptively \ - forging block." - () -end - -module Lib = struct - include Internal_event.Simple - - let section = section @ ["lib"] - - let attempting_to_vote_for_proposal = - declare_2 - ~section - ~name:"attempting_preattest_proposal" - ~level:Debug - ~msg:"attempting to {action} proposal {proposal}" - ("action", Baking_state.consensus_vote_kind_encoding) - ~pp1:(fun fmt -> function - | Baking_state.Preattestation -> Format.fprintf fmt "preattest" - | Attestation -> Format.fprintf fmt "attest") - ("proposal", Baking_state.proposal_encoding) - ~pp2:Baking_state.pp_proposal - - let waiting_block_timestamp = - declare_2 - ~section - ~alternative_color:waiting_color - ~name:"waiting_block_timestamp" - ~level:Notice - ~msg:"Waiting {diff_time} until block timestamp {timestamp}" - ("timestamp", Time.Protocol.encoding) - ("diff_time", Time.System.Span.encoding) - ~pp1:Time.Protocol.pp_hum - ~pp2:Time.System.Span.pp_hum -end - -module Actions = struct - include Internal_event.Simple - - let section = section @ ["actions"] - - let skipping_consensus_vote = - declare_5 - ~section - ~name:"skipping_consensus_vote" - ~level:Error - ~msg: - "unable to sign {vote_kind} for {delegate} at level {level}, round \ - {round} -- {trace}" - ~pp1:Baking_state.pp_consensus_vote_kind - ("vote_kind", Baking_state.consensus_vote_kind_encoding) - ~pp2:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp3:pp_int32 - ("level", Data_encoding.int32) - ~pp4:Round.pp - ("round", Round.encoding) - ~pp5:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let failed_to_get_dal_attestations = - declare_2 - ~section - ~name:"failed_to_get_attestations" - ~level:Error - ~msg:"unable to get DAL attestation for {delegate} -- {trace}" - ("delegate", Signature.Public_key_hash.encoding) - ~pp2:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let failed_to_get_dal_attestations_in_time = - declare_1 - ~section - ~name:"failed_to_get_attestations_in_time" - ~level:Error - ~msg:"unable to get DAL attestation for {delegate} in time" - ("delegate", Signature.Public_key_hash.encoding) - - let failed_to_inject_consensus_vote = - declare_3 - ~section - ~name:"failed_to_inject_consensus_vote" - ~level:Error - ~msg:"failed to inject {vote_kind} for {delegate} -- {trace}" - ~pp1:Baking_state.pp_consensus_vote_kind - ("vote_kind", Baking_state.consensus_vote_kind_encoding) - ~pp2:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp3:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let failed_to_forge_block = - declare_2 - ~section - ~name:"failed_to_forge_block" - ~level:Error - ~msg:"failed to forge block for {delegate} -- {trace}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let potential_double_baking = - declare_2 - ~section - ~name:"potential_double_baking" - ~level:Warning - ~msg:"potential double baking detected at level {level}, round {round}" - ~pp1:pp_int32 - ~pp2:Round.pp - ("level", Data_encoding.int32) - ("round", Round.encoding) - - let consensus_vote_injected = - declare_5 - ~section - ~name:"consensus_vote_injected" - ~level:Notice - ~msg: - "injected {vote_kind} {ophash} for {delegate} for level {level}, round \ - {round}" - ~pp1:Baking_state.pp_consensus_vote_kind - ("vote_kind", Baking_state.consensus_vote_kind_encoding) - ~pp2:Operation_hash.pp - ("ophash", Operation_hash.encoding) - ~pp3:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp4:pp_int32 - ("level", Data_encoding.int32) - ~pp5:Round.pp - ("round", Round.encoding) - - let attach_dal_attestation = - declare_5 - ~section - ~name:"attach_dal_attestation" - ~level:Notice - ~msg: - "ready to attach DAL attestation for level {attestation_level}, round \ - {round}, with bitset {bitset} for {delegate} to attest slots \ - published at level {published_level}" - ("delegate", Signature.Public_key_hash.encoding) - ~pp2:Z.pp_print - ("bitset", Data_encoding.n) - ("published_level", Data_encoding.int32) - ("attestation_level", Data_encoding.int32) - ("round", Round.encoding) - - let warning_dal_timeout_old_round = - declare_0 - ~section - ~name:"warning_dal_timeout_old_round" - ~level:Warning - ~msg: - "The DAL timeout computed was for an old round. Please report this \ - issue." - () - - let not_in_dal_committee = - declare_2 - ~section - ~name:"not_in_dal_committee" - ~level:Notice - ~msg:"{delegate} has no assigned DAL shards at level {attestation_level}" - ("delegate", Signature.Public_key_hash.encoding) - ("attestation_level", Data_encoding.int32) - - let synchronizing_round = - declare_1 - ~section - ~name:"synchronizing_round" - ~level:Info - ~msg:"synchronizing round after block {block}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - - let prepare_forging_block = - declare_3 - ~section - ~name:"prepare_forging_block" - ~level:Debug - ~msg: - "prepare forging block at level {level}, round {round} for {delegate}" - ~pp1:pp_int32 - ~pp2:Round.pp - ~pp3:Baking_state.pp_consensus_key_and_delegate - ("level", Data_encoding.int32) - ("round", Round.encoding) - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let forging_block = - declare_3 - ~section - ~name:"forging_block" - ~level:Info - ~msg:"forging block at level {level}, round {round} for {delegate}" - ~pp1:pp_int32 - ~pp2:Round.pp - ~pp3:Baking_state.pp_consensus_key_and_delegate - ("level", Data_encoding.int32) - ("round", Round.encoding) - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let delayed_block_injection = - declare_4 - ~section - ~name:"delayed_block_injection" - ~level:Debug - ~msg: - "waiting {delay} before injecting block at level {level}, round \ - {round} for {delegate}" - ("delay", Time.System.Span.encoding) - ~pp1:Time.System.Span.pp_hum - ("level", Data_encoding.int32) - ~pp2:pp_int32 - ("round", Round.encoding) - ~pp3:Round.pp - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp4:Baking_state.pp_consensus_key_and_delegate - - let injecting_block = - declare_3 - ~section - ~name:"injecting_block" - ~level:Debug - ~msg:"injecting block at level {level}, round {round} for {delegate}" - ~pp1:pp_int32 - ~pp2:Round.pp - ~pp3:Baking_state.pp_consensus_key_and_delegate - ("level", Data_encoding.int32) - ("round", Round.encoding) - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let block_injected = - declare_5 - ~alternative_color:Internal_event.Blue - ~section - ~name:"block_injected" - ~level:Notice - ~msg: - "block {block} at level {level}, round {round} injected for \ - {delegate}{manager_operations_infos}" - ~pp1:Block_hash.pp - ~pp2:pp_int32 - ~pp3:Round.pp - ~pp4:Baking_state.pp_consensus_key_and_delegate - ~pp5: - (Format.pp_print_option - (fun fmt Baking_state.{manager_operation_number; total_fees} -> - Format.fprintf - fmt - " with %d manager operations summing %a μtz in fees" - manager_operation_number - pp_int64 - total_fees)) - ("block", Block_hash.encoding) - ("level", Data_encoding.int32) - ("round", Round.encoding) - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ( "manager_operations_infos", - Data_encoding.option Baking_state.manager_operations_infos_encoding ) - - let block_injection_failed = - declare_2 - ~section - ~name:"block_injection_failed" - ~level:Error - ~msg:"failed to inject block {block_hash} -- {trace}" - ("block_hash", Block_hash.encoding) - ~pp1:Block_hash.pp - ("trace", Error_monad.trace_encoding) - ~pp2:Error_monad.pp_print_trace - - let signing_consensus_vote = - declare_2 - ~section - ~name:"signing_consensus_vote" - ~level:Info - ~msg:"signing {vote_kind} for {delegate}" - ~pp1:Baking_state.pp_consensus_vote_kind - ("vote_kind", Baking_state.consensus_vote_kind_encoding) - ~pp2:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let invalid_json_file = - declare_1 - ~section - ~name:"invalid_json_file" - ~level:Warning - ~msg:"{filename} is not a valid JSON file" - ("filename", Data_encoding.string) - - let no_operations_found_in_file = - declare_1 - ~section - ~name:"no_operations_found_in_file" - ~level:Warning - ~msg:"no operations found in file {filename}" - ("filename", Data_encoding.string) - - let cannot_fetch_operations = - declare_1 - ~section - ~name:"cannot_fetch_operations" - ~level:Error - ~msg:"cannot fetch operations: {errs}" - ("errs", Error_monad.(TzTrace.encoding error_encoding)) - - let vote_for_liquidity_baking_toggle = - declare_1 - ~section - ~name:"vote_for_liquidity_baking_toggle" - ~level:Notice - ~msg:"Voting {value} for liquidity baking toggle vote" - ( "value", - Protocol.Alpha_context.Per_block_votes.liquidity_baking_vote_encoding ) - - let vote_for_adaptive_issuance = - declare_1 - ~section - ~name:"vote_for_adaptive_issuance" - ~level:Notice - ~msg:"Voting {value} for adaptive issuance vote" - ( "value", - Protocol.Alpha_context.Per_block_votes.adaptive_issuance_vote_encoding - ) - - let signature_timeout = - declare_1 - ~section - ~name:"signature_timeout" - ~level:Error - ~msg:"Signature call reached a timeout of {timeout}" - ("timeout", Data_encoding.float) - - let signature_error = - declare_1 - ~section - ~name:"signature_error" - ~level:Error - ~msg:"Signature call failed with {errors}" - ~pp1:pp_print_top_error_of_trace - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - - let delegates_without_slots = - declare_2 - ~section - ~name:"delegates_without_slots" - ~level:Notice - ~msg: - "The following delegates have no attesting rights at level {level}: \ - {delegates}" - ~pp1:(Format.pp_print_list Baking_state.pp_consensus_key) - ("delegates", Data_encoding.list Baking_state.consensus_key_encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - - let no_dal_node_running = Commands.no_dal_node_running -end - -module VDF = struct - include Internal_event.Simple - - let section = section @ ["vdf"] - - let vdf_revelation_injected = - declare_3 - ~section - ~name:"vdf_revelation_injected" - ~level:Notice - ~msg: - "Injected VDF revelation for cycle {cycle} (chain {chain} with \ - operation {ophash})" - ~pp1:pp_int32 - ("cycle", Data_encoding.int32) - ~pp2:Format.pp_print_string - ("chain", Data_encoding.string) - ~pp3:Operation_hash.pp - ("ophash", Operation_hash.encoding) - - let vdf_daemon_error = - declare_2 - ~section - ~name:"vdf_daemon_error" - ~level:Error - ~msg:"{worker}: error while running VDF daemon: {errors}" - ~pp1:Format.pp_print_string - ("worker", Data_encoding.string) - ~pp2:pp_print_top_error_of_trace - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - - let vdf_daemon_connection_lost = - declare_1 - ~section - ~name:"vdf_daemon_connection_lost" - ~level:Error - ~msg:"Connection to node lost, VDF daemon {worker} exiting" - ~pp1:Format.pp_print_string - ("worker", Data_encoding.string) - - let vdf_daemon_cannot_kill_computation = - declare_1 - ~section - ~name:"vdf_daemon_cannot_kill_computation" - ~level:Error - ~msg:"Error when killining running computation: {error}" - ~pp1:Format.pp_print_string - ("error", Data_encoding.string) - - let vdf_info = - declare_1 - ~section - ~name:"vdf_internal" - ~level:Notice - ~msg:"{msg}" - ~pp1:Format.pp_print_string - ("msg", Data_encoding.string) -end - -module Nonces = struct - include Internal_event.Simple - - let section = section @ ["nonces"] - - let found_nonce_to_reveal = - declare_2 - ~section - ~name:"found_nonce_to_reveal" - ~level:Notice - ~msg:"found nonce to reveal for block {block}, level {level}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - ~pp2:Raw_level.pp - ("level", Raw_level.encoding) - - let revealing_nonce = - declare_3 - ~alternative_color:Internal_event.Cyan - ~section - ~name:"revealing_nonce" - ~level:Notice - ~msg: - "revealing nonce of level {level} (chain {chain} with operation \ - {ophash})" - ~pp1:pp_int32 - ("level", Data_encoding.int32) - ~pp2:Format.pp_print_string - ("chain", Data_encoding.string) - ~pp3:Operation_hash.pp - ("ophash", Operation_hash.encoding) - - let cannot_fetch_chain_head_level = - declare_0 - ~section - ~name:"cannot_fetch_chain_head_level" - ~level:Error - ~msg:"cannot fetch chain head level, aborting nonces filtering" - () - - let incoherent_nonce = - declare_1 - ~section - ~name:"incoherent_nonce" - ~level:Error - ~msg:"incoherent nonce for level {level}" - ~pp1:(fun fmt -> Format.fprintf fmt "%a" Raw_level.pp) - ("level", Raw_level.encoding) - - let cannot_read_nonces = - declare_1 - ~section - ~name:"cannot_read_nonces" - ~level:Error - ~msg:"cannot read nonces {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let cannot_retrieve_unrevealed_nonces = - declare_1 - ~section - ~name:"cannot_retrieve_unrevealed_nonces" - ~level:Error - ~msg:"cannot retrieve unrevealed nonces {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let cannot_inject_nonces = - declare_1 - ~section - ~name:"cannot_inject_nonces" - ~level:Error - ~msg:"cannot inject nonces {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let cant_retrieve_block_header_for_nonce = - declare_2 - ~section - ~name:"cant_retrieve_block_header_for_nonce" - ~level:Warning - ~msg:"cannot retrieve block header {header} associated with nonce {trace}" - ("header", Data_encoding.string) - ~pp2:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let registering_nonce = - declare_1 - ~section - ~name:"registering_nonce" - ~level:Info - ~msg:"registering nonce for block {block}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - - let nothing_to_reveal = - declare_1 - ~section - ~name:"nothing_to_reveal" - ~level:Info - ~msg:"nothing to reveal for block {block}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - - let revelation_worker_started = - declare_0 - ~section - ~name:"revelation_worker_started" - ~level:Info - ~msg:"revelation worker started" - () - - let success_migrate_nonces = - declare_0 - ~section - ~name:"success_migrate_nonces" - ~level:Notice - ~msg:"successfully migrated nonces: legacy nonces are safe to delete" - () - - let ignore_failed_nonce_migration = - declare_3 - ~section - ~name:"ignore_failed_nonce_migration" - ~level:Warning - ~msg: - "Found orphaned nonces while migrating baking nonces to the new file \ - format. Please review the list of associated blocks. If the block is \ - older than the last cycle or if it was not included, the file at \ - '{legacy_nonces_file}' and '{orphaned_nonces_file}'should be archived \ - and then removed. If the block is in the current or last cycle, you \ - must start from a snapshot that is old enough to boostrap those \ - blocks to avoid losing some of your baking rewards. Blocks associated \ - with orphaned nonces:\n\ - {failed}" - ~pp1:(Format.pp_print_list Block_hash.pp) - ("failed", Data_encoding.list Block_hash.encoding) - ("legacy_nonces_file", Data_encoding.string) - ("orphaned_nonces_file", Data_encoding.string) - - let outdated_nonce = - declare_1 - ~section - ~name:"outdated_nonce" - ~level:Info - ~msg:"outdated nonce for block {block_hash} is safe to delete" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let unexpected_nonce = - declare_1 - ~section - ~name:"unexpected_nonce" - ~level:Info - ~msg:"unexpected nonce for block {block_hash} is safe to delete" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let revealed_nonce = - declare_1 - ~section - ~name:"revealed_nonce" - ~level:Info - ~msg:"revealed nonce for block {block_hash} is safe to delete" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let deterministic_nonce_timeout = - declare_1 - ~section - ~name:"deterministic_nonce_timeout" - ~level:Error - ~msg: - "Call to generate a deterministic nonce reached a timeout of {timeout}" - ("timeout", Data_encoding.float) - - let deterministic_nonce_error = - declare_1 - ~section - ~name:"deterministic_nonce_error" - ~level:Error - ~msg:"Call to deterministic nonce failed with {errors}" - ~pp1:pp_print_top_error_of_trace - ("errors", Error_monad.(TzTrace.encoding error_encoding)) -end - -module Per_block_votes = struct - include Internal_event.Simple - - let reading_per_block_votes = - declare_1 - ~section - ~name:"reading_per_block_votes" - ~level:Notice - ~msg:"reading votes file: {path}" - ("path", Data_encoding.string) - - let liquidity_baking_toggle_vote = - declare_1 - ~section - ~name:"read_liquidity_baking_toggle_vote" - ~level:Notice - ~msg:"read liquidity baking toggle vote = {value}" - ( "value", - Protocol.Alpha_context.Per_block_votes.liquidity_baking_vote_encoding ) - - let per_block_vote_file_fail = - declare_1 - ~section - ~name:"per_block_vote_file_error" - ~level:Error - ~msg:"Error reading the block vote file: {errors}" - ~pp1:pp_print_top_error_of_trace - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - - let adaptive_issuance_vote = - declare_1 - ~section - ~name:"read_adaptive_issuance_vote" - ~level:Notice - ~msg:"read adaptive issuance vote = {value}" - ( "value", - Protocol.Alpha_context.Per_block_votes.adaptive_issuance_vote_encoding - ) -end - -module Selection = struct - include Internal_event.Simple - - let section = section @ ["operation_selection"] - - let invalid_operation_filtered = - declare_2 - ~section - ~name:"invalid_operation_filtered" - ~level:Warning - ~msg:"filtered invalid operation {op}: {errors}" - ~pp1:Operation_hash.pp - ("op", Operation_hash.encoding) - ~pp2:pp_print_top_error_of_trace - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - - let cannot_serialize_operation_metadata = - declare_1 - ~section - ~name:"cannot_serialize_operation_metadata" - ~level:Warning - ~msg:"cannot serialize operation {op} metadata" - ~pp1:Operation_hash.pp - ("op", Operation_hash.encoding) -end - -module Forge_worker = struct - include Internal_event.Simple - - let section = section @ ["forge_worker"] - - let error_while_processing_forge_request = - declare_1 - ~section - ~name:"error_while_processing_forge_request" - ~level:Warning - ~msg:"error while processing forge request: {errors}" - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - ~pp1:pp_print_top_error_of_trace - - let error_while_authorizing_consensus_votes = - declare_1 - ~section - ~name:"error_while_authorizing_consensus_votes" - ~level:Error - ~msg:"error while authorizing consensus votes: {errors}" - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - ~pp1:pp_print_top_error_of_trace -end diff --git a/src/proto_020_PsParisC/lib_delegate/baking_files.ml b/src/proto_020_PsParisC/lib_delegate/baking_files.ml deleted file mode 100644 index 8b27b6668f89..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_files.ml +++ /dev/null @@ -1,41 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 = string - -type nonce_types = [`Legacy_nonce | `Stateful_nonce | `Orphaned_nonce] - -let resolve_location ~chain_id (kind : 'a) : 'a location = - let basename = - match kind with - | `Highwatermarks -> "highwatermark" - | `State -> "baker_state" - | `Legacy_nonce -> "nonce" - | `Stateful_nonce -> "stateful_nonce" - | `Orphaned_nonce -> "orphaned_nonce" - in - Format.asprintf "%a_%s" Chain_id.pp_short chain_id basename - -let filename x = x diff --git a/src/proto_020_PsParisC/lib_delegate/baking_files.mli b/src/proto_020_PsParisC/lib_delegate/baking_files.mli deleted file mode 100644 index ce58b7e66d2c..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_files.mli +++ /dev/null @@ -1,35 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 - -type nonce_types = [`Legacy_nonce | `Stateful_nonce | `Orphaned_nonce] - -val resolve_location : - chain_id:Chain_id.t -> - ([< `Highwatermarks | `State | nonce_types] as 'kind) -> - 'kind location - -val filename : [< `Highwatermarks | `State | nonce_types] location -> string diff --git a/src/proto_020_PsParisC/lib_delegate/baking_highwatermarks.ml b/src/proto_020_PsParisC/lib_delegate/baking_highwatermarks.ml deleted file mode 100644 index e9227a5d6f1a..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_highwatermarks.ml +++ /dev/null @@ -1,264 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol_client_context -open Protocol.Alpha_context - -type highwatermark = {round : Round.t; level : int32} - -let highwatermark_encoding : highwatermark Data_encoding.t = - let open Data_encoding in - conv - (fun {round; level} -> (round, level)) - (fun (round, level) -> {round; level}) - (obj2 - (req "round" Protocol.Alpha_context.Round.encoding) - (req "level" int32)) - -let pp_highwatermark fmt {round; level} = - Format.fprintf fmt "level: %ld, round: %a" level Round.pp round - -type error += Block_previously_baked of highwatermark - -type error += Block_previously_preattested of highwatermark - -type error += Block_previously_attested of highwatermark - -let () = - register_error_kind - `Permanent - ~id:"highwatermarks.block_previously_baked" - ~title:"Block previously baked" - ~description:"Trying to bake a block at a level previously baked" - ~pp:(fun ppf highwatermark -> - Format.fprintf - ppf - "A block with a higher watermark than the current one (%a) was \ - previously baked." - pp_highwatermark - highwatermark) - highwatermark_encoding - (function - | Block_previously_baked highwatermark -> Some highwatermark | _ -> None) - (fun highwatermark -> Block_previously_baked highwatermark) ; - register_error_kind - `Permanent - ~id:"highwatermarks.block_previously_preattested" - ~title:"Block previously preattested" - ~description:"Trying to preattest a block at a level previously preattested" - ~pp:(fun ppf highwatermark -> - Format.fprintf - ppf - "A preattestation with a higher watermark than the current one (%a) \ - was already produced." - pp_highwatermark - highwatermark) - highwatermark_encoding - (function - | Block_previously_preattested highwatermark -> Some highwatermark - | _ -> None) - (fun highwatermark -> Block_previously_preattested highwatermark) ; - register_error_kind - `Permanent - ~id:"highwatermarks.block_previously_attested" - ~title:"Block previously attested" - ~description:"Trying to attest a block at a level previously attested" - ~pp:(fun ppf highwatermark -> - Format.fprintf - ppf - "An attestation with a higher watermark than the current one (%a) was \ - already produced." - pp_highwatermark - highwatermark) - highwatermark_encoding - (function - | Block_previously_attested highwatermark -> Some highwatermark - | _ -> None) - (fun highwatermark -> Block_previously_attested highwatermark) - -module DelegateMap = Map.Make (struct - type t = Signature.Public_key_hash.t - - let compare = Signature.Public_key_hash.compare -end) - -let highwatermark_delegate_map_encoding = - let open Data_encoding in - conv - DelegateMap.bindings - DelegateMap.( - fun l -> List.fold_left (fun map (k, v) -> add k v map) empty l) - (list - (obj2 - (req "delegate" Signature.Public_key_hash.encoding) - (req "highwatermark" highwatermark_encoding))) - -type highwatermarks = { - blocks : highwatermark DelegateMap.t; - preattestations : highwatermark DelegateMap.t; - attestations : highwatermark DelegateMap.t; -} - -type t = highwatermarks - -let encoding = - let open Data_encoding in - conv - (fun {blocks; preattestations; attestations} -> - (blocks, preattestations, attestations)) - (fun (blocks, preattestations, attestations) -> - {blocks; preattestations; attestations}) - (obj3 - (req "blocks" highwatermark_delegate_map_encoding) - (req "preattestations" highwatermark_delegate_map_encoding) - (req "attestations" highwatermark_delegate_map_encoding)) - -let empty = - { - blocks = DelegateMap.empty; - preattestations = DelegateMap.empty; - attestations = DelegateMap.empty; - } - -(* We do not lock these functions. The caller will be already locked. *) -let load (cctxt : #Protocol_client_context.full) location : t tzresult Lwt.t = - protect (fun () -> - cctxt#load (Baking_files.filename location) encoding ~default:empty) - -let save_highwatermarks (cctxt : #Protocol_client_context.full) filename - highwatermarks : unit tzresult Lwt.t = - protect (fun () -> - (* TODO: improve the backend so we don't write partial informations *) - cctxt#write filename highwatermarks encoding) - -let may_sign highwatermarks ~delegate ~level ~round = - match DelegateMap.find delegate highwatermarks with - | None -> true - | Some highwatermark -> - if Compare.Int32.(highwatermark.level < level) then true - else if Compare.Int32.(highwatermark.level = level) then - Round.(highwatermark.round < round) - else false - -let may_sign_block cctxt (location : [`Highwatermarks] Baking_files.location) - ~delegate ~level ~round = - let open Lwt_result_syntax in - let* all_highwatermarks = load cctxt location in - return @@ may_sign all_highwatermarks.blocks ~delegate ~level ~round - -let may_sign_preattestation all_highwatermarks ~delegate ~level ~round = - may_sign all_highwatermarks.preattestations ~delegate ~level ~round - -let may_sign_attestation all_highwatermarks ~delegate ~level ~round = - may_sign all_highwatermarks.attestations ~delegate ~level ~round - -let record map ~delegate ~new_level ~new_round = - DelegateMap.update - delegate - (function - | None -> Some {level = new_level; round = new_round} - | Some ({level; round} as prev) -> - if Compare.Int32.(new_level > level) then - Some {level = new_level; round = new_round} - else if Compare.Int32.(new_level = level) then - if Round.(new_round > round) then - Some {level = new_level; round = new_round} - else Some prev - else Some prev) - map - -let record_block (cctxt : #Protocol_client_context.full) location ~delegate - ~level ~round = - let open Lwt_result_syntax in - let filename = Baking_files.filename location in - let* highwatermarks = load cctxt location in - let new_blocks = - record highwatermarks.blocks ~delegate ~new_level:level ~new_round:round - in - save_highwatermarks cctxt filename {highwatermarks with blocks = new_blocks} - -let record_preattestation (cctxt : #Protocol_client_context.full) location - ~delegate ~level ~round = - let open Lwt_result_syntax in - let filename = Baking_files.filename location in - let* highwatermarks = load cctxt location in - let new_preattestations = - record - highwatermarks.preattestations - ~delegate - ~new_level:level - ~new_round:round - in - save_highwatermarks - cctxt - filename - {highwatermarks with preattestations = new_preattestations} - -let record_attestation (cctxt : #Protocol_client_context.full) location - ~delegate ~level ~round = - let open Lwt_result_syntax in - let filename = Baking_files.filename location in - let* highwatermarks = load cctxt location in - let new_attestations = - record - highwatermarks.attestations - ~delegate - ~new_level:level - ~new_round:round - in - save_highwatermarks - cctxt - filename - {highwatermarks with attestations = new_attestations} - -let record_all_preattestations all_highwatermarks cctxt location ~delegates - ~level ~round = - let new_preattestations = - List.fold_left - (fun map delegate -> - record map ~delegate ~new_level:level ~new_round:round) - all_highwatermarks.preattestations - delegates - in - let filename = Baking_files.filename location in - save_highwatermarks - cctxt - filename - {all_highwatermarks with preattestations = new_preattestations} - -let record_all_attestations all_highwatermarks cctxt location ~delegates ~level - ~round = - let new_attestations = - List.fold_left - (fun map delegate -> - record map ~delegate ~new_level:level ~new_round:round) - all_highwatermarks.attestations - delegates - in - let filename = Baking_files.filename location in - save_highwatermarks - cctxt - filename - {all_highwatermarks with attestations = new_attestations} diff --git a/src/proto_020_PsParisC/lib_delegate/baking_highwatermarks.mli b/src/proto_020_PsParisC/lib_delegate/baking_highwatermarks.mli deleted file mode 100644 index 64b3bc50853d..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_highwatermarks.mli +++ /dev/null @@ -1,105 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol.Alpha_context - -type highwatermark = {round : Round.t; level : int32} - -type error += Block_previously_baked of highwatermark - -type error += Block_previously_preattested of highwatermark - -type error += Block_previously_attested of highwatermark - -type t - -val load : - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - t tzresult Lwt.t - -val may_sign_block : - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - bool tzresult Lwt.t - -val may_sign_preattestation : - t -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - bool - -val may_sign_attestation : - t -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - bool - -val record_block : - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - unit tzresult Lwt.t - -val record_preattestation : - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - unit tzresult Lwt.t - -val record_attestation : - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - unit tzresult Lwt.t - -val record_all_preattestations : - t -> - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegates:public_key_hash list -> - level:int32 -> - round:Round.t -> - unit tzresult Lwt.t - -val record_all_attestations : - t -> - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegates:public_key_hash list -> - level:int32 -> - round:Round.t -> - unit tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/baking_lib.ml b/src/proto_020_PsParisC/lib_delegate/baking_lib.ml deleted file mode 100644 index 7c997bbc4c0a..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_lib.ml +++ /dev/null @@ -1,807 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol -open Alpha_context -open Baking_state -module Events = Baking_events.Lib - -let sleep_until_block_timestamp prepared_block = - let open Lwt_syntax in - match - Baking_scheduling.sleep_until - prepared_block.signed_block_header.shell.timestamp - with - | Some waiter -> - let* () = - Events.( - emit - waiting_block_timestamp - ( prepared_block.signed_block_header.shell.timestamp, - Ptime.diff - (Time.System.of_protocol_exn - prepared_block.signed_block_header.shell.timestamp) - (Ptime_clock.now ()) )) - in - waiter - | None -> Lwt.return_unit - -let create_state cctxt ?synchronize ?monitor_node_mempool ~config - ~current_proposal delegates = - let open Lwt_result_syntax in - let chain = cctxt#chain in - let monitor_node_operations = monitor_node_mempool in - let* chain_id = Shell_services.Chain.chain_id cctxt ~chain () in - let* constants = - Alpha_services.Constants.all cctxt (`Hash chain_id, `Head 0) - in - - let*! operation_worker = - Operation_worker.create ?monitor_node_operations ~constants cctxt - in - Baking_scheduling.create_initial_state - cctxt - ?synchronize - ~chain - config - operation_worker - ~current_proposal - ~constants - delegates - -let get_current_proposal cctxt ?cache () = - let open Lwt_result_syntax in - let* block_stream, _block_stream_stopper = - Node_rpc.monitor_heads cctxt ?cache ~chain:cctxt#chain () - in - let*! current_head = Lwt_stream.peek block_stream in - match current_head with - | Some current_head -> return (block_stream, current_head) - | None -> failwith "head stream unexpectedly ended" - -let preattest (cctxt : Protocol_client_context.full) ?(force = false) delegates - = - let open State_transitions in - let open Lwt_result_syntax in - let*! () = Events.(emit Baking_events.Delegates.delegates_used delegates) in - let cache = Baking_cache.Block_cache.create 10 in - let* _, current_proposal = get_current_proposal cctxt ~cache () in - let config = Baking_configuration.make ~force () in - let* state = create_state cctxt ~config ~current_proposal delegates in - let proposal = state.level_state.latest_proposal in - let*! () = - Events.( - emit - attempting_to_vote_for_proposal - (Preattestation, state.level_state.latest_proposal)) - in - let* () = - if force then return_unit - else - let*! proposal_acceptance = - is_acceptable_proposal_for_current_level state proposal - in - match proposal_acceptance with - | Invalid -> cctxt#error "Cannot preattest an invalid proposal" - | Outdated_proposal -> cctxt#error "Cannot preattest an outdated proposal" - | Valid_proposal -> return_unit - in - let consensus_batch = - make_consensus_vote_batch state proposal Preattestation - in - let*! () = - cctxt#message - "@[Preattesting for:@ %a@]" - Format.( - pp_print_list - ~pp_sep:pp_print_space - Baking_state.pp_consensus_key_and_delegate) - (List.map - (fun ({delegate; _} : unsigned_consensus_vote) -> delegate) - consensus_batch.unsigned_consensus_votes) - in - let* signed_consensus_batch = - Baking_actions.sign_consensus_votes state.global_state consensus_batch - in - Baking_actions.inject_consensus_votes state signed_consensus_batch - -let attest (cctxt : Protocol_client_context.full) ?(force = false) delegates = - let open State_transitions in - let open Lwt_result_syntax in - let*! () = Events.(emit Baking_events.Delegates.delegates_used delegates) in - let cache = Baking_cache.Block_cache.create 10 in - let* _, current_proposal = get_current_proposal cctxt ~cache () in - let config = Baking_configuration.make ~force () in - let* state = create_state cctxt ~config ~current_proposal delegates in - let proposal = state.level_state.latest_proposal in - let*! () = - Events.( - emit - attempting_to_vote_for_proposal - (Attestation, state.level_state.latest_proposal)) - in - let* () = - if force then return_unit - else - let*! proposal_acceptance = - is_acceptable_proposal_for_current_level state proposal - in - match proposal_acceptance with - | Invalid -> cctxt#error "Cannot attest an invalid proposal" - | Outdated_proposal -> cctxt#error "Cannot attest an outdated proposal" - | Valid_proposal -> return_unit - in - let consensus_batch = make_consensus_vote_batch state proposal Attestation in - let*! () = - cctxt#message - "@[Attesting for:@ %a@]" - Format.( - pp_print_list - ~pp_sep:pp_print_space - Baking_state.pp_consensus_key_and_delegate) - (List.map - (fun ({delegate; _} : unsigned_consensus_vote) -> delegate) - consensus_batch.unsigned_consensus_votes) - in - let* signed_consensus_batch = - Baking_actions.sign_consensus_votes state.global_state consensus_batch - in - let* () = - Baking_state.may_record_new_state ~previous_state:state ~new_state:state - in - Baking_actions.inject_consensus_votes state signed_consensus_batch - -let do_action (state, action) = - let open Lwt_result_syntax in - let* new_state = Baking_actions.perform_action state action in - let* () = - Baking_state.may_record_new_state ~previous_state:state ~new_state - in - return new_state - -let bake_at_next_level_event state = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - let*! baking_time = - Baking_scheduling.compute_next_potential_baking_time_at_next_level state - in - match baking_time with - | None -> cctxt#error "No baking slot found for the delegates" - | Some (timestamp, round) -> - let*! () = - cctxt#message - "Waiting until %a for round %a" - Timestamp.pp - timestamp - Round.pp - round - in - let*! () = - Option.value - ~default:Lwt.return_unit - (Baking_scheduling.sleep_until timestamp) - in - return - (Baking_state.Timeout - (Time_to_prepare_next_level_block {at_round = round})) - -let bake_at_next_level state = - let open Lwt_result_syntax in - let* event = bake_at_next_level_event state in - let*! state, action = State_transitions.step state event in - match action with - | Prepare_block {block_to_bake} -> - let* prepared_block = - Baking_actions.prepare_block state.global_state block_to_bake - in - let*! () = sleep_until_block_timestamp prepared_block in - let* new_state = - do_action - ( state, - Inject_block - {prepared_block; force_injection = false; asynchronous = false} ) - in - return new_state - | _ -> assert false - -(* Simulate the end of the current round to bootstrap the automaton - or attest the block if necessary *) -let first_automaton_event state = - match state.level_state.elected_block with - | None -> Lwt.return (Baking_scheduling.compute_bootstrap_event state) - | Some _elected_block -> - (* If there is an elected block we can directly bake at next - level after waiting its date *) - bake_at_next_level_event state - -let attestations_attesting_power state attestations = - let get_attestation_voting_power {slot; _} = - match - Delegate_slots.voting_power state.level_state.delegate_slots ~slot - with - | None -> 0 (* cannot happen *) - | Some attesting_power -> attesting_power - in - List.sort_uniq compare attestations - |> List.fold_left - (fun power attestation -> - power + get_attestation_voting_power attestation) - 0 - -let generic_attesting_power (filter : packed_operation list -> 'a list) - (extract : 'a -> consensus_content) state = - let current_mempool = - Operation_worker.get_current_operations state.global_state.operation_worker - in - let latest_proposal = state.level_state.latest_proposal in - let block_round = latest_proposal.block.round in - let shell_level = latest_proposal.block.shell.level in - let attestations = - filter (Operation_pool.Operation_set.elements current_mempool.consensus) - in - let attestations_in_mempool = - List.filter_map - (fun v -> - let consensus_content = extract v in - if - Round.(consensus_content.round = block_round) - && Compare.Int32.( - Raw_level.to_int32 consensus_content.level = shell_level) - then Some consensus_content - else None) - attestations - in - let power = attestations_attesting_power state attestations_in_mempool in - (power, attestations) - -let state_attesting_power = - generic_attesting_power - Operation_pool.filter_attestations - (fun - ({ - protocol_data = - { - contents = Single (Attestation {consensus_content; dal_content = _}); - _; - }; - _; - } : - Kind.attestation operation) - -> consensus_content) - -let propose_at_next_level ~minimal_timestamp state = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - assert (Option.is_some state.level_state.elected_block) ; - if minimal_timestamp then - let* minimal_round, delegate = - match - Baking_scheduling.first_potential_round_at_next_level - state - ~earliest_round:Round.zero - with - | None -> cctxt#error "No potential baking slot for the given delegates." - | Some first_potential_round -> return first_potential_round - in - let pool = - Operation_worker.get_current_operations - state.global_state.operation_worker - in - let kind = Fresh pool in - let block_to_bake = - { - predecessor = state.level_state.latest_proposal.block; - round = minimal_round; - delegate; - kind; - force_apply = state.global_state.config.force_apply; - } - in - let* prepared_block = - Baking_actions.prepare_block state.global_state block_to_bake - in - let*! () = sleep_until_block_timestamp prepared_block in - let* state = - do_action - ( state, - Inject_block - { - prepared_block; - force_injection = minimal_timestamp; - asynchronous = false; - } ) - in - let*! () = - cctxt#message - "Proposed block at round %a on top of %a " - Round.pp - block_to_bake.round - Block_hash.pp - block_to_bake.predecessor.hash - in - return state - else - let* state = bake_at_next_level state in - let*! () = cctxt#message "Proposal injected" in - return state - -let attestation_quorum state = - let power, attestations = state_attesting_power state in - if - Compare.Int.( - power >= state.global_state.constants.parametric.consensus_threshold) - then Some (power, attestations) - else None - -(* Here's the sketch of the algorithm: - Do I have an attestation quorum for the current block or an elected block? - - Yes :: wait and propose at next level - - No :: - Is the current proposal at the right round? - - Yes :: fail propose - - No :: - Is there a preattestation quorum or does the last proposal contain a prequorum? - - Yes :: repropose block with right payload and preattestations for current round - - No :: repropose fresh block for current round *) -let propose (cctxt : Protocol_client_context.full) ?minimal_fees - ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?force_apply - ?(force = false) ?(minimal_timestamp = false) ?extra_operations - ?context_path ?state_recorder delegates = - let open Lwt_result_syntax in - let*! () = Events.(emit Baking_events.Delegates.delegates_used delegates) in - let cache = Baking_cache.Block_cache.create 10 in - let* _block_stream, current_proposal = get_current_proposal cctxt ~cache () in - let config = - Baking_configuration.make - ?minimal_fees - ?minimal_nanotez_per_gas_unit - ?minimal_nanotez_per_byte - ?context_path - ?force_apply - ~force - ?extra_operations - ?state_recorder - () - in - let* state = create_state cctxt ~config ~current_proposal delegates in - (* Make sure the operation worker is populated to avoid empty blocks - being proposed. *) - let* () = - Operation_worker.retrieve_pending_operations - cctxt - state.global_state.operation_worker - in - let* _ = - match state.level_state.elected_block with - | Some _ -> propose_at_next_level ~minimal_timestamp state - | None -> ( - match attestation_quorum state with - | Some (_voting_power, attestation_qc) -> - let state = - { - state with - round_state = - { - state.round_state with - current_phase = Baking_state.Awaiting_attestations; - }; - } - in - let latest_proposal = state.level_state.latest_proposal.block in - let candidate = - { - Operation_worker.hash = latest_proposal.hash; - round_watched = latest_proposal.round; - payload_hash_watched = latest_proposal.payload_hash; - } - in - let* state = - let*! action = - State_transitions.step - state - (Baking_state.Quorum_reached (candidate, attestation_qc)) - in - do_action action - (* this will register the elected block *) - in - propose_at_next_level ~minimal_timestamp state - | None -> ( - let*? event = Baking_scheduling.compute_bootstrap_event state in - let*! state, _action = State_transitions.step state event in - let latest_proposal = state.level_state.latest_proposal in - let open State_transitions in - let round = state.round_state.current_round in - let*! proposal_acceptance = - is_acceptable_proposal_for_current_level state latest_proposal - in - match proposal_acceptance with - | Invalid | Outdated_proposal -> ( - match round_proposer state ~level:`Current round with - | Some {consensus_key_and_delegate; _} -> - let*! action = - State_transitions.propose_block_action - state - consensus_key_and_delegate - round - ~last_proposal:state.level_state.latest_proposal - in - let* state = - match action with - | Prepare_block {block_to_bake} -> - let* prepared_block = - Baking_actions.prepare_block - state.global_state - block_to_bake - in - let*! () = - sleep_until_block_timestamp prepared_block - in - let* state = - do_action - ( state, - Inject_block - { - prepared_block; - force_injection = force; - asynchronous = false; - } ) - in - return state - | Inject_block {prepared_block; _} -> - let*! () = - sleep_until_block_timestamp prepared_block - in - let* state = - do_action - ( state, - Inject_block - { - prepared_block; - force_injection = force; - asynchronous = false; - } ) - in - return state - | _ -> assert false - in - let*! () = - cctxt#message - "Reproposed block at level %ld on round %a" - state.level_state.current_level - Round.pp - state.round_state.current_round - in - return state - | None -> cctxt#error "No slots for current round") - | Valid_proposal -> - cctxt#error - "Cannot propose: there's already a valid proposal for the \ - current round %a" - Round.pp - round)) - in - return_unit - -let repropose (cctxt : Protocol_client_context.full) ?(force = false) - ?force_round delegates = - let open Lwt_result_syntax in - let open Baking_state in - let*! () = Events.(emit Baking_events.Delegates.delegates_used delegates) in - let cache = Baking_cache.Block_cache.create 10 in - let* _block_stream, current_proposal = get_current_proposal cctxt ~cache () in - let config = Baking_configuration.make ~force () in - let* state = create_state cctxt ~config ~current_proposal delegates in - (* Make sure the operation worker is populated to avoid empty blocks - being proposed. *) - let*? event = Baking_scheduling.compute_bootstrap_event state in - let*! state, _action = State_transitions.step state event in - let latest_proposal = state.level_state.latest_proposal in - let open State_transitions in - let round = - match force_round with - | Some x -> x - | None -> state.round_state.current_round - in - let*! proposal_validity = - is_acceptable_proposal_for_current_level state latest_proposal - in - match proposal_validity with - | Invalid | Outdated_proposal -> ( - match Baking_state.round_proposer state ~level:`Current round with - | Some {consensus_key_and_delegate; _} -> - let*! action = - State_transitions.propose_block_action - state - consensus_key_and_delegate - round - ~last_proposal:state.level_state.latest_proposal - in - let* signed_block = - match action with - | Prepare_block {block_to_bake} -> - let* signed_block = - Baking_actions.prepare_block state.global_state block_to_bake - in - let*! () = sleep_until_block_timestamp signed_block in - let* _state = - do_action - ( state, - Inject_block - { - prepared_block = signed_block; - force_injection = force; - asynchronous = false; - } ) - in - return signed_block - | _ -> assert false - in - let*! () = - cctxt#message - "Reproposed block at level %ld on round %a" - signed_block.signed_block_header.shell.level - Round.pp - signed_block.round - in - return_unit - | None -> cctxt#error "No slots for current round") - | Valid_proposal -> - cctxt#error - "Cannot propose: there's already a valid proposal for the current \ - round %a" - Round.pp - round - -let bake_using_automaton ~count config state heads_stream = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - let* initial_event = first_automaton_event state in - let current_level = state.level_state.latest_proposal.block.shell.level in - let forge_event_stream = - state.global_state.forge_worker_hooks.get_forge_event_stream () - in - let loop_state = - Baking_scheduling.create_loop_state - ~heads_stream - ~forge_event_stream - state.global_state.operation_worker - in - let stop_on_next_level_block = function - | New_head_proposal proposal -> - Compare.Int32.( - proposal.block.shell.level >= Int32.(add current_level (of_int count))) - | _ -> false - in - let* event_opt = - Baking_scheduling.automaton_loop - ~stop_on_event:stop_on_next_level_block - ~config - ~on_error:(fun err -> Lwt.return (Error err)) - loop_state - state - initial_event - in - match event_opt with - | Some (New_head_proposal proposal) -> - let*! () = - cctxt#message - "Last injected block: %a (level %ld)" - Block_hash.pp - proposal.block.hash - proposal.block.shell.level - in - return_unit - | _ -> cctxt#error "Baking loop unexpectedly ended" - -(* attest the latest proposal and bake with it *) -let rec baking_minimal_timestamp ~count state - (block_stream : proposal Lwt_stream.t) = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - let latest_proposal = state.level_state.latest_proposal in - let own_attestations = - State_transitions.make_consensus_vote_batch - state - latest_proposal - Attestation - in - let current_mempool = - Operation_worker.get_current_operations state.global_state.operation_worker - in - let attestations_in_mempool = - Operation_pool.( - filter_attestations (Operation_set.elements current_mempool.consensus)) - |> List.filter_map - (fun - ({ - protocol_data = - {contents = Single (Attestation {consensus_content; _}); _}; - _; - } : - Kind.attestation operation) - -> - if - Round.(consensus_content.round = latest_proposal.block.round) - && Compare.Int32.( - Raw_level.to_int32 consensus_content.level - = latest_proposal.block.shell.level) - then Some consensus_content - else None) - in - let total_voting_power = - List.fold_left - (fun attestations own -> - own.Baking_state.vote_consensus_content :: attestations) - attestations_in_mempool - own_attestations.unsigned_consensus_votes - |> attestations_attesting_power state - in - let consensus_threshold = - state.global_state.constants.parametric.consensus_threshold - in - let* () = - if Compare.Int.(total_voting_power < consensus_threshold) then - cctxt#error - "Delegates do not have enough voting power. Only %d is available while \ - %d is required." - total_voting_power - consensus_threshold - else return_unit - in - let* minimal_round, delegate = - match - Baking_scheduling.first_potential_round_at_next_level - state - ~earliest_round:Round.zero - with - | None -> cctxt#error "No potential baking slot for the given delegates." - | Some first_potential_round -> return first_potential_round - in - let* signed_attestations = - let*! own_attestations_with_dal = - dal_content_map_p - (Baking_actions.may_get_dal_content state) - own_attestations - in - Baking_actions.sign_consensus_votes - state.global_state - own_attestations_with_dal - in - let pool = - Operation_pool.add_operations - current_mempool - (List.map - (fun signed_consensus -> signed_consensus.signed_operation) - signed_attestations.signed_consensus_votes) - in - let kind = Fresh pool in - let block_to_bake = - { - predecessor = latest_proposal.block; - round = minimal_round; - delegate; - kind; - force_apply = state.global_state.config.force_apply; - } - in - let* prepared_block = - Baking_actions.prepare_block state.global_state block_to_bake - in - let*! () = sleep_until_block_timestamp prepared_block in - let* new_state = - do_action - ( state, - Inject_block - {prepared_block; force_injection = true; asynchronous = false} ) - in - let*! () = cctxt#message "Injected block at minimal timestamp" in - if count <= 1 then return_unit - else - let*! () = - let attestation_level = Int32.succ latest_proposal.block.shell.level in - Lwt_stream.junk_while_s - (fun proposal -> - Lwt.return - Compare.Int32.( - proposal.Baking_state.block.shell.level <> attestation_level)) - block_stream - in - let*! next_level_proposal = - let*! r = Lwt_stream.get block_stream in - match r with - | None -> cctxt#error "Stream unexpectedly ended" - | Some b -> Lwt.return b - in - let*! new_state, action = - State_transitions.step new_state (New_head_proposal next_level_proposal) - in - let* new_state = - match action with - | Update_to_level update -> - let* new_state, _preattest_action = - Baking_actions.update_to_level new_state update - in - return - { - new_state with - round_state = - { - Baking_state.current_round = Round.zero; - current_phase = Idle; - delayed_quorum = None; - early_attestations = []; - awaiting_unlocking_pqc = false; - }; - } - | _ -> - (* Algorithmically, this will always be an update_to_level - action. *) - assert false - in - baking_minimal_timestamp ~count:(pred count) new_state block_stream - -let bake (cctxt : Protocol_client_context.full) ?minimal_fees - ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?force_apply ?force - ?(minimal_timestamp = false) ?extra_operations - ?(monitor_node_mempool = true) ?context_path ?dal_node_endpoint ?(count = 1) - ?votes ?state_recorder delegates = - let open Lwt_result_syntax in - let*! () = Events.(emit Baking_events.Delegates.delegates_used delegates) in - let config = - Baking_configuration.make - ?minimal_fees - ?minimal_nanotez_per_gas_unit - ?minimal_nanotez_per_byte - ?context_path - ?force_apply - ?force - ?extra_operations - ?dal_node_endpoint - ?votes - ?state_recorder - () - in - let cache = Baking_cache.Block_cache.create 10 in - let* block_stream, current_proposal = get_current_proposal cctxt ~cache () in - let* state = - create_state - cctxt - ~monitor_node_mempool - ~synchronize:(not minimal_timestamp) - ~config - ~current_proposal - delegates - in - let* () = - when_ monitor_node_mempool (fun () -> - (* Make sure the operation worker is populated to avoid empty - blocks being baked *) - Operation_worker.retrieve_pending_operations - cctxt - state.global_state.operation_worker) - in - if not minimal_timestamp then - bake_using_automaton ~count config state block_stream - else baking_minimal_timestamp ~count state block_stream diff --git a/src/proto_020_PsParisC/lib_delegate/baking_lib.mli b/src/proto_020_PsParisC/lib_delegate/baking_lib.mli deleted file mode 100644 index 6805daf9ae17..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_lib.mli +++ /dev/null @@ -1,84 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol.Alpha_context - -(** {1 API} *) - -val bake : - Protocol_client_context.full -> - ?minimal_fees:Tez.t -> - ?minimal_nanotez_per_gas_unit:Q.t -> - ?minimal_nanotez_per_byte:Q.t -> - ?force_apply:bool -> - ?force:bool -> - ?minimal_timestamp:bool -> - ?extra_operations:Baking_configuration.Operations_source.t -> - ?monitor_node_mempool:bool -> - ?context_path:string -> - ?dal_node_endpoint:Uri.t -> - (* Number of baked blocks. Defaults to 1. *) - ?count:int -> - ?votes:Baking_configuration.per_block_votes_config -> - ?state_recorder:Baking_configuration.state_recorder_config -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t - -val preattest : - Protocol_client_context.full -> - ?force:bool -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t - -val attest : - Protocol_client_context.full -> - ?force:bool -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t - -val propose : - Protocol_client_context.full -> - ?minimal_fees:Tez.t -> - ?minimal_nanotez_per_gas_unit:Q.t -> - ?minimal_nanotez_per_byte:Q.t -> - ?force_apply:bool -> - ?force:bool -> - ?minimal_timestamp:bool -> - ?extra_operations:Baking_configuration.Operations_source.t -> - ?context_path:string -> - ?state_recorder:Baking_configuration.state_recorder_config -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t - -(** [repropose] tries to bake a new block proposal on the same level - as the current head. If provided, the proposal will use the - [force_round] argument as its reproposal round, otherwise the - current tenderbake round will be used. *) -val repropose : - Protocol_client_context.full -> - ?force:bool -> - ?force_round:Round.t -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml b/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml deleted file mode 100644 index 78075f8ff096..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_nonces.ml +++ /dev/null @@ -1,672 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* Copyright (c) 2024 TriliTech *) -(* *) -(* 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 Events = Baking_events.Nonces - -module Profiler = (val Profiler.wrap Baking_profiler.nonce_profiler) - -type state = { - cctxt : Protocol_client_context.full; - chain : Chain_services.chain; - constants : Constants.t; - config : Baking_configuration.nonce_config; - legacy_location : [`Legacy_nonce] Baking_files.location; - stateful_location : [`Stateful_nonce] Baking_files.location; - orphaned_location : [`Orphaned_nonce] Baking_files.location; - mutable last_predecessor : Block_hash.t; -} - -type t = state - -(** [nonce_state] tracks the current state of committed nonces. It is used to - optimise nonce processing by further reducing queries for nonce metadata. *) -type nonce_state = - | Committed - (** [Committed] is initial state and signals that the nonce was committed at - some cycle: - - If baker in current cycle: do nothing - - If baker in cycle + 1: - - If block with commitment is part of the - cannonical chain: then transition to injected - - else: safe to delete - - If current cycle > cycle + 1: too stale, so safe to delete *) - | Revealed of Raw_level.t - (** [Revealed] signals that the nonce revelation operation was injected at - [injected_level] - - At each level, get the last finalized block (level - 2) - - If the revelation operation found in that block: nonce is safe to - delete - - If not found: - - If pass `re_injection_threshold`: - - consider revelation operation lost, so re-inject - - transition to injected with updated level - - If pass `nonce_revelation_threshold`: - - missed out revelation operation, so delete - - else: do nothing *) - -type nonce_data = { - nonce : Nonce.t; - nonce_hash : Nonce_hash.t; - block_hash : Block_hash.t; (* Keep around for legacy purposes *) - cycle : Cycle.t; - level : Raw_level.t; - round : Round.t option; - nonce_state : nonce_state; -} - -type nonces = nonce_data Nonce_hash.Map.t - -let empty = Nonce_hash.Map.empty - -let legacy_empty = Block_hash.Map.empty - -let reinjection_threshold = 2l - -let nonce_state_encoding = - let open Data_encoding in - union - [ - case - (Tag 0) - ~title:"Committed" - (constant "committed") - (function Committed -> Some () | _ -> None) - (fun () -> Committed); - case - (Tag 1) - ~title:"Revealed" - (obj1 (req "injection_level" Raw_level.encoding)) - (function - | Revealed injection_level -> Some injection_level | _ -> None) - (fun injection_level -> Revealed injection_level); - ] - -let nonce_data_encoding = - let open Data_encoding in - def "nonce_data" - @@ conv - (fun {nonce; nonce_hash; block_hash; cycle; level; round; nonce_state} -> - (nonce, nonce_hash, block_hash, cycle, level, round, nonce_state)) - (fun (nonce, nonce_hash, block_hash, cycle, level, round, nonce_state) -> - {nonce; nonce_hash; block_hash; cycle; level; round; nonce_state}) - (obj7 - (req "nonce" Nonce.encoding) - (req "hash" Nonce_hash.encoding) - (req "block" Block_hash.encoding) - (req "cycle" Cycle.encoding) - (req "level" Raw_level.encoding) - (opt "round" Round.encoding) - (req "state" nonce_state_encoding)) - -let legacy_encoding = - let open Data_encoding in - def "legacy_seed_nonce" - @@ conv - (fun m -> - Block_hash.Map.fold (fun hash nonce acc -> (hash, nonce) :: acc) m []) - (fun l -> - List.fold_left - (fun map (hash, nonce) -> Block_hash.Map.add hash nonce map) - Block_hash.Map.empty - l) - @@ list (obj2 (req "block" Block_hash.encoding) (req "nonce" Nonce.encoding)) - -let encoding = - let open Data_encoding in - def "seed_nonce" - @@ conv - (fun m -> - Nonce_hash.Map.fold - (fun _hash nonce_data acc -> nonce_data :: acc) - m - []) - (fun l -> - List.fold_left - (fun map data -> Nonce_hash.Map.add data.nonce_hash data map) - Nonce_hash.Map.empty - l) - @@ list nonce_data_encoding - -let load (wallet : #Client_context.wallet) - ~(stateful_location : [`Stateful_nonce] Baking_files.location) = - let location = Baking_files.filename stateful_location in - wallet#load location ~default:empty encoding - -let save (wallet : #Client_context.wallet) - ~(legacy_location : [`Legacy_nonce] Baking_files.location) - ~(stateful_location : [`Stateful_nonce] Baking_files.location) - ~(orphaned_location : [`Orphaned_nonce] Baking_files.location) nonces = - let open Lwt_result_syntax in - let legacy_location = Baking_files.filename legacy_location in - let stateful_location = Baking_files.filename stateful_location in - let orphaned_location = Baking_files.filename orphaned_location in - (* We always write in both files *) - let* () = wallet#write stateful_location nonces encoding in - (* Merge current nonces and orphaned nonces (if exists) before writing to - legacy nonce file *) - let* orphaned_nonces = - wallet#load orphaned_location ~default:legacy_empty legacy_encoding - in - let legacy_nonces = - Nonce_hash.Map.fold - (fun _ {nonce; block_hash; _} legacy_nonces -> - Block_hash.Map.add block_hash nonce legacy_nonces) - nonces - orphaned_nonces - in - wallet#write legacy_location legacy_nonces legacy_encoding - -let add nonces nonce = Nonce_hash.Map.add nonce.nonce_hash nonce nonces - -let is_outdated constants committed_cycle current_cycle = - let {Constants.parametric = {consensus_rights_delay; _}; _} = constants in - Int32.sub (Cycle.to_int32 current_cycle) (Cycle.to_int32 committed_cycle) - > Int32.of_int consensus_rights_delay - -(** [try_migrate_legacy_nonces] makes a best effort to migrate nonces in the legacy format - to new format. Legacy nonces that cannot be migrated are dropped. No updates to the legacy - file are made *) -let try_migrate_legacy_nonces state = - let { - cctxt; - chain; - legacy_location; - stateful_location; - orphaned_location; - constants; - _; - } = - state - in - let legacy_location = Baking_files.filename legacy_location in - let migrate () = - let open Lwt_result_syntax in - let* legacy_nonces = - cctxt#load legacy_location ~default:legacy_empty legacy_encoding - in - let new_location = Baking_files.filename stateful_location in - let* nonces = cctxt#load new_location ~default:empty encoding in - let* {cycle = current_cycle; _} = - Plugin.RPC.current_level cctxt (chain, `Head 0) - in - let*! nonces, failed_migration = - Block_hash.Map.fold_s - (fun block_hash nonce (existing_nonces, failed_migration) -> - let*! updated_nonces = - if Nonce_hash.Map.mem (Nonce.hash nonce) existing_nonces then - (* Current nonce already exists in the new format, no migration needed. *) - return existing_nonces - else - let* {cycle = nonce_cycle; level = nonce_level; _} = - Plugin.RPC.current_level cctxt (chain, `Hash (block_hash, 0)) - in - match is_outdated constants nonce_cycle current_cycle with - | true -> - let*! () = Events.(emit outdated_nonce block_hash) in - return existing_nonces - | false -> ( - let* nonce_info = - Alpha_services.Nonce.get cctxt (chain, `Head 0) nonce_level - in - match nonce_info with - | Missing nonce_hash when Nonce.check_hash nonce nonce_hash -> - (* If a nonce is found locally but revelation not in context, - assume that it is [Committed] and not already [Revealed]. - In the case that it is already in mempool, the mempool - will reject the operation. *) - let data = - { - nonce; - nonce_hash = Nonce.hash nonce; - block_hash; - cycle = nonce_cycle; - level = nonce_level; - round = None; - nonce_state = Committed; - } - in - return - (Nonce_hash.Map.add - data.nonce_hash - data - existing_nonces) - | Missing _nonce_hash -> - let*! () = Events.(emit unexpected_nonce block_hash) in - return existing_nonces - | Revealed _nonce_hash -> - let*! () = Events.(emit revealed_nonce block_hash) in - return existing_nonces - | Forgotten -> return existing_nonces) - in - Lwt.return - (match updated_nonces with - | Ok updated_nonces -> (updated_nonces, failed_migration) - | Error _ -> - ( existing_nonces, - Block_hash.Map.add block_hash nonce failed_migration ))) - legacy_nonces - (nonces, legacy_empty) - in - let* () = cctxt#write new_location nonces encoding in - let+ () = - if Block_hash.Map.is_empty failed_migration then return_unit - else - let orphaned_location = Baking_files.filename orphaned_location in - state.cctxt#write orphaned_location failed_migration legacy_encoding - in - failed_migration - in - let open Lwt_syntax in - let* res = migrate () in - match res with - | Ok failed_migration when Block_hash.Map.is_empty failed_migration -> - Events.(emit success_migrate_nonces ()) - | Ok failed_migration -> - let failed_block_hashes = - Block_hash.Map.fold - (fun block_hash _ acc -> block_hash :: acc) - failed_migration - [] - in - let legacy_filename = - Filename.concat cctxt#get_base_dir legacy_location - in - let orphaned_location = Baking_files.filename orphaned_location in - let orphaned_filename = - Filename.concat cctxt#get_base_dir orphaned_location - in - Events.( - emit - ignore_failed_nonce_migration - (failed_block_hashes, legacy_filename, orphaned_filename)) - | Error _ -> return_unit - -(** [partition_unrevealed_nonces state nonces current_cycle current_level] partitions - nonces into 2 groups: - - nonces that need to be re/revealed - - nonces that are live - Nonces that are not relevant can be dropped. -*) -let partition_unrevealed_nonces {cctxt; chain; _} nonces current_cycle - current_level = - let open Lwt_result_syntax in - match Cycle.pred current_cycle with - | None -> - (* This will be [None] iff [current_cycle = 0] which only - occurs during genesis. *) - return (empty, nonces) - | Some previous_cycle -> - (* Partition nonces into nonces that need to be re/injected and - those that do not. *) - Nonce_hash.Map.fold_es - (fun _hash nonce_data (nonces_to_reveal, live) -> - let {nonce_hash; cycle; level; nonce_state; _} = nonce_data in - match cycle with - | cycle when Cycle.(cycle = previous_cycle) -> ( - (* Only process nonces that are part of previous cycle. *) - let+ nonce_info = - (Alpha_services.Nonce.get - cctxt - (chain, `Head 0) - level - [@profiler.aggregate_s - {verbosity = Debug} "get nonce information"]) - in - match (nonce_state, nonce_info) with - | Committed, Missing expected_nonce_hash - when Nonce_hash.(nonce_hash = expected_nonce_hash) -> - (* Nonce was committed and block is part of main chain *) - (add nonces_to_reveal nonce_data, live) - | Committed, _ -> - (* Nonce was committed but block is not part of main chain *) - (nonces_to_reveal, live) - | Revealed injection_level, Missing expected_nonce_hash - when Nonce_hash.(nonce_hash = expected_nonce_hash) -> - if - Raw_level.diff current_level injection_level - > reinjection_threshold - then - (* [reinjection_threshold] levels have passed since nonce revelation - was injected. It might have been lost so reinject. *) - (add nonces_to_reveal nonce_data, live) - else - (* We are waiting for nonce revelation to be included. *) - (nonces_to_reveal, add live nonce_data) - | Revealed _injection_level, Missing _ - | Revealed _injection_level, Forgotten - | Revealed _injection_level, Revealed _ -> - (nonces_to_reveal, live)) - | cycle when Cycle.(cycle = current_cycle) -> - (* Nothing to do if nonce was committed as part of current - cycle. *) - return (nonces_to_reveal, add live nonce_data) - | _ -> - (* Nonces not part of current or previous cycles are orphaned and can - be dropped. *) - return (nonces_to_reveal, live)) - nonces - (empty, empty) - -(* Nonce creation *) - -let generate_deterministic_nonce ?timeout secret_key_uri data = - let open Lwt_result_syntax in - let*! result = - match timeout with - | None -> - let*! res = Client_keys.deterministic_nonce secret_key_uri data in - Lwt.return (`Nonce_result res) - | Some timeout -> - Lwt.pick - [ - (let*! () = Lwt_unix.sleep timeout in - Lwt.return (`Nonce_timeout timeout)); - (let*! nonce = - Client_keys.deterministic_nonce secret_key_uri data - in - Lwt.return (`Nonce_result nonce)); - ] - in - match result with - | `Nonce_timeout timeout -> - let*! () = Events.(emit deterministic_nonce_timeout timeout) in - tzfail (Baking_errors.Deterministic_nonce_timeout timeout) - | `Nonce_result (Error errs) -> - let*! () = Events.(emit deterministic_nonce_error errs) in - Lwt.return (Error errs) - | `Nonce_result (Ok nonce) -> - return (Data_encoding.Binary.of_bytes_exn Nonce.encoding nonce) - -let generate_seed_nonce ?timeout - (nonce_config : Baking_configuration.nonce_config) - (delegate : Baking_state.consensus_key) level = - let open Lwt_result_syntax in - let* nonce = - match nonce_config with - | Deterministic -> - let data = Data_encoding.Binary.to_bytes_exn Raw_level.encoding level in - generate_deterministic_nonce ?timeout delegate.secret_key_uri data - | Random -> ( - match - Nonce.of_bytes (Tezos_crypto.Rand.generate Constants.nonce_length) - with - | Error _errs -> assert false - | Ok nonce -> return nonce) - in - return (Nonce.hash nonce, nonce) - -let register_nonce (cctxt : #Protocol_client_context.full) ~chain_id block_hash - nonce ~cycle ~level ~round = - let open Lwt_result_syntax in - (let*! () = Events.(emit registering_nonce block_hash) in - (* Register the nonce *) - let legacy_location = - Baking_files.resolve_location ~chain_id `Legacy_nonce - in - let stateful_location = - Baking_files.resolve_location ~chain_id `Stateful_nonce - in - let orphaned_location = - Baking_files.resolve_location ~chain_id `Orphaned_nonce - in - () [@profiler.record_f {verbosity = Info} "waiting lock"] ; - cctxt#with_lock @@ fun () -> - let* nonces = - (load - cctxt - ~stateful_location [@profiler.record_s {verbosity = Info} "load nonces"]) - in - let nonces = - (add - nonces - { - nonce; - nonce_hash = Nonce.hash nonce; - block_hash; - cycle; - level; - round = Some round; - nonce_state = Committed; - } [@profiler.record_f {verbosity = Info} "add nonces"]) - in - (save - cctxt - ~legacy_location - ~stateful_location - nonces - ~orphaned_location [@profiler.record_s {verbosity = Info} "save nonces"])) - [@profiler.record_s {verbosity = Notice} "register nonce"] - -(** [inject_seed_nonce_revelation cctxt ~chain ~block ~branch nonces] forges one - [Seed_nonce_revelation] operation per each nonce to be revealed, together with - a signature and then injects these operations. *) -let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain - ~block ~branch nonces = - let open Lwt_result_syntax in - match nonces with - | [] -> - let*! () = Events.(emit nothing_to_reveal branch) in - return_unit - | _ -> - List.iter_es - (fun (level, nonce) -> - let* bytes = - (Plugin.RPC.Forge.seed_nonce_revelation - cctxt - (chain, block) - ~branch - ~level - ~nonce - () - [@profiler.aggregate_s - {verbosity = Debug} "forge seed nonce revelation"]) - in - let bytes = Signature.concat bytes Signature.zero in - let* oph = - (Shell_services.Injection.operation - ~async:true - cctxt - ~chain - bytes - [@profiler.aggregate_s - {verbosity = Debug} "inject seed nonce revelation"]) - in - let*! () = - Events.( - emit - revealing_nonce - (Raw_level.to_int32 level, Chain_services.to_string chain, oph)) - in - return_unit) - nonces - -(** [reveal_potential_nonces state new_proposal] updates the internal [state] - of the worker each time a proposal with a new predecessor is received; this means - revealing the necessary nonces. *) -let reveal_potential_nonces state new_proposal = - let open Lwt_result_syntax in - let { - cctxt; - chain; - legacy_location; - stateful_location; - orphaned_location; - last_predecessor; - _; - } = - state - in - let new_predecessor_hash = new_proposal.Baking_state.predecessor.hash in - if - Block_hash.(last_predecessor <> new_predecessor_hash) - && not (Baking_state.is_first_block_in_protocol new_proposal) - then ( - (* only try revealing nonces when the proposal's predecessor is a new one *) - state.last_predecessor <- new_predecessor_hash ; - let block = `Head 0 in - let branch = new_predecessor_hash in - (* improve concurrency *) - () [@profiler.record_f {verbosity = Info} "waiting lock"] ; - cctxt#with_lock @@ fun () -> - let*! nonces = - (load - cctxt - ~stateful_location - [@profiler.record_s {verbosity = Info} "load nonce file"]) - in - match nonces with - | Error err -> - let*! () = Events.(emit cannot_read_nonces err) in - return_unit - | Ok nonces -> ( - let* {cycle; level; _} = - Plugin.RPC.current_level cctxt (chain, `Head 0) - in - let*! partitioned_nonces = - (partition_unrevealed_nonces - state - nonces - cycle - level - [@profiler.record_s {verbosity = Info} "partition unrevealed nonces"]) - in - match partitioned_nonces with - | Error err -> - let*! () = Events.(emit cannot_retrieve_unrevealed_nonces err) in - return_unit - | Ok (nonces_to_reveal, live_nonces) -> ( - if Nonce_hash.Map.is_empty nonces_to_reveal then return_unit - else - let prepared_nonces = - Nonce_hash.Map.fold - (fun _ {level; nonce; _} acc -> (level, nonce) :: acc) - nonces_to_reveal - [] - in - let*! result = - (inject_seed_nonce_revelation - cctxt - ~chain - ~block - ~branch - prepared_nonces - [@profiler.record_s - {verbosity = Info} "inject seed nonce revelation"]) - in - match result with - | Error err -> - let*! () = Events.(emit cannot_inject_nonces err) in - return_unit - | Ok () -> - let updated_nonces = - let nonce_with_new_states = - Nonce_hash.Map.map - (fun nonce_data -> - {nonce_data with nonce_state = Revealed level}) - nonces_to_reveal - in - Nonce_hash.Map.fold - (fun hash nonce acc -> Nonce_hash.Map.add hash nonce acc) - nonce_with_new_states - live_nonces - in - (save - cctxt - ~legacy_location - ~stateful_location - ~orphaned_location - updated_nonces - [@profiler.record_s {verbosity = Info} "save nonces"])))) - else return_unit - -(* We suppose that the block stream is cloned by the caller *) -let start_revelation_worker cctxt config chain_id constants block_stream = - let open Lwt_syntax in - let legacy_location = Baking_files.resolve_location ~chain_id `Legacy_nonce in - let stateful_location = - Baking_files.resolve_location ~chain_id `Stateful_nonce - in - let chain = `Hash chain_id in - let canceler = Lwt_canceler.create () in - let should_shutdown = ref false in - let state = - { - cctxt; - chain; - constants; - config; - legacy_location; - stateful_location; - orphaned_location = - Baking_files.resolve_location ~chain_id `Orphaned_nonce; - last_predecessor = Block_hash.zero; - } - in - (* TODO: https://gitlab.com/tezos/tezos/-/issues/7110 - Enshrine `stateful_hash_nonces` as the main nonce file - format. - *) - let* () = try_migrate_legacy_nonces state in - let last_proposal = ref None in - let rec worker_loop () = - Lwt_canceler.on_cancel canceler (fun () -> - should_shutdown := true ; - Lwt.return_unit) ; - let* new_proposal = Lwt_stream.get block_stream in - match new_proposal with - | None -> - (* The head stream closed meaning that the connection - with the node was interrupted: exit *) - return_unit - | Some new_proposal -> - Option.iter (fun _ -> (() [@profiler.stop])) !last_proposal ; - () - [@profiler.record - {verbosity = Notice} - (Block_hash.to_b58check new_proposal.Baking_state.block.hash)] ; - last_proposal := Some new_proposal.Baking_state.block.hash ; - if !should_shutdown then return_unit - else - let* _ = - (reveal_potential_nonces - state - new_proposal - [@profiler.record_s {verbosity = Notice} "reveal potential nonces"]) - in - worker_loop () - in - Lwt.dont_wait - (fun () -> - Lwt.finalize - (fun () -> - let* () = Events.(emit revelation_worker_started ()) in - let* () = worker_loop () in - (* never ending loop *) Lwt.return_unit) - (fun () -> (* TODO *) Lwt.return_unit)) - (fun _exn -> ()) ; - Lwt.return canceler diff --git a/src/proto_020_PsParisC/lib_delegate/baking_nonces.mli b/src/proto_020_PsParisC/lib_delegate/baking_nonces.mli deleted file mode 100644 index a4c2a5f3bce6..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_nonces.mli +++ /dev/null @@ -1,80 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* Copyright (c) 2024 TriliTech *) -(* *) -(* 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 - -type state - -type t = state - -(** [nonces] is a hash map corresponding to the data which can be found in the - file from [nonces_location] *) -type nonces - -(** [load wallet location] loads the file corresponding to [location] and - returns a data structure containing the stored information. *) -val load : - #Client_context.wallet -> - stateful_location:[`Stateful_nonce] Baking_files.location -> - nonces tzresult Lwt.t - -(** [generate_seed_nonce nonce_config delegate level] computes a nonce via a - [Deterministic] or [Random] approach, depending on the [nonce_config] - argument; the deterministic case uses as parameters [delegate] and [level]. *) -val generate_seed_nonce : - ?timeout:float -> - Baking_configuration.nonce_config -> - Baking_state.consensus_key -> - Raw_level.t -> - (Nonce_hash.t * Nonce.t) tzresult Lwt.t - -(** [register_nonce cctxt ~chain_id block_hash nonce ~cycle ~level ~round] updates - the contents from the nonces file located using [cctxt] and [~chain_id] by - adding a new entry or replacing an existing one of the form - [block_hash] : [nonce] * [~cycle] * [~level] * [~round]. *) -val register_nonce : - #Protocol_client_context.full -> - chain_id:Chain_id.t -> - Block_hash.t -> - Nonce.t -> - cycle:Cycle.t -> - level:Raw_level.t -> - round:Round.t -> - unit tzresult Lwt.t - -(** [start_revelation_worker cctxt config chain_id constants block_stream] - represents the continuous process of receiving new proposal from [block_stream] - and applying them to the internal state created from [cctxt], [config], - [chain_id] and [constants]; each new proposal can produce a nonce, to be stored - in a nonce file location, facilitating the nonce revelation process. *) -val start_revelation_worker : - Protocol_client_context.full -> - Baking_configuration.nonce_config -> - Chain_id.t -> - Constants.t -> - Baking_state.proposal Lwt_stream.t -> - Lwt_canceler.t Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/baking_pow.ml b/src/proto_020_PsParisC/lib_delegate/baking_pow.ml deleted file mode 100644 index d4f2a8f02103..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_pow.ml +++ /dev/null @@ -1,134 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol - -let default_constant = "\x00\x00\x00\x05" - -let with_version_constant = - let commit_hash = - match - Hex.to_string (`Hex Tezos_version_value.Current_git_info.commit_hash) - with - | None -> Tezos_version_value.Current_git_info.commit_hash - | Some s -> s - in - if String.length commit_hash >= 4 then String.sub commit_hash 0 4 - else default_constant - -let with_version_constant_len = String.length with_version_constant - -let proof_of_work_nonce = - let out = - Bytes.make Alpha_context.Constants.proof_of_work_nonce_size '\000' - in - let () = - Bytes.blit_string with_version_constant 0 out 0 with_version_constant_len - in - out - -(* [proof_of_work_nonce] will be modified in place so we make a clean copy to expose to the outside *) -let empty_proof_of_work_nonce = Bytes.copy proof_of_work_nonce - -let max_z_len = - Alpha_context.Constants.proof_of_work_nonce_size - with_version_constant_len - -(* Make a string of zeros to restore [proof_of_work_nonce] to its original value in 1 operation *) -let zeros = String.make max_z_len '\000' - -let mine ~proof_of_work_threshold shell builder = - let open Lwt_result_syntax in - match - Option.bind - (Data_encoding.Binary.fixed_length Block_payload_hash.encoding) - (fun payload -> - Option.map - (fun round -> - let shell = - Data_encoding.Binary.length - Block_header.shell_header_encoding - shell - in - shell + payload + round + with_version_constant_len) - (Data_encoding.Binary.fixed_length Round_repr.encoding)) - (* Where to put the proof of work value is in the bytes of the encoded header *) - with - | None -> failwith "Cannot compute block header offset" - | Some offset -> - let () = - (* Restore proof_of_work_nonce to its original value. *) - Bytes.blit_string - zeros - 0 - proof_of_work_nonce - with_version_constant_len - max_z_len - in - (* Build the binary of the block header with 0 as proof of work and compute its hash. *) - let block_0 = builder proof_of_work_nonce in - let block_header = - Data_encoding.Binary.to_bytes_exn - Alpha_context.Block_header.encoding - Alpha_context.Block_header. - { - shell; - protocol_data = {contents = block_0; signature = Signature.zero}; - } - in - let block_hash = Block_header.hash_raw block_header in - let block_hash_bytes = Block_hash.to_bytes block_hash in - (* The loop edits [block_header] and [block_hash] (by editing its subpart [block_hash_bytes]!) in place. *) - let rec loop z = - let z_len = (Z.numbits z + 7) / 8 in - if z_len > max_z_len then - failwith - "Client_baking_pow.mine: couldn't find nonce for required proof of \ - work" - else ( - Bytes.blit_string (Z.to_bits z) 0 block_header offset z_len ; - (if Hacl_star.AutoConfig2.(has_feature VEC256) then - Hacl_star.Hacl.Blake2b_256.Noalloc.hash - else Hacl_star.Hacl.Blake2b_32.Noalloc.hash) - ~key:Bytes.empty - ~msg:block_header - ~digest:block_hash_bytes ; - if - Alpha_context.Block_header.Proof_of_work.check_hash - block_hash - proof_of_work_threshold - then - let () = - Bytes.blit_string - (Z.to_bits z) - 0 - proof_of_work_nonce - with_version_constant_len - z_len - in - let block = builder proof_of_work_nonce in - return block - else loop (Z.succ z)) - in - loop Z.zero diff --git a/src/proto_020_PsParisC/lib_delegate/baking_pow.mli b/src/proto_020_PsParisC/lib_delegate/baking_pow.mli deleted file mode 100644 index ad5975c9190c..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_pow.mli +++ /dev/null @@ -1,40 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol - -(** A null proof-of-work nonce. This should only be used to nonsensical blocks - of the correct size and shape. *) -val empty_proof_of_work_nonce : Bytes.t - -(** [mine ~proof_of_work_threshold chain block header builder] returns a block with a valid - proof-of-work nonce. The function [builder], provided by the caller, is used - to make the block. All the internal logic of generating nonces and checking - for the proof-of-work threshold is handled by [mine]. *) -val mine : - proof_of_work_threshold:int64 -> - Block_header.shell_header -> - (Bytes.t -> Alpha_context.Block_header.contents) -> - Alpha_context.Block_header.contents tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/baking_profiler.ml b/src/proto_020_PsParisC/lib_delegate/baking_profiler.ml deleted file mode 100644 index 1f476de4d111..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_profiler.ml +++ /dev/null @@ -1,40 +0,0 @@ -(*****************************************************************************) -(* *) -(* SPDX-License-Identifier: MIT *) -(* SPDX-FileCopyrightText: 2024 Nomadic Labs *) -(* *) -(*****************************************************************************) - -open Profiler - -let nonce_profiler = unplugged () - -let operation_worker_profiler = unplugged () - -let node_rpc_profiler = unplugged () - -(* This is the main profiler for the baker *) -let baker_profiler = unplugged () - -(* This environment profiler was added to get insights on the signature checking. *) -let environment_profiler = - Tezos_protocol_environment.Environment_profiler.environment_profiler - -let all_profilers = - [ - ("nonce", [nonce_profiler]); - ("op_worker", [operation_worker_profiler]); - ("node_rpc", [node_rpc_profiler]); - ("baker", [baker_profiler; environment_profiler]); - ] - -let activate_all ~profiler_maker = - List.iter - (fun (name, profilers) -> - Option.iter - (fun instance -> List.iter (fun p -> plug p instance) profilers) - (profiler_maker ~name)) - all_profilers - -let create_reset_block_section = - Profiler.section_maker Block_hash.equal Block_hash.to_b58check diff --git a/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml b/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml deleted file mode 100644 index bf43c7cd203a..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_scheduling.ml +++ /dev/null @@ -1,1120 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol.Alpha_context -module Events = Baking_events.Scheduling -open Baking_state - -module Profiler = struct - include (val Profiler.wrap Baking_profiler.baker_profiler) - - let[@warning "-32"] reset_block_section = - (* The section_maker must be created here and not inside the pattern - matching because it instantiates a reference that needs to live the - whole lifetime of the profiler and will be used to test if the - section should be closed and re-opened or not. *) - let section = - Tezos_base.Profiler.section_maker - ~verbosity:Notice - ( = ) - Block_hash.to_b58check - Baking_profiler.baker_profiler - in - function - | Baking_state.New_head_proposal proposal, metadata - | Baking_state.New_valid_proposal proposal, metadata -> - section (proposal.block.hash, metadata) - | _ -> () -end - -type loop_state = { - heads_stream : Baking_state.proposal Lwt_stream.t; - get_valid_blocks_stream : Baking_state.proposal Lwt_stream.t Lwt.t; - qc_stream : Operation_worker.event Lwt_stream.t; - forge_event_stream : forge_event Lwt_stream.t; - future_block_stream : - [`New_future_head of proposal | `New_future_valid_proposal of proposal] - Lwt_stream.t; - push_future_block : - [`New_future_head of proposal | `New_future_valid_proposal of proposal] -> - unit; - mutable last_get_head_event : - [`New_head_proposal of proposal option] Lwt.t option; - mutable last_get_valid_block_event : - [`New_valid_proposal of proposal option] Lwt.t option; - mutable last_future_block_event : - [`New_future_head of proposal | `New_future_valid_proposal of proposal] - Lwt.t - option; - mutable last_get_qc_event : - [`QC_reached of Operation_worker.event option] Lwt.t option; - mutable last_forge_event : - [`New_forge_event of forge_event option] Lwt.t option; -} - -type events = - [ `New_future_head of proposal - | `New_future_valid_proposal of proposal - | `New_valid_proposal of proposal option - | `New_head_proposal of proposal option - | `QC_reached of Operation_worker.event option - | `New_forge_event of forge_event option - | `Termination - | `Timeout of timeout_kind ] - Lwt.t - -let create_loop_state ?get_valid_blocks_stream ~heads_stream ~forge_event_stream - operation_worker = - let future_block_stream, push_future_block = Lwt_stream.create () in - let get_valid_blocks_stream = - match get_valid_blocks_stream with - | None -> Lwt.return (Lwt_stream.create () |> fst) - | Some vbs_t -> vbs_t - in - { - heads_stream; - get_valid_blocks_stream; - qc_stream = Operation_worker.get_quorum_event_stream operation_worker; - forge_event_stream; - future_block_stream; - push_future_block = (fun x -> push_future_block (Some x)); - last_get_head_event = None; - last_get_valid_block_event = None; - last_future_block_event = None; - last_get_qc_event = None; - last_forge_event = None; - } - -let find_in_known_round_intervals known_round_intervals ~predecessor_timestamp - ~predecessor_round ~now = - let open Baking_cache in - Round_timestamp_interval_cache.( - find_opt - known_round_intervals - {predecessor_timestamp; predecessor_round; time_interval = (now, now)}) - -let sleep_until_ptime ptime = - let delay = Ptime.diff ptime (Time.System.now ()) in - if Ptime.Span.compare delay Ptime.Span.zero < 0 then None - else Some (Lwt_unix.sleep (Ptime.Span.to_float_s delay)) - -(** The function is blocking until it is [time]. *) -let sleep_until time = - (* Sleeping is a system op, baking is a protocol op, this is where we convert *) - let time = Time.System.of_protocol_exn time in - sleep_until_ptime time - -(* Only allocate once the termination promise *) -let terminated = - let open Lwt_syntax in - let+ _ = Lwt_exit.clean_up_starts in - `Termination - -let rec wait_next_event ~timeout loop_state = - let open Lwt_result_syntax in - (* TODO? should we prioritize head events/timeouts to resynchronize if needs be ? *) - let get_head_event () = - (* n.b. we should also consume the available elements in the - block_stream before starting baking. *) - match loop_state.last_get_head_event with - | None -> - let t = - let*! e = Lwt_stream.get loop_state.heads_stream in - Lwt.return (`New_head_proposal e) - in - loop_state.last_get_head_event <- Some t ; - t - | Some t -> t - in - let get_valid_block_event () = - match loop_state.last_get_valid_block_event with - | None -> - let t = - let*! valid_blocks_stream = loop_state.get_valid_blocks_stream in - let*! e = Lwt_stream.get valid_blocks_stream in - Lwt.return (`New_valid_proposal e) - in - loop_state.last_get_valid_block_event <- Some t ; - t - | Some t -> t - in - let get_future_block_event () = - (* n.b. we should also consume the available elements in the - block_stream before starting baking. *) - match loop_state.last_future_block_event with - | None -> - let t = - let*! future_proposal = - Lwt_stream.get loop_state.future_block_stream - in - Lwt.return - @@ - match future_proposal with - | None -> - (* unreachable, we never close the stream *) - assert false - | Some future_proposal -> future_proposal - in - loop_state.last_future_block_event <- Some t ; - t - | Some t -> t - in - let get_qc_event () = - match loop_state.last_get_qc_event with - | None -> - let t = - let*! e = Lwt_stream.get loop_state.qc_stream in - Lwt.return (`QC_reached e) - in - loop_state.last_get_qc_event <- Some t ; - t - | Some t -> t - in - let get_forge_event () = - match loop_state.last_forge_event with - | None -> - let t = - let*! e = Lwt_stream.get loop_state.forge_event_stream in - Lwt.return (`New_forge_event e) - in - loop_state.last_forge_event <- Some t ; - t - | Some t -> t - in - (* event construction *) - let open Baking_state in - let*! result = - Lwt.choose - [ - terminated; - (get_head_event () :> events); - (get_valid_block_event () :> events); - (get_future_block_event () :> events); - (get_qc_event () :> events); - (get_forge_event () :> events); - (timeout :> events); - ] - in - match result with - (* event matching *) - | `Termination -> - (* Exit the loop *) - return_none - | `New_valid_proposal None -> - (* Node connection lost *) - loop_state.last_get_valid_block_event <- None ; - tzfail Baking_errors.Node_connection_lost - | `New_head_proposal None -> - (* Node connection lost *) - loop_state.last_get_head_event <- None ; - tzfail Baking_errors.Node_connection_lost - | `QC_reached None -> - (* Not supposed to happen: exit the loop *) - loop_state.last_get_qc_event <- None ; - return_none - | `New_forge_event None -> - (* Not supposed to happen: exit the loop *) - loop_state.last_forge_event <- None ; - return_none - | `New_valid_proposal (Some proposal) -> ( - loop_state.last_get_valid_block_event <- None ; - (* Is the block in the future? *) - match sleep_until proposal.block.shell.timestamp with - | Some waiter -> - (* If so, wait until its timestamp is reached before advertising it *) - let*! () = Events.(emit proposal_in_the_future proposal.block.hash) in - Lwt.dont_wait - (fun () -> - let*! () = waiter in - loop_state.push_future_block (`New_future_valid_proposal proposal) ; - Lwt.return_unit) - (fun _exn -> ()) ; - wait_next_event ~timeout loop_state - | None -> return_some (New_valid_proposal proposal)) - | `New_head_proposal (Some proposal) -> ( - loop_state.last_get_head_event <- None ; - (* Is the block in the future? *) - match sleep_until proposal.block.shell.timestamp with - | Some waiter -> - (* If so, wait until its timestamp is reached before advertising it *) - let*! () = Events.(emit proposal_in_the_future proposal.block.hash) in - Lwt.dont_wait - (fun () -> - let*! () = waiter in - loop_state.push_future_block (`New_future_head proposal) ; - Lwt.return_unit) - (fun _exn -> ()) ; - wait_next_event ~timeout loop_state - | None -> return_some (New_head_proposal proposal)) - | `New_future_head proposal -> - let*! () = - Events.(emit process_proposal_in_the_future proposal.block.hash) - in - loop_state.last_future_block_event <- None ; - return_some (New_head_proposal proposal) - | `New_future_valid_proposal proposal -> - let*! () = - Events.(emit process_proposal_in_the_future proposal.block.hash) - in - loop_state.last_future_block_event <- None ; - return_some (New_valid_proposal proposal) - | `QC_reached - (Some (Operation_worker.Prequorum_reached (candidate, preattestation_qc))) - -> - loop_state.last_get_qc_event <- None ; - return_some (Prequorum_reached (candidate, preattestation_qc)) - | `QC_reached - (Some (Operation_worker.Quorum_reached (candidate, attestation_qc))) -> - loop_state.last_get_qc_event <- None ; - return_some (Quorum_reached (candidate, attestation_qc)) - | `New_forge_event (Some event) -> - loop_state.last_forge_event <- None ; - return_some (New_forge_event event) - | `Timeout e -> return_some (Timeout e) - -let rec first_own_round_in_range delegate_slots ~committee_size ~included_min - ~excluded_max = - if included_min >= excluded_max then None - else - match Round.of_int included_min with - | Error _ -> - (* Should not happen because in practice, [included_min] is - non-negative and not big enough to overflow as an Int32. *) - None - | Ok round -> ( - match Round.to_slot round ~committee_size with - | Error _ -> - (* Impossible because [Round.of_int] builds a sound round. *) None - | Ok slot -> ( - match Delegate_slots.own_slot_owner delegate_slots ~slot with - | Some {consensus_key_and_delegate; _} -> - Some (round, consensus_key_and_delegate) - | None -> - first_own_round_in_range - delegate_slots - ~committee_size - ~included_min:(included_min + 1) - ~excluded_max)) - -let first_potential_round_at_next_level state ~earliest_round = - match Round.to_int earliest_round with - | Error _ -> None - | Ok earliest_round -> - let committee_size = - state.global_state.constants.parametric.consensus_committee_size - in - first_own_round_in_range - state.level_state.next_level_delegate_slots - ~committee_size - ~included_min:earliest_round - ~excluded_max:(earliest_round + committee_size) -(* If no own round is found between [earliest_round] included and - [earliest_round + committee_size] excluded, then we can stop - searching, because baking slots repeat themselves modulo the - [committee_size]. *) - -(** From the current [state], the function returns an optional - association pair, which consists of the next baking timestamp and - its baking round. In that case, an elected block must exist. *) -let compute_next_potential_baking_time_at_next_level state = - let open Lwt_syntax in - let open Protocol.Alpha_context in - let open Baking_state in - match state.level_state.elected_block with - | None -> return_none - | Some elected_block -> ( - let* () = - Events.( - emit - compute_next_timeout_elected_block - ( elected_block.proposal.block.shell.level, - elected_block.proposal.block.round )) - in - (* Do we have baking rights for the next level ? *) - (* Determine the round for the next level *) - let predecessor_timestamp = - elected_block.proposal.block.shell.timestamp - in - let predecessor_round = elected_block.proposal.block.round in - let now = Time.System.now () |> Time.System.to_protocol in - (* Lookup the next slot information if already stored in the - memoization table [Round_timestamp_interval_tbl]. *) - match - find_in_known_round_intervals - state.global_state.cache.round_timestamps - ~predecessor_timestamp - ~predecessor_round - ~now - with - | Some (first_potential_baking_time, first_potential_round, delegate) -> ( - (* Check if we already have proposed something at next - level *) - match state.level_state.next_level_proposed_round with - | Some proposed_round - when Round.(proposed_round >= first_potential_round) -> - let* () = Events.(emit proposal_already_injected ()) in - return_none - | None | Some _ -> - let* () = - Events.( - emit - next_potential_slot - ( Int32.succ state.level_state.current_level, - first_potential_round, - first_potential_baking_time, - delegate )) - in - return_some (first_potential_baking_time, first_potential_round)) - | None -> ( - let round_durations = state.global_state.round_durations in - (* Compute the timestamp at which the new level will start at - round 0.*) - Round.timestamp_of_round - round_durations - ~predecessor_timestamp - ~predecessor_round - ~round:Round.zero - |> function - | Error _ -> return_none - | Ok min_possible_time -> ( - (* If this timestamp exists and is not yet outdated, the - earliest round to bake is thereby 0. Otherwise, we - compute the round from the current timestamp. This - possibly means the baker has been late. *) - (if Time.Protocol.(now < min_possible_time) then Ok Round.zero - else - Environment.wrap_tzresult - @@ Round.round_of_timestamp - round_durations - ~predecessor_timestamp - ~predecessor_round - ~timestamp:now) - |> function - | Error _ -> return_none - | Ok earliest_round -> ( - (* There does not necessarily exists a slot that is - equal to [earliest_round]. We must find the earliest - slot after this value for which a validator is - designated to propose. *) - match - first_potential_round_at_next_level state ~earliest_round - with - | None -> return_none - | Some (first_potential_round, delegate) -> ( - (* Check if we already have proposed something at next - level. If so, we can skip. Otherwise, we recompute - the timestamp for the - [first_potential_round]. Finally, from this - [first_potential_baking_time], we can return. *) - match state.level_state.next_level_proposed_round with - | Some proposed_round - when Round.(proposed_round >= first_potential_round) -> - let* () = - Events.(emit proposal_already_injected ()) - in - return_none - | None | Some _ -> ( - timestamp_of_round - state - ~predecessor_timestamp - ~predecessor_round - ~round:first_potential_round - |> function - | Error _ -> return_none - | Ok first_potential_baking_time -> - let* () = - Events.( - emit - next_potential_slot - ( Int32.succ state.level_state.current_level, - first_potential_round, - first_potential_baking_time, - delegate )) - in - (* memoize this *) - let () = - let this_round_duration = - Round.round_duration - round_durations - first_potential_round - in - let end_first_potential_baking_time = - Timestamp.( - first_potential_baking_time - +? this_round_duration) - |> function - | Ok x -> x - | Error _ -> assert false - in - Baking_cache.( - Round_timestamp_interval_cache.replace - state.global_state.cache.round_timestamps - { - predecessor_timestamp; - predecessor_round; - time_interval = - ( first_potential_baking_time, - end_first_potential_baking_time ); - } - ( first_potential_baking_time, - first_potential_round, - delegate )) - in - return_some - ( first_potential_baking_time, - first_potential_round ))))))) - -(** From the current [state], the function returns an Lwt promise that - fulfills once the nearest timeout is expired and at which the state - machine will react. - - Both subfunctions [wait_baking_time] and [wait_end_of_round] are - using the blocking function - [Baking_scheduling.sleep_until]. However, this call is binded into - a Lwt promise. Hence, it just won't get fulfilled until sleep time - has elapsed. Once the promise is fulfilled, - [Baking_scheduling.wait_next_event] handles with [Lwt.choose] to - react and trigger event [Timeout]. *) -let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t - = - let open Lwt_result_syntax in - (* FIXME: this function (may) try to instantly repropose a block *) - let open Baking_state in - let wait_end_of_round ?(delta = 0L) (next_round_time, next_round) = - let next_time = Time.Protocol.add next_round_time delta in - let now = Time.System.now () in - let delay = Ptime.diff (Time.System.of_protocol_exn next_time) now in - let current_round = Int32.pred @@ Round.to_int32 next_round in - let*! () = - if delta = 0L then - Events.(emit waiting_end_of_round (delay, current_round, next_time)) - else - Events.( - emit - waiting_delayed_end_of_round - (delay, current_round, next_time, delta)) - in - let end_of_round = - Lwt.return - @@ End_of_round {ending_round = state.round_state.current_round} - in - match sleep_until next_time with - | None -> return end_of_round - | Some t -> - return - (let*! () = t in - end_of_round) - in - let wait_baking_time_next_level (next_baking_time, next_baking_round) = - let now = Time.System.now () in - let delay = Ptime.diff (Time.System.of_protocol_exn next_baking_time) now in - match sleep_until next_baking_time with - | None -> - let*! () = Events.(emit no_need_to_wait_for_proposal ()) in - return - (Lwt.return - (Time_to_prepare_next_level_block {at_round = next_baking_round})) - | Some t -> - let*! () = - Events.(emit waiting_time_to_bake (delay, next_baking_time)) - in - return - (let*! () = t in - Lwt.return - (Time_to_prepare_next_level_block {at_round = next_baking_round})) - in - let delay_next_round_timeout next_round = - (* we only delay if it's our turn to bake *) - match round_proposer state ~level:`Current (snd next_round) with - | Some _ -> - let delta = - state.global_state.constants.parametric.minimal_block_delay - |> Period.to_seconds - |> fun d -> Int64.div d 5L - in - (* NB: this means 6 seconds delay, if the first round duration is - 30. *) - wait_end_of_round ~delta next_round - | None -> wait_end_of_round next_round - in - let should_wait_to_forge_block (_next_baking_time, next_baking_round) = - Option.is_some state.level_state.elected_block - && Round.equal next_baking_round Round.zero - in - let waiting_to_forge_block (next_baking_time, next_baking_round) = - let*! () = Events.(emit first_baker_of_next_level ()) in - let now = Time.System.now () in - let next_baking_ptime = Time.System.of_protocol_exn next_baking_time in - let pre_emptive_forge_time = - state.global_state.config.pre_emptive_forge_time - in - let next_forging_ptime = - match Ptime.sub_span next_baking_ptime pre_emptive_forge_time with - | Some ptime -> ptime - | None -> - (* This branch can only be reached if the Ptime operations above - fail. In practice, it should be unreachable. *) - assert false - in - let delay = Ptime.diff next_forging_ptime now in - match sleep_until_ptime next_forging_ptime with - | None -> - let*! () = Events.(emit no_need_to_wait_to_forge_block ()) in - return - (Lwt.return - (Time_to_prepare_next_level_block {at_round = next_baking_round})) - | Some t -> - let*! () = - Events.( - emit - waiting_to_forge_block - (delay, Time.System.to_protocol next_forging_ptime)) - in - return - (let*! () = t in - Lwt.return - (Time_to_prepare_next_level_block {at_round = next_baking_round})) - in - (* TODO: re-use what has been done in round_synchronizer.ml *) - (* Compute the timestamp of the next possible round. *) - let next_round = compute_next_round_time state in - let*! next_baking = compute_next_potential_baking_time_at_next_level state in - match (next_round, next_baking) with - | None, None -> - let*! () = Events.(emit waiting_for_new_head ()) in - return - (let*! () = Lwt_utils.never_ending () in - assert false) - (* We have no slot at the next level in the near future, we will - patiently wait for the next round. *) - | Some next_round, None -> ( - (* If there is an elected block, then we make the assumption - that the bakers at the next level have also received an - attestation quorum, and we delay a bit injecting at the next - round, so that there are not two blocks injected at the same - time. *) - match state.level_state.elected_block with - | None -> wait_end_of_round next_round - | Some _elected_block -> delay_next_round_timeout next_round) - (* There is no timestamp for a successor round but there is for a - future baking slot. If we are the next level baker at round 0, - quorum has been reached for this level, and no block being forged, - we will wait to forge, otherwise we will wait to bake *) - | None, Some next_baking -> - if should_wait_to_forge_block next_baking then - waiting_to_forge_block next_baking - else wait_baking_time_next_level next_baking - (* We choose the earliest timestamp between waiting to bake and - waiting for the next round. *) - | ( Some ((next_round_time, next_round) as next_round_info), - Some ((next_baking_time, _) as next_baking) ) -> - (* If we can bake at the next level before the end of the next - round, then do so. This is because the proposed block will have - a smaller timestamp than the earliest block at next level built - on top of the proposal made at the next round (at the current - level). *) - let round_durations = state.global_state.round_durations in - let next_round_duration = - Round.round_duration round_durations next_round |> Period.to_seconds - in - if - Time.Protocol.( - next_baking_time < add next_round_time next_round_duration) - then - if should_wait_to_forge_block next_baking then - waiting_to_forge_block next_baking - else wait_baking_time_next_level next_baking - else - (* same observation is in the [(Some next_round, None)] case *) - delay_next_round_timeout next_round_info - -(* initialises attestable_payload with the PQC included in the latest block - if there is one and if it's more recent than the one loaded from disk - if any *) -let may_initialise_with_latest_proposal_pqc state = - let open Lwt_result_syntax in - let p = state.level_state.latest_proposal in - match p.block.prequorum with - | None -> return state - | Some pqc -> ( - match state.level_state.attestable_payload with - | Some ep when ep.prequorum.round >= pqc.round -> - (*do not change the attestable_payload loaded from disk if it's - more recent *) - return state - | Some _ | None -> - return - { - state with - level_state = - { - state.level_state with - attestable_payload = Some {prequorum = pqc; proposal = p}; - }; - }) - -let create_round_durations constants = - let first_round_duration = - constants.Constants.parametric.minimal_block_delay - in - let delay_increment_per_round = - constants.parametric.delay_increment_per_round - in - Environment.wrap_tzresult - (Round.Durations.create ~first_round_duration ~delay_increment_per_round) - -let create_dal_node_rpc_ctxt endpoint = - let open Tezos_rpc_http_client_unix in - let rpc_config = - {Tezos_rpc_http_client_unix.RPC_client_unix.default_config with endpoint} - in - let media_types = - Tezos_rpc_http.Media_type.Command_line.of_command_line rpc_config.media_type - in - new RPC_client_unix.http_ctxt rpc_config media_types - -let create_initial_state cctxt ?(synchronize = true) ~chain config - operation_worker ~(current_proposal : Baking_state.proposal) ?constants - delegates = - let open Lwt_result_syntax in - (* FIXME? consider saved attestable value *) - let open Protocol in - let open Baking_state in - let* chain_id = Shell_services.Chain.chain_id cctxt ~chain () in - let* constants = - match constants with - | Some c -> return c - | None -> Alpha_services.Constants.all cctxt (`Hash chain_id, `Head 0) - in - let*? round_durations = create_round_durations constants in - let* validation_mode = - Baking_state.( - match config.Baking_configuration.validation with - | Node -> return Node - | Local {context_path} -> - let* index = Baking_simulator.load_context ~context_path in - return (Local index) - | ContextIndex index -> return (Local index)) - in - let cache = Baking_state.create_cache () in - let dal_node_rpc_ctxt = - Option.map create_dal_node_rpc_ctxt config.dal_node_endpoint - in - let global_state = - { - cctxt; - chain_id; - config; - constants; - round_durations; - operation_worker; - forge_worker_hooks = - { - push_request = (fun _ -> assert false); - get_forge_event_stream = (fun _ -> assert false); - cancel_all_pending_tasks = (fun _ -> assert false); - }; - validation_mode; - delegates; - cache; - dal_node_rpc_ctxt; - } - in - (* Trick to provide the global state to the forge worker without - introducing a circular dependency. *) - let forge_worker = Forge_worker.start global_state in - global_state.forge_worker_hooks <- - { - push_request = Forge_worker.push_request forge_worker; - get_forge_event_stream = - (fun () -> Forge_worker.get_event_stream forge_worker); - cancel_all_pending_tasks = - (fun () -> Forge_worker.cancel_all_pending_tasks forge_worker); - } ; - let chain = `Hash chain_id in - let current_level = current_proposal.block.shell.level in - let* delegate_slots = - Baking_state.compute_delegate_slots - cctxt - delegates - ~level:current_level - ~chain - in - let* next_level_delegate_slots = - Baking_state.compute_delegate_slots - cctxt - delegates - ~level:(Int32.succ current_level) - ~chain - in - let elected_block = - if Baking_state.is_first_block_in_protocol current_proposal then - (* If the last block is a protocol transition, we admit it as a - final block *) - Some {proposal = current_proposal; attestation_qc = []} - else None - in - let current_level = current_proposal.block.shell.level in - let dal_attestable_slots = - Option.fold - ~none:[] - ~some:(fun dal_node_rpc_ctxt -> - Node_rpc.dal_attestable_slots - dal_node_rpc_ctxt - ~attestation_level:current_level - (Delegate_slots.own_delegates delegate_slots)) - dal_node_rpc_ctxt - in - let next_level_dal_attestable_slots = - Option.fold - ~none:[] - ~some:(fun dal_node_rpc_ctxt -> - Node_rpc.dal_attestable_slots - dal_node_rpc_ctxt - ~attestation_level:(Int32.succ current_level) - (Delegate_slots.own_delegates next_level_delegate_slots)) - dal_node_rpc_ctxt - in - let level_state = - { - current_level; - latest_proposal = current_proposal; - is_latest_proposal_applied = - true (* this proposal is expected to be the current head *); - locked_round = None; - attestable_payload = None; - elected_block; - delegate_slots; - next_level_delegate_slots; - next_level_proposed_round = None; - dal_attestable_slots; - next_level_dal_attestable_slots; - } - in - let* round_state = - if synchronize then - let*? round_durations = create_round_durations constants in - let*? current_round = - Baking_actions.compute_round current_proposal round_durations - in - return - { - current_round; - current_phase = Idle; - delayed_quorum = None; - early_attestations = []; - awaiting_unlocking_pqc = false; - } - else - return - { - Baking_state.current_round = Round.zero; - current_phase = Idle; - delayed_quorum = None; - early_attestations = []; - awaiting_unlocking_pqc = false; - } - in - let state = {global_state; level_state; round_state} in - (* Try loading locked round and attestable round from disk *) - let* state = Baking_state.may_load_attestable_data state in - may_initialise_with_latest_proposal_pqc state - -let compute_bootstrap_event state = - let open Result_syntax in - let open Baking_state in - (* Check if we are in the current round *) - if - Round.( - state.level_state.latest_proposal.block.round - = state.round_state.current_round) - then - (* If so, then trigger the new proposal event to possibly preattest *) - return @@ Baking_state.New_head_proposal state.level_state.latest_proposal - else - (* Otherwise, trigger the end of round to check whether we - need to propose at this level or not *) - let* ending_round = - Environment.wrap_tzresult @@ Round.pred state.round_state.current_round - in - return @@ Baking_state.Timeout (End_of_round {ending_round}) - -let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error - loop_state state event = - let open Lwt_result_syntax in - let state_recorder ~new_state = - match config.Baking_configuration.state_recorder with - | Baking_configuration.Filesystem -> - Baking_state.may_record_new_state ~previous_state:state ~new_state - | Baking_configuration.Memory -> return_unit - in - () [@profiler.reset_block_section event] ; - (let*! state', action = - (State_transitions.step - state - event - [@profiler.record_s - {verbosity = Notice} (Format.asprintf "Step : %a" pp_short_event event)]) - in - let* state'' = - let*! state_res = - let* state'' = - (Baking_actions.perform_action - state' - action - [@profiler.record_s - {verbosity = Notice} - (Format.asprintf "Action : %a" Baking_actions.pp_action action)]) - in - let* () = - may_record_new_state ~previous_state:state ~new_state:state'' - in - return state'' - in - match state_res with - | Ok state'' -> return state'' - | Error error -> - let* () = on_error error in - (* Still try to record the intermediate state; ignore potential - errors. *) - let*! _ = state_recorder ~new_state:state' in - return state' - in - let* next_timeout = - (compute_next_timeout - state'' - [@profiler.record_s {verbosity = Notice} "Timeout : compute next timeout"]) - in - let* event_opt = - (wait_next_event - ~timeout: - (let*! e = next_timeout in - Lwt.return (`Timeout e)) - loop_state [@profiler.record_s {verbosity = Notice} "Wait : next event"]) - in - () [@profiler.stop] ; - match event_opt with - | None -> - (* Termination *) - return_none - | Some event -> - if stop_on_event event then return_some event - else - automaton_loop - ~stop_on_event - ~config - ~on_error - loop_state - state'' - event) - [@profiler.record_s {verbosity = Notice} "Scheduler loop"] - -let perform_sanity_check cctxt ~chain_id = - let open Lwt_result_syntax in - let open Baking_errors in - let prefix_base_dir f = Filename.Infix.(cctxt#get_base_dir // f) in - let stateful_location = - Baking_files.resolve_location ~chain_id `Stateful_nonce - in - let* _ = - Baking_nonces.load cctxt ~stateful_location - |> trace - (Cannot_load_local_file - (prefix_base_dir (Baking_files.filename stateful_location) ^ "s")) - in - let highwatermarks_location = - Baking_files.resolve_location ~chain_id `Highwatermarks - in - let* _ = - Baking_highwatermarks.load cctxt highwatermarks_location - |> trace - (Cannot_load_local_file - (prefix_base_dir (Baking_files.filename highwatermarks_location) - ^ "s")) - in - let state_location = Baking_files.resolve_location ~chain_id `State in - let* _ = - Baking_state.load_attestable_data cctxt state_location - |> trace - (Cannot_load_local_file - (prefix_base_dir (Baking_files.filename state_location))) - in - return_unit - -let rec retry (cctxt : #Protocol_client_context.full) ?max_delay ~delay ~factor - ~tries ?(msg = "Connection failed. ") f x = - let open Lwt_result_syntax in - let*! result = f x in - match result with - | Ok _ as r -> Lwt.return r - | Error - (RPC_client_errors.Request_failed {error = Connection_failed _; _} :: _) - as err - when tries > 0 -> ( - let*! () = cctxt#message "%sRetrying in %.2f seconds..." msg delay in - let*! result = - Lwt.pick - [ - (let*! () = Lwt_unix.sleep delay in - Lwt.return `Continue); - (let*! _ = Lwt_exit.clean_up_starts in - Lwt.return `Killed); - ] - in - match result with - | `Killed -> Lwt.return err - | `Continue -> - let next_delay = delay *. factor in - let delay = - Option.fold - ~none:next_delay - ~some:(fun max_delay -> Float.min next_delay max_delay) - max_delay - in - retry cctxt ?max_delay ~delay ~factor ~msg ~tries:(tries - 1) f x) - | Error _ as err -> Lwt.return err - -let register_dal_profiles cctxt dal_node_rpc_ctxt delegates = - Option.iter_es - (fun dal_ctxt -> - retry - cctxt - ~max_delay:2. - ~delay:1. - ~factor:2. - ~tries:max_int - ~msg:"Failed to register profiles, DAL node is not reachable. " - (fun () -> Node_rpc.register_dal_profiles dal_ctxt delegates) - ()) - dal_node_rpc_ctxt - -let run cctxt ?canceler ?(stop_on_event = fun _ -> false) - ?(on_error = fun _ -> Lwt_result_syntax.return_unit) ?constants ~chain - config delegates = - let open Lwt_result_syntax in - let*! () = Events.(emit Baking_events.Delegates.delegates_used delegates) in - let* chain_id = Shell_services.Chain.chain_id cctxt ~chain () in - let* constants = - match constants with - | Some c -> return c - | None -> - Protocol.Alpha_services.Constants.all cctxt (`Hash chain_id, `Head 0) - in - let* () = perform_sanity_check cctxt ~chain_id in - let cache = Baking_cache.Block_cache.create 10 in - let* heads_stream, _block_stream_stopper = - Node_rpc.monitor_heads cctxt ~cache ~chain () - in - let* current_proposal = - let*! proposal = Lwt_stream.get heads_stream in - match proposal with - | Some current_head -> return current_head - | None -> failwith "head stream unexpectedly ended" - in - let*! operation_worker = Operation_worker.create ~constants cctxt in - Option.iter - (fun canceler -> - Lwt_canceler.on_cancel canceler (fun () -> - let*! _ = Operation_worker.shutdown_worker operation_worker in - Lwt.return_unit)) - canceler ; - let* initial_state = - create_initial_state - cctxt - ~chain - config - operation_worker - ~current_proposal - ~constants - delegates - in - let _promise = - register_dal_profiles - cctxt - initial_state.global_state.dal_node_rpc_ctxt - delegates - in - let cloned_block_stream = Lwt_stream.clone heads_stream in - let*! revelation_worker_canceler = - Baking_nonces.start_revelation_worker - cctxt - initial_state.global_state.config.nonce - initial_state.global_state.chain_id - initial_state.global_state.constants - cloned_block_stream - in - Option.iter - (fun canceler -> - Lwt_canceler.on_cancel canceler (fun () -> - let*! _ = Lwt_canceler.cancel revelation_worker_canceler in - Lwt.return_unit)) - canceler ; - (* FIXME: currently, the client streamed RPC call will hold until at - least one element is present in the stream. This is fixed by: - https://gitlab.com/nomadic-labs/resto/-/merge_requests/50. Until - then, we await the promise completion of the RPC call later - on. *) - let get_valid_blocks_stream = - let*! vbs = Node_rpc.monitor_valid_proposals cctxt ~cache ~chain () in - match vbs with - | Error _ -> Stdlib.failwith "Failed to get the validated blocks stream" - | Ok (vbs, _) -> Lwt.return vbs - in - let forge_event_stream = - initial_state.global_state.forge_worker_hooks.get_forge_event_stream () - in - let loop_state = - create_loop_state - ~get_valid_blocks_stream - ~forge_event_stream - ~heads_stream - initial_state.global_state.operation_worker - in - let on_error err = - let*! () = Events.(emit error_while_baking err) in - (* TODO? retry a bounded number of time *) - (* let retries = config.Baking_configuration.retries_on_failure in *) - on_error err - in - let*? initial_event = compute_bootstrap_event initial_state in - (* profiler_section is defined here because ocamlformat and ppx mix badly here *) - let[@warning "-26"] profiler_section = New_valid_proposal current_proposal in - () [@profiler.stop] ; - () [@profiler.reset_block_section profiler_section] ; - protect - ~on_error:(fun err -> - let*! _ = Option.iter_es Lwt_canceler.cancel canceler in - Lwt.return_error err) - (fun () -> - let* _ignored_event = - automaton_loop - ~stop_on_event - ~config - ~on_error - loop_state - initial_state - initial_event - in - return_unit) diff --git a/src/proto_020_PsParisC/lib_delegate/baking_scheduling.mli b/src/proto_020_PsParisC/lib_delegate/baking_scheduling.mli deleted file mode 100644 index ba9f10403d66..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_scheduling.mli +++ /dev/null @@ -1,114 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Baking_state -open Protocol.Alpha_context - -type loop_state - -val create_loop_state : - ?get_valid_blocks_stream:proposal Lwt_stream.t Lwt.t -> - heads_stream:proposal Lwt_stream.t -> - forge_event_stream:forge_event Lwt_stream.t -> - Operation_worker.t -> - loop_state - -val sleep_until : Time.Protocol.t -> unit Lwt.t option - -(** [retry ctxt ~delay ?max_delay ~factor ~tries ?msg f x] retries applying [f - x] [tries] until it succeeds or returns an error different from - [Connection_failed], at most [tries] number of times. After each try it - waits for a number of seconds, but not more than [max_delay], if given. The - wait time between tries is given by the initial [delay], multiplied by - [factor] at each subsequent try. At each failure, [msg] together with the - current delay is printed using [ctxt#message].*) -val retry : - #Protocol_client_context.full -> - ?max_delay:float -> - delay:float -> - factor:float -> - tries:int -> - ?msg:string -> - ('a -> 'b tzresult Lwt.t) -> - 'a -> - 'b tzresult Lwt.t - -(** An event monitor using the streams in [loop_state] (to create - promises) and a timeout promise [timeout]. The function reacts to a - promise being fulfilled by firing an event [Baking_state.event]. *) -val wait_next_event : - timeout:[`Timeout of timeout_kind] Lwt.t -> - loop_state -> - (event option, error trace) result Lwt.t - -(** Returns the first round at the next level, at or after - [earliest_round], whose baking slot belongs to one of our own - delegates; also returns the corresponding delegate. Or returns - [None] if no such round exists. *) -val first_potential_round_at_next_level : - state -> - earliest_round:Round.t -> - (Round.t * consensus_key_and_delegate) option - -val compute_next_potential_baking_time_at_next_level : - state -> (Time.Protocol.t * Round.t) option Lwt.t - -val compute_next_timeout : state -> timeout_kind Lwt.t tzresult Lwt.t - -val create_initial_state : - Protocol_client_context.full -> - ?synchronize:bool -> - chain:Chain_services.chain -> - Baking_configuration.t -> - Operation_worker.t -> - current_proposal:proposal -> - ?constants:Constants.t -> - consensus_key list -> - state tzresult Lwt.t - -val compute_bootstrap_event : state -> event tzresult - -val automaton_loop : - ?stop_on_event:(event -> bool) -> - config:Baking_configuration.t -> - on_error:(tztrace -> (unit, tztrace) result Lwt.t) -> - loop_state -> - state -> - event -> - event option tzresult Lwt.t - -val run : - Protocol_client_context.full -> - ?canceler:Lwt_canceler.t -> - ?stop_on_event:(event -> bool) -> - ?on_error:(tztrace -> unit tzresult Lwt.t) -> - ?constants:Constants.t -> - chain:Chain_services.chain -> - Baking_configuration.t -> - consensus_key list -> - unit tzresult Lwt.t - -val create_dal_node_rpc_ctxt : - Uri.t -> Tezos_rpc_http_client_unix.RPC_client_unix.http_ctxt diff --git a/src/proto_020_PsParisC/lib_delegate/baking_simulator.ml b/src/proto_020_PsParisC/lib_delegate/baking_simulator.ml deleted file mode 100644 index 84c09c7c5d27..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_simulator.ml +++ /dev/null @@ -1,172 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol -open Alpha_context -open Baking_errors - -type incremental = { - predecessor : Baking_state.block_info; - context : Tezos_protocol_environment.Context.t; - state : Protocol.validation_state * Protocol.application_state option; - rev_operations : Operation.packed list; - header : Tezos_base.Block_header.shell_header; -} - -let load_context ~context_path = - let open Lwt_result_syntax in - protect (fun () -> - let*! index = Context_ops.init ~kind:`Disk ~readonly:true context_path in - return (Abstract_context_index.abstract index)) - -let check_context_consistency (abstract_index : Abstract_context_index.t) - context_hash = - let open Lwt_result_syntax in - protect (fun () -> - (* Hypothesis : the version key exists *) - let version_key = ["version"] in - let*! context_opt = abstract_index.checkout_fun context_hash in - match context_opt with - | None -> tzfail Failed_to_checkout_context - | Some context -> ( - let*! result = Context_ops.mem context version_key in - match result with - | true -> return_unit - | false -> tzfail Invalid_context)) - -let begin_construction ~timestamp ~protocol_data ~force_apply - ~pred_resulting_context_hash (abstract_index : Abstract_context_index.t) - pred_block chain_id = - let open Lwt_result_syntax in - protect (fun () -> - let {Baking_state.shell = pred_shell; hash = pred_hash; _} = pred_block in - let*! context_opt = - abstract_index.checkout_fun pred_resulting_context_hash - in - match context_opt with - | None -> tzfail Failed_to_checkout_context - | Some context -> - let header : Tezos_base.Block_header.shell_header = - Tezos_base.Block_header. - { - predecessor = pred_hash; - proto_level = pred_shell.proto_level; - validation_passes = 0; - fitness = pred_shell.fitness; - timestamp; - level = pred_shell.level; - context = Context_hash.zero (* fake context hash *); - operations_hash = - Operation_list_list_hash.zero (* fake op hash *); - } - in - let mode = - Lifted_protocol.Construction - { - predecessor_hash = pred_hash; - timestamp; - block_header_data = protocol_data; - } - in - let* validation_state = - Lifted_protocol.begin_validation - context - chain_id - mode - ~predecessor:pred_shell - ~cache:`Lazy - in - let* application_state = - if force_apply then - let* application_state = - Lifted_protocol.begin_application - context - chain_id - mode - ~predecessor:pred_shell - ~cache:`Lazy - in - return_some application_state - else return_none - in - let state = (validation_state, application_state) in - return - { - predecessor = pred_block; - context; - state; - rev_operations = []; - header; - }) - -let ( let** ) x k = - let open Lwt_result_syntax in - let*! x in - let*? x = Environment.wrap_tzresult x in - k x - -let add_operation st (op : Operation.packed) = - let open Lwt_result_syntax in - protect (fun () -> - let validation_state, application_state = st.state in - let oph = Operation.hash_packed op in - let** validation_state = - Protocol.validate_operation - ~check_signature:false - (* We assume that the operation has already been validated in the - node, therefore the signature has already been checked, but we - still need to validate it again because the context may be - different. *) - validation_state - oph - op - in - let** application_state, receipt = - match application_state with - | Some application_state -> - let* application_state, receipt = - Protocol.apply_operation application_state oph op - in - return (Some application_state, Some receipt) - | None -> return (None, None) - in - let state = (validation_state, application_state) in - return ({st with state; rev_operations = op :: st.rev_operations}, receipt)) - -let finalize_construction inc = - let open Lwt_result_syntax in - protect (fun () -> - let validation_state, application_state = inc.state in - let** () = Protocol.finalize_validation validation_state in - let** result = - match application_state with - | Some application_state -> - let* result = - Protocol.finalize_application application_state (Some inc.header) - in - return_some result - | None -> return_none - in - return result) diff --git a/src/proto_020_PsParisC/lib_delegate/baking_simulator.mli b/src/proto_020_PsParisC/lib_delegate/baking_simulator.mli deleted file mode 100644 index c5155ac45ee0..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_simulator.mli +++ /dev/null @@ -1,81 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol -open Alpha_context - -type incremental = { - predecessor : Baking_state.block_info; - context : Tezos_protocol_environment.Context.t; - state : validation_state * application_state option; - rev_operations : Operation.packed list; - header : Tezos_base.Block_header.shell_header; -} - -val load_context : - context_path:string -> Abstract_context_index.t tzresult Lwt.t - -(** Make sure that the given context is consistent by trying to read in it *) -val check_context_consistency : - Abstract_context_index.t -> Context_hash.t -> unit tzresult Lwt.t - -(** [begin_construction ~timestamp ~protocol_data ~force_apply abstract_context - predecessor chain_id] creates a new [incremental] value with an empty - operation list. A [context] is recovered from the [abstract_index] and the - resulting_context_hash from [predecessor]. This context is used to create a - [validation_state] and an [application_state] (if [force_apply] is set). A - partial [shell_header] is created from [predecessor] information and - [timestamp]. *) -val begin_construction : - timestamp:Time.Protocol.t -> - protocol_data:block_header_data -> - force_apply:bool -> - pred_resulting_context_hash:Context_hash.t -> - Abstract_context_index.t -> - Baking_state.block_info -> - Chain_id.t -> - incremental tzresult Lwt.t - -(** [add_operation incremental op] validates [op] in - [incremental.validation_state] without checking its signature. Indeed, the - operation has already been validated in the node so it has a correct - signature. We still need to validate it again because the context may be - different. [op] is also applied if [incremental] has been created with - [force_apply] set. This function returns an [incremental] with updated - operations list and [validation_state] (and [application_state]). *) -val add_operation : - incremental -> - Operation.packed -> - (incremental * operation_receipt option) tzresult Lwt.t - -(** [finalize_construction incremental] calls the [finalize_validation] of the - protocol on the [validation_state] from [incremental]. If [incremental] has - been created with [force_apply] set, [finalize_application] is also called - and its results returned. *) -val finalize_construction : - incremental -> - (Tezos_protocol_environment.validation_result * block_header_metadata) option - tzresult - Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/baking_state.ml b/src/proto_020_PsParisC/lib_delegate/baking_state.ml deleted file mode 100644 index 13578c56158d..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_state.ml +++ /dev/null @@ -1,1468 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context -open Baking_errors - -module Profiler = (val Profiler.wrap Baking_profiler.baker_profiler) - -(** A consensus key (aka, a validator) is identified by its alias name, its - public key, its public key hash, and its secret key. *) -type consensus_key = { - alias : string option; - public_key : Signature.Public_key.t; - public_key_hash : Signature.Public_key_hash.t; - secret_key_uri : Client_keys.sk_uri; -} - -let consensus_key_encoding = - let open Data_encoding in - conv - (fun {alias; public_key; public_key_hash; secret_key_uri} -> - ( alias, - public_key, - public_key_hash, - Uri.to_string (secret_key_uri :> Uri.t) )) - (fun (alias, public_key, public_key_hash, secret_key_uri) -> - { - alias; - public_key; - public_key_hash; - secret_key_uri = - (match Client_keys.make_sk_uri (Uri.of_string secret_key_uri) with - | Ok sk -> sk - | Error e -> Format.kasprintf Stdlib.failwith "%a" pp_print_trace e); - }) - (obj4 - (req "alias" (option string)) - (req "public_key" Signature.Public_key.encoding) - (req "public_key_hash" Signature.Public_key_hash.encoding) - (req "secret_key_uri" string)) - -let pp_consensus_key fmt {alias; public_key_hash; _} = - match alias with - | None -> Format.fprintf fmt "%a" Signature.Public_key_hash.pp public_key_hash - | Some alias -> - Format.fprintf - fmt - "%s (%a)" - alias - Signature.Public_key_hash.pp - public_key_hash - -type consensus_key_and_delegate = consensus_key * Signature.Public_key_hash.t - -let consensus_key_and_delegate_encoding = - let open Data_encoding in - merge_objs - consensus_key_encoding - (obj1 (req "delegate" Signature.Public_key_hash.encoding)) - -let pp_consensus_key_and_delegate fmt (consensus_key, delegate) = - if Signature.Public_key_hash.equal consensus_key.public_key_hash delegate then - pp_consensus_key fmt consensus_key - else - Format.fprintf - fmt - "%a@,on behalf of %a" - pp_consensus_key - consensus_key - Signature.Public_key_hash.pp - delegate - -type validation_mode = Node | Local of Abstract_context_index.t - -type prequorum = { - level : int32; - round : Round.t; - block_payload_hash : Block_payload_hash.t; - preattestations : Kind.preattestation operation list; -} - -type block_info = { - hash : Block_hash.t; - shell : Block_header.shell_header; - payload_hash : Block_payload_hash.t; - payload_round : Round.t; - round : Round.t; - prequorum : prequorum option; - quorum : Kind.attestation operation list; - payload : Operation_pool.payload; -} - -type cache = { - known_timestamps : Timestamp.time Baking_cache.Timestamp_of_round_cache.t; - round_timestamps : - (Timestamp.time * Round.t * consensus_key_and_delegate) - Baking_cache.Round_timestamp_interval_cache.t; -} - -let prequorum_encoding = - let open Data_encoding in - conv - (fun {level; round; block_payload_hash; preattestations} -> - (level, round, block_payload_hash, List.map Operation.pack preattestations)) - (fun (level, round, block_payload_hash, preattestations) -> - { - level; - round; - block_payload_hash; - preattestations = - List.filter_map Operation_pool.unpack_preattestation preattestations; - }) - (obj4 - (req "level" int32) - (req "round" Round.encoding) - (req "block_payload_hash" Block_payload_hash.encoding) - (req "preattestations" (list (dynamic_size Operation.encoding)))) - -let block_info_encoding = - let open Data_encoding in - conv - (fun { - hash; - shell; - payload_hash; - payload_round; - round; - prequorum; - quorum; - payload; - } -> - ( hash, - shell, - payload_hash, - payload_round, - round, - prequorum, - List.map Operation.pack quorum, - payload )) - (fun ( hash, - shell, - payload_hash, - payload_round, - round, - prequorum, - quorum, - payload ) -> - { - hash; - shell; - payload_hash; - payload_round; - round; - prequorum; - quorum = List.filter_map Operation_pool.unpack_attestation quorum; - payload; - }) - (obj8 - (req "hash" Block_hash.encoding) - (req "shell" Block_header.shell_header_encoding) - (req "payload_hash" Block_payload_hash.encoding) - (req "payload_round" Round.encoding) - (req "round" Round.encoding) - (req "prequorum" (option prequorum_encoding)) - (req "quorum" (list (dynamic_size Operation.encoding))) - (req "payload" Operation_pool.payload_encoding)) - -let round_of_shell_header shell_header = - let open Result_syntax in - let* fitness = - Environment.wrap_tzresult - @@ Fitness.from_raw shell_header.Tezos_base.Block_header.fitness - in - return (Fitness.round fitness) - -module SlotMap : Map.S with type key = Slot.t = Map.Make (Slot) - -type delegate_slot = { - consensus_key_and_delegate : consensus_key_and_delegate; - first_slot : Slot.t; - attesting_power : int; -} - -module Delegate_slots = struct - (* Note that we also use the delegate slots as proposal slots. *) - type t = { - own_delegates : delegate_slot list; - own_delegate_slots : delegate_slot SlotMap.t; - (* This map cannot have as keys just the first slot of delegates, - because it is used in [round_proposer] for which we need all slots, - as the round can be arbitrary. *) - all_delegate_voting_power : int SlotMap.t; - (* This is a map having as keys the first slot of all delegates, and as - values their attesting power. - This map contains just the first slot for a delegate, because it is - only used in [slot_voting_power] which is about (pre)attestations, - not proposals. Indeed, only (pre)attestations that use the delegate's - first slot are valid for inclusion in a block and count toward the - (pre)quorum. Note that the baker might receive nominally valid - non-first-slot operations from the mempool because this check is - skipped in the mempool to increase its speed; the baker can and - should ignore such operations. *) - } - - let own_delegates slots = slots.own_delegates - - let own_slot_owner slots ~slot = SlotMap.find slot slots.own_delegate_slots - - let voting_power slots ~slot = - SlotMap.find slot slots.all_delegate_voting_power -end - -type delegate_slots = Delegate_slots.t - -type dal_attestable_slots = - (Signature.Public_key_hash.t - * Tezos_dal_node_services.Types.attestable_slots tzresult Lwt.t) - list - -type proposal = {block : block_info; predecessor : block_info} - -let proposal_encoding = - let open Data_encoding in - conv - (fun {block; predecessor} -> (block, predecessor)) - (fun (block, predecessor) -> {block; predecessor}) - (obj2 - (req "block" block_info_encoding) - (req "predecessor" block_info_encoding)) - -let is_first_block_in_protocol {block; predecessor; _} = - Compare.Int.(block.shell.proto_level <> predecessor.shell.proto_level) - -type locked_round = {payload_hash : Block_payload_hash.t; round : Round.t} - -let locked_round_encoding = - let open Data_encoding in - conv - (fun {payload_hash; round} -> (payload_hash, round)) - (fun (payload_hash, round) -> {payload_hash; round}) - (obj2 - (req "payload_hash" Block_payload_hash.encoding) - (req "round" Round.encoding)) - -type attestable_payload = {proposal : proposal; prequorum : prequorum} - -let attestable_payload_encoding = - let open Data_encoding in - conv - (fun {proposal; prequorum} -> (proposal, prequorum)) - (fun (proposal, prequorum) -> {proposal; prequorum}) - (obj2 - (req "proposal" proposal_encoding) - (req "prequorum" prequorum_encoding)) - -type elected_block = { - proposal : proposal; - attestation_qc : Kind.attestation Operation.t list; -} - -type manager_operations_infos = { - manager_operation_number : int; - total_fees : Int64.t; -} - -type prepared_block = { - signed_block_header : block_header; - round : Round.t; - delegate : consensus_key_and_delegate; - operations : Tezos_base.Operation.t list list; - manager_operations_infos : manager_operations_infos option; - baking_votes : Per_block_votes_repr.per_block_votes; -} - -(* The fields {current_level}, {delegate_slots}, {next_level_delegate_slots}, - {next_level_proposed_round}, {dal_attestable_slots}, - {next_level_dal_attestable_slots} are updated only when we receive a block at - a different level than {current_level}. Note that this means that there is - always a {latest_proposal}, which may be our own baked block. *) -type level_state = { - current_level : int32; - latest_proposal : proposal; - is_latest_proposal_applied : bool; - (* Last proposal received where we injected an attestation (thus we - have seen 2f+1 preattestations) *) - locked_round : locked_round option; - (* Latest payload where we've seen a proposal reach 2f+1 preattestations *) - attestable_payload : attestable_payload option; - (* Block for which we've seen 2f+1 attestations and that we may bake onto *) - elected_block : elected_block option; - delegate_slots : delegate_slots; - next_level_delegate_slots : delegate_slots; - next_level_proposed_round : Round.t option; - dal_attestable_slots : dal_attestable_slots; - next_level_dal_attestable_slots : dal_attestable_slots; -} - -type phase = - | Idle - | Awaiting_preattestations - | Awaiting_attestations - | Awaiting_application - -let phase_encoding = - let open Data_encoding in - union - ~tag_size:`Uint8 - [ - case - ~title:"Idle" - (Tag 0) - (constant "Idle") - (function Idle -> Some () | _ -> None) - (fun () -> Idle); - case - ~title:"Awaiting_preattestations" - (Tag 1) - (constant "Awaiting_preattestations") - (function Awaiting_preattestations -> Some () | _ -> None) - (fun () -> Awaiting_preattestations); - case - ~title:"Awaiting_application" - (Tag 2) - (constant "Awaiting_application") - (function Awaiting_application -> Some () | _ -> None) - (fun () -> Awaiting_application); - case - ~title:"Awaiting_attestationss" - (Tag 3) - (constant "Awaiting_attestationss") - (function Awaiting_attestations -> Some () | _ -> None) - (fun () -> Awaiting_attestations); - ] - -type block_kind = - | Fresh of Operation_pool.pool - | Reproposal of { - consensus_operations : packed_operation list; - payload_hash : Block_payload_hash.t; - payload_round : Round.t; - payload : Operation_pool.payload; - } - -type block_to_bake = { - predecessor : block_info; - round : Round.t; - delegate : consensus_key_and_delegate; - kind : block_kind; - force_apply : bool; -} - -type consensus_vote_kind = Attestation | Preattestation - -let consensus_vote_kind_encoding = - let open Data_encoding in - union - [ - case - (Tag 0) - ~title:"preattestation" - unit - (function Preattestation -> Some () | _ -> None) - (fun () -> Preattestation); - case - (Tag 1) - ~title:"attestation" - unit - (function Attestation -> Some () | _ -> None) - (fun () -> Attestation); - ] - -let pp_consensus_vote_kind fmt = function - | Attestation -> Format.fprintf fmt "attestation" - | Preattestation -> Format.fprintf fmt "preattestation" - -type unsigned_consensus_vote = { - vote_kind : consensus_vote_kind; - vote_consensus_content : consensus_content; - delegate : consensus_key_and_delegate; - dal_content : dal_content option; -} - -type batch_content = { - level : Raw_level.t; - round : Round.t; - block_payload_hash : Block_payload_hash.t; -} - -type unsigned_consensus_vote_batch = { - batch_kind : consensus_vote_kind; - batch_content : batch_content; - batch_branch : Block_hash.t; - unsigned_consensus_votes : unsigned_consensus_vote list; -} - -let make_unsigned_consensus_vote_batch kind - ({level; round; block_payload_hash} as batch_content) ~batch_branch - delegates_and_slots = - let unsigned_consensus_votes = - List.map - (fun (delegate, slot) -> - let consensus_content = {level; round; slot; block_payload_hash} in - { - vote_kind = kind; - vote_consensus_content = consensus_content; - delegate; - dal_content = None; - }) - delegates_and_slots - in - {batch_kind = kind; batch_branch; batch_content; unsigned_consensus_votes} - -let dal_content_map_p f unsigned_consensus_vote_batch = - let open Lwt_syntax in - let* patched_unsigned_consensus_votes = - List.map_p - (fun unsigned_consensus_vote -> - let fallback_case = - { - unsigned_consensus_vote with - dal_content = Some {attestation = Dal.Attestation.empty}; - } - in - Lwt.catch - (fun () -> - let* dal_content = f unsigned_consensus_vote in - match dal_content with - | Ok dal_content -> - return {unsigned_consensus_vote with dal_content} - | Error _ -> return fallback_case) - (fun _exn -> return fallback_case)) - unsigned_consensus_vote_batch.unsigned_consensus_votes - in - return - { - unsigned_consensus_vote_batch with - unsigned_consensus_votes = patched_unsigned_consensus_votes; - } - -type signed_consensus_vote = { - unsigned_consensus_vote : unsigned_consensus_vote; - signed_operation : packed_operation; -} - -type signed_consensus_vote_batch = { - batch_kind : consensus_vote_kind; - batch_content : batch_content; - batch_branch : Block_hash.t; - signed_consensus_votes : signed_consensus_vote list; -} - -type error += Mismatch_signed_consensus_vote_in_batch - -let () = - register_error_kind - `Permanent - ~id:"Baking_state.mismatch_signed_consensus_vote_in_batch" - ~title:"Mismatch signed consensus vote in batch" - ~description:"Consensus votes mismatch while creating a batch." - ~pp:(fun ppf () -> - Format.fprintf - ppf - "There are batched consensus votes which are not of the same kind or \ - do not have the same consensus content as the rest.") - Data_encoding.unit - (function Mismatch_signed_consensus_vote_in_batch -> Some () | _ -> None) - (fun () -> Mismatch_signed_consensus_vote_in_batch) - -let make_signed_consensus_vote_batch batch_kind (batch_content : batch_content) - ~batch_branch signed_consensus_votes = - let open Result_syntax in - let* () = - List.iter_e - (fun {unsigned_consensus_vote; signed_operation = _} -> - error_when - (unsigned_consensus_vote.vote_kind <> batch_kind - || Raw_level.( - unsigned_consensus_vote.vote_consensus_content.level - <> batch_content.level) - || Round.( - unsigned_consensus_vote.vote_consensus_content.round - <> batch_content.round) - || Block_payload_hash.( - unsigned_consensus_vote.vote_consensus_content.block_payload_hash - <> batch_content.block_payload_hash)) - Mismatch_signed_consensus_vote_in_batch) - signed_consensus_votes - in - return {batch_kind; batch_content; batch_branch; signed_consensus_votes} - -let make_singleton_consensus_vote_batch - (signed_consensus_vote : signed_consensus_vote) = - let {unsigned_consensus_vote; _} = signed_consensus_vote in - let batch_content = - { - level = unsigned_consensus_vote.vote_consensus_content.level; - round = unsigned_consensus_vote.vote_consensus_content.round; - block_payload_hash = - unsigned_consensus_vote.vote_consensus_content.block_payload_hash; - } - in - { - batch_kind = unsigned_consensus_vote.vote_kind; - batch_content; - batch_branch = signed_consensus_vote.signed_operation.shell.branch; - signed_consensus_votes = [signed_consensus_vote]; - } - -type round_state = { - current_round : Round.t; - current_phase : phase; - delayed_quorum : Kind.attestation operation list option; - early_attestations : signed_consensus_vote list; - awaiting_unlocking_pqc : bool; -} - -type forge_event = - | Block_ready of prepared_block - | Preattestation_ready of signed_consensus_vote - | Attestation_ready of signed_consensus_vote - -type forge_request = - | Forge_and_sign_block of block_to_bake - | Forge_and_sign_preattestations of { - unsigned_preattestations : unsigned_consensus_vote_batch; - } - | Forge_and_sign_attestations of { - unsigned_attestations : unsigned_consensus_vote_batch; - } - -type forge_worker_hooks = { - push_request : forge_request -> unit; - get_forge_event_stream : unit -> forge_event Lwt_stream.t; - cancel_all_pending_tasks : unit -> unit; -} - -type global_state = { - (* client context *) - cctxt : Protocol_client_context.full; - (* chain id *) - chain_id : Chain_id.t; - (* baker configuration *) - config : Baking_configuration.t; - (* protocol constants *) - constants : Constants.t; - (* round durations *) - round_durations : Round.round_durations; - (* worker that monitor and aggregates new operations *) - operation_worker : Operation_worker.t; - (* hooks to the consensus and block forge worker *) - mutable forge_worker_hooks : forge_worker_hooks; - (* the validation mode used by the baker*) - validation_mode : validation_mode; - (* the delegates on behalf of which the baker is running *) - delegates : consensus_key list; - cache : cache; - dal_node_rpc_ctxt : Tezos_rpc.Context.generic option; -} - -type state = { - global_state : global_state; - level_state : level_state; - round_state : round_state; -} - -type t = state - -let update_current_phase state new_phase = - {state with round_state = {state.round_state with current_phase = new_phase}} - -type timeout_kind = - | End_of_round of {ending_round : Round.t} - | Time_to_prepare_next_level_block of {at_round : Round.t} - -let timeout_kind_encoding = - let open Data_encoding in - union - [ - case - (Tag 0) - ~title:"End_of_round" - (obj2 - (req "kind" (constant "End_of_round")) - (req "round" Round.encoding)) - (function - | End_of_round {ending_round} -> Some ((), ending_round) | _ -> None) - (fun ((), ending_round) -> End_of_round {ending_round}); - case - (Tag 1) - ~title:"Time_to_prepare_next_level_block" - (obj2 - (req "kind" (constant "Time_to_prepare_next_level_block")) - (req "round" Round.encoding)) - (function - | Time_to_prepare_next_level_block {at_round} -> Some ((), at_round) - | _ -> None) - (fun ((), at_round) -> Time_to_prepare_next_level_block {at_round}); - ] - -type event = - | New_valid_proposal of proposal - | New_head_proposal of proposal - | Prequorum_reached of - Operation_worker.candidate * Kind.preattestation operation list - | Quorum_reached of - Operation_worker.candidate * Kind.attestation operation list - | New_forge_event of forge_event - | Timeout of timeout_kind - -let event_encoding = - let open Data_encoding in - union - [ - case - (Tag 0) - ~title:"New_valid_proposal" - (tup2 (constant "New_valid_proposal") proposal_encoding) - (function New_valid_proposal p -> Some ((), p) | _ -> None) - (fun ((), p) -> New_valid_proposal p); - case - (Tag 1) - ~title:"New_head_proposal" - (tup2 (constant "New_head_proposal") proposal_encoding) - (function New_head_proposal p -> Some ((), p) | _ -> None) - (fun ((), p) -> New_head_proposal p); - case - (Tag 2) - ~title:"Prequorum_reached" - (tup3 - (constant "Prequorum_reached") - Operation_worker.candidate_encoding - (Data_encoding.list (dynamic_size Operation.encoding))) - (function - | Prequorum_reached (candidate, ops) -> - Some ((), candidate, List.map Operation.pack ops) - | _ -> None) - (fun ((), candidate, ops) -> - Prequorum_reached - (candidate, Operation_pool.filter_preattestations ops)); - case - (Tag 3) - ~title:"Quorum_reached" - (tup3 - (constant "Quorum_reached") - Operation_worker.candidate_encoding - (Data_encoding.list (dynamic_size Operation.encoding))) - (function - | Quorum_reached (candidate, ops) -> - Some ((), candidate, List.map Operation.pack ops) - | _ -> None) - (fun ((), candidate, ops) -> - Quorum_reached (candidate, Operation_pool.filter_attestations ops)); - case - (Tag 4) - ~title:"Timeout" - (tup2 (constant "Timeout") timeout_kind_encoding) - (function Timeout tk -> Some ((), tk) | _ -> None) - (fun ((), tk) -> Timeout tk); - ] - -let vote_kind_encoding = - let open Data_encoding in - union - [ - case - (Tag 0) - ~title:"Preattestation" - unit - (function Preattestation -> Some () | _ -> None) - (fun () -> Preattestation); - case - (Tag 1) - ~title:"Attestation" - unit - (function Attestation -> Some () | _ -> None) - (fun () -> Attestation); - ] - -let unsigned_consensus_vote_encoding = - let open Data_encoding in - let dal_content_encoding : dal_content encoding = - conv - (fun {attestation} -> attestation) - (fun attestation -> {attestation}) - Dal.Attestation.encoding - in - conv - (fun {vote_kind; vote_consensus_content; delegate; dal_content} -> - (vote_kind, vote_consensus_content, delegate, dal_content)) - (fun (vote_kind, vote_consensus_content, delegate, dal_content) -> - {vote_kind; vote_consensus_content; delegate; dal_content}) - (obj4 - (req "vote_kind" vote_kind_encoding) - (req "vote_consensus_content" consensus_content_encoding) - (req "delegate" consensus_key_and_delegate_encoding) - (opt "dal_content" dal_content_encoding)) - -let signed_consensus_vote_encoding = - let open Data_encoding in - conv - (fun {unsigned_consensus_vote; signed_operation} -> - (unsigned_consensus_vote, signed_operation)) - (fun (unsigned_consensus_vote, signed_operation) -> - {unsigned_consensus_vote; signed_operation}) - (obj2 - (req "unsigned_consensus_vote" unsigned_consensus_vote_encoding) - (req "signed_operation" (dynamic_size Operation.encoding))) - -let manager_operations_infos_encoding = - let open Data_encoding in - conv - (fun {manager_operation_number; total_fees} -> - (manager_operation_number, total_fees)) - (fun (manager_operation_number, total_fees) -> - {manager_operation_number; total_fees}) - (obj2 (req "manager_operation_number" int31) (req "total_fees" int64)) - -let forge_event_encoding = - let open Data_encoding in - let prepared_block_encoding = - conv - (fun { - signed_block_header; - round; - delegate; - operations; - manager_operations_infos; - baking_votes; - } -> - ( signed_block_header, - round, - delegate, - operations, - manager_operations_infos, - baking_votes )) - (fun ( signed_block_header, - round, - delegate, - operations, - manager_operations_infos, - baking_votes ) -> - { - signed_block_header; - round; - delegate; - operations; - manager_operations_infos; - baking_votes; - }) - (obj6 - (req "header" (dynamic_size Block_header.encoding)) - (req "round" Round.encoding) - (req "delegate" consensus_key_and_delegate_encoding) - (req - "operations" - (list (list (dynamic_size Tezos_base.Operation.encoding)))) - (opt "operations_infos" manager_operations_infos_encoding) - (req "baking_votes" Per_block_votes.per_block_votes_encoding)) - in - union - [ - case - (Tag 0) - ~title:"Block_ready" - (obj1 (req "signed_block" prepared_block_encoding)) - (function - | Block_ready prepared_block -> Some prepared_block | _ -> None) - (fun prepared_block -> Block_ready prepared_block); - case - (Tag 1) - ~title:"Preattestation_ready" - (obj1 (req "signed_preattestation" signed_consensus_vote_encoding)) - (function - | Preattestation_ready signed_preattestation -> - Some signed_preattestation - | _ -> None) - (fun signed_preattestation -> - Preattestation_ready signed_preattestation); - case - (Tag 2) - ~title:"Attestation_ready" - (obj1 (req "signed_attestation" signed_consensus_vote_encoding)) - (function - | Attestation_ready signed_attestation -> Some signed_attestation - | _ -> None) - (fun signed_attestation -> Attestation_ready signed_attestation); - ] - -(* Disk state *) - -module Events = struct - include Internal_event.Simple - - let section = [Protocol.name; "baker"; "disk"] - - let incompatible_stored_state = - declare_0 - ~section - ~name:"incompatible_stored_state" - ~level:Warning - ~msg:"found an outdated or corrupted baking state: discarding it" - () -end - -type state_data = { - level_data : int32; - locked_round_data : locked_round option; - attestable_payload_data : attestable_payload option; -} - -let state_data_encoding = - let open Data_encoding in - conv - (fun {level_data; locked_round_data; attestable_payload_data} -> - (level_data, locked_round_data, attestable_payload_data)) - (fun (level_data, locked_round_data, attestable_payload_data) -> - {level_data; locked_round_data; attestable_payload_data}) - (obj3 - (req "level" int32) - (req "locked_round" (option locked_round_encoding)) - (req "attestable_payload" (option attestable_payload_encoding))) - -let record_state (state : state) = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - let location = - Baking_files.resolve_location ~chain_id:state.global_state.chain_id `State - in - let filename = - Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) - in - protect @@ fun () -> - cctxt#with_lock @@ fun () -> - let level_data = state.level_state.current_level in - let locked_round_data = state.level_state.locked_round in - let attestable_payload_data = state.level_state.attestable_payload in - let bytes = - Data_encoding.Binary.to_bytes_exn - state_data_encoding - {level_data; locked_round_data; attestable_payload_data} - in - let filename_tmp = filename ^ "_tmp" in - let*! () = - Lwt_io.with_file - ~flags:[Unix.O_CREAT; O_WRONLY; O_TRUNC; O_CLOEXEC; O_SYNC] - ~mode:Output - filename_tmp - (fun channel -> - Lwt_io.write_from_exactly channel bytes 0 (Bytes.length bytes)) - in - let*! () = Lwt_unix.rename filename_tmp filename in - return_unit - -let may_record_new_state ~previous_state ~new_state = - let open Lwt_result_syntax in - if new_state.global_state.config.state_recorder = Baking_configuration.Memory - then return_unit - else - let { - current_level = previous_current_level; - locked_round = previous_locked_round; - attestable_payload = previous_attestable_payload; - _; - } = - previous_state.level_state - in - let { - current_level = new_current_level; - locked_round = new_locked_round; - attestable_payload = new_attestable_payload; - _; - } = - new_state.level_state - in - let is_new_state_consistent = - Compare.Int32.(new_current_level > previous_current_level) - || new_current_level = previous_current_level - && - if Compare.Int32.(new_current_level = previous_current_level) then - let is_new_locked_round_consistent = - match (new_locked_round, previous_locked_round) with - | None, None -> true - | Some _, None -> true - | None, Some _ -> false - | Some new_locked_round, Some previous_locked_round -> - Round.(new_locked_round.round >= previous_locked_round.round) - in - let is_new_attestable_payload_consistent = - match (new_attestable_payload, previous_attestable_payload) with - | None, None -> true - | Some _, None -> true - | None, Some _ -> false - | Some new_attestable_payload, Some previous_attestable_payload -> - Round.( - new_attestable_payload.proposal.block.round - >= previous_attestable_payload.proposal.block.round) - in - is_new_locked_round_consistent - && is_new_attestable_payload_consistent - else true - in - let* () = - fail_unless is_new_state_consistent Broken_locked_values_invariant - in - let has_not_changed = - previous_state.level_state.current_level - == new_state.level_state.current_level - && previous_state.level_state.locked_round - == new_state.level_state.locked_round - && previous_state.level_state.attestable_payload - == new_state.level_state.attestable_payload - in - if has_not_changed then return_unit else record_state new_state - -let load_attestable_data cctxt location = - let open Lwt_result_syntax in - protect (fun () -> - let filename = - Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) - in - let*! exists = Lwt_unix.file_exists filename in - match exists with - | false -> return_none - | true -> - Lwt_io.with_file - ~flags:[Unix.O_EXCL; O_RDONLY; O_CLOEXEC] - ~mode:Input - filename - (fun channel -> - let*! str = Lwt_io.read channel in - match - Data_encoding.Binary.of_string_opt state_data_encoding str - with - | Some state_data -> return_some state_data - | None -> - (* The stored state format is incompatible: discard it. *) - let*! () = Events.(emit incompatible_stored_state ()) in - return_none)) - -let may_load_attestable_data state = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - let chain_id = state.global_state.chain_id in - let location = Baking_files.resolve_location ~chain_id `State in - protect ~on_error:(fun _ -> return state) @@ fun () -> - cctxt#with_lock @@ fun () -> - let* attestable_data_opt = load_attestable_data cctxt location in - match attestable_data_opt with - | None -> return state - | Some {level_data; locked_round_data; attestable_payload_data} -> - if Compare.Int32.(state.level_state.current_level = level_data) then - let loaded_level_state = - { - state.level_state with - locked_round = locked_round_data; - attestable_payload = attestable_payload_data; - } - in - return {state with level_state = loaded_level_state} - else return state - -(* Helpers *) - -module DelegateSet = struct - include Set.Make (struct - type t = consensus_key - - let compare {public_key_hash = pkh; _} {public_key_hash = pkh'; _} = - Signature.Public_key_hash.compare pkh pkh' - end) - - let find_pkh pkh s = - let exception Found of elt in - try - iter - (fun ({public_key_hash; _} as delegate) -> - if Signature.Public_key_hash.equal pkh public_key_hash then - raise (Found delegate) - else ()) - s ; - None - with Found d -> Some d -end - -let delegate_slots attesting_rights delegates = - let own_delegates = DelegateSet.of_list delegates in - let own_delegate_first_slots, own_delegate_slots, all_delegate_voting_power = - List.fold_left - (fun (own_list, own_map, all_map) slot -> - let {Plugin.RPC.Validators.consensus_key; delegate; slots; _} = slot in - let first_slot = Stdlib.List.hd slots in - let attesting_power = List.length slots in - let all_map = SlotMap.add first_slot attesting_power all_map in - let own_list, own_map = - match DelegateSet.find_pkh consensus_key own_delegates with - | Some consensus_key -> - let attesting_slot = - { - consensus_key_and_delegate = (consensus_key, delegate); - first_slot; - attesting_power; - } - in - ( attesting_slot :: own_list, - List.fold_left - (fun own_map slot -> SlotMap.add slot attesting_slot own_map) - own_map - slots ) - | None -> (own_list, own_map) - in - (own_list, own_map, all_map)) - ([], SlotMap.empty, SlotMap.empty) - attesting_rights - in - Delegate_slots. - { - own_delegates = own_delegate_first_slots; - own_delegate_slots; - all_delegate_voting_power; - } - -let compute_delegate_slots (cctxt : Protocol_client_context.full) - ?(block = `Head 0) ~level ~chain delegates = - let open Lwt_result_syntax in - let*? level = Environment.wrap_tzresult (Raw_level.of_int32 level) in - let* attesting_rights = - (Plugin.RPC.Validators.get - cctxt - (chain, block) - ~levels:[level] - [@profiler.record_s {verbosity = Debug} "RPC: get attesting rights"]) - in - let delegate_slots = - (delegate_slots - attesting_rights - delegates [@profiler.record_f {verbosity = Debug} "delegate_slots"]) - in - return delegate_slots - -let round_proposer state ~level round = - let slots = - match level with - | `Current -> state.level_state.delegate_slots - | `Next -> state.level_state.next_level_delegate_slots - in - let committee_size = - state.global_state.constants.parametric.consensus_committee_size - in - Round.to_slot round ~committee_size |> function - | Error _ -> None - | Ok slot -> Delegate_slots.own_slot_owner slots ~slot - -let cache_size_limit = 100 - -let create_cache () = - let open Baking_cache in - { - known_timestamps = Timestamp_of_round_cache.create cache_size_limit; - round_timestamps = Round_timestamp_interval_cache.create cache_size_limit; - } - -(** Memoization wrapper for [Round.timestamp_of_round]. *) -let timestamp_of_round state ~predecessor_timestamp ~predecessor_round ~round = - let open Result_syntax in - let open Baking_cache in - let known_timestamps = state.global_state.cache.known_timestamps in - match - Timestamp_of_round_cache.find_opt - known_timestamps - (predecessor_timestamp, predecessor_round, round) - with - (* Compute and register the timestamp if not already existing. *) - | None -> - let* ts = - Environment.wrap_tzresult - @@ Protocol.Alpha_context.Round.timestamp_of_round - state.global_state.round_durations - ~predecessor_timestamp - ~predecessor_round - ~round - in - Timestamp_of_round_cache.replace - known_timestamps - (predecessor_timestamp, predecessor_round, round) - ts ; - return ts - (* If it already exists, just fetch from the memoization table. *) - | Some ts -> return ts - -let compute_next_round_time state = - let proposal = - match state.level_state.attestable_payload with - | None -> state.level_state.latest_proposal - | Some {proposal; _} -> proposal - in - if is_first_block_in_protocol proposal then None - else - match state.level_state.next_level_proposed_round with - | Some _proposed_round -> - (* TODO? do something, if we don't, we won't be able to - repropose a block at next level. *) - None - | None -> ( - let predecessor_timestamp = proposal.predecessor.shell.timestamp in - let predecessor_round = proposal.predecessor.round in - let next_round = Round.succ state.round_state.current_round in - match - timestamp_of_round - state - ~predecessor_timestamp - ~predecessor_round - ~round:next_round - with - | Ok timestamp -> Some (timestamp, next_round) - | _ -> assert false) - -(* Pretty-printers *) - -let pp_validation_mode fmt = function - | Node -> Format.fprintf fmt "node" - | Local _ -> Format.fprintf fmt "local" - -let pp_global_state fmt {chain_id; config; validation_mode; delegates; _} = - Format.fprintf - fmt - "@[Global state:@ chain_id: %a@ @[config:@ %a@]@ \ - validation_mode: %a@ @[delegates:@ %a@]@]" - Chain_id.pp - chain_id - Baking_configuration.pp - config - pp_validation_mode - validation_mode - Format.(pp_print_list pp_consensus_key) - delegates - -let pp_option pp fmt = function - | None -> Format.fprintf fmt "none" - | Some v -> Format.fprintf fmt "%a" pp v - -let pp_prequorum fmt {level; round; block_payload_hash; preattestations} = - Format.fprintf - fmt - "level: %ld, round: %a, payload_hash: %a, preattestations: %d" - level - Round.pp - round - Block_payload_hash.pp_short - block_payload_hash - (List.length preattestations) - -let pp_block_info fmt - { - hash; - shell; - payload_hash; - round; - prequorum; - quorum; - payload; - payload_round; - } = - Format.fprintf - fmt - "@[Block:@ hash: %a@ payload_hash: %a@ level: %ld@ round: %a@ \ - prequorum: %a@ quorum: %d attestations@ payload: %a@ payload round: %a@]" - Block_hash.pp - hash - Block_payload_hash.pp_short - payload_hash - shell.level - Round.pp - round - (pp_option pp_prequorum) - prequorum - (List.length quorum) - Operation_pool.pp_payload - payload - Round.pp - payload_round - -let pp_proposal fmt {block; _} = pp_block_info fmt block - -let pp_locked_round fmt ({payload_hash; round} : locked_round) = - Format.fprintf - fmt - "payload hash: %a, round: %a" - Block_payload_hash.pp_short - payload_hash - Round.pp - round - -let pp_attestable_payload fmt {proposal; prequorum} = - Format.fprintf - fmt - "proposal: %a, prequorum: %a" - Block_hash.pp - proposal.block.hash - pp_prequorum - prequorum - -let pp_elected_block fmt {proposal; attestation_qc} = - Format.fprintf - fmt - "@[%a@ nb quorum attestations: %d@]" - pp_block_info - proposal.block - (List.length attestation_qc) - -let pp_delegate_slot fmt - {consensus_key_and_delegate; first_slot; attesting_power} = - Format.fprintf - fmt - "slots: @[first_slot: %a@],@ delegate: %a,@ attesting_power: %d" - Slot.pp - first_slot - pp_consensus_key_and_delegate - consensus_key_and_delegate - attesting_power - -(* this type is only used below for pretty-printing *) -type delegate_slots_for_pp = { - attester : consensus_key_and_delegate; - all_slots : Slot.t list; -} - -let delegate_slots_for_pp delegate_slot_map = - SlotMap.fold - (fun slot {consensus_key_and_delegate; first_slot; attesting_power = _} acc -> - match SlotMap.find first_slot acc with - | None -> - SlotMap.add - first_slot - {attester = consensus_key_and_delegate; all_slots = [slot]} - acc - | Some {attester; all_slots} -> - SlotMap.add first_slot {attester; all_slots = slot :: all_slots} acc) - delegate_slot_map - SlotMap.empty - |> SlotMap.map (fun {attester; all_slots} -> - {attester; all_slots = List.rev all_slots}) - -let pp_delegate_slots fmt Delegate_slots.{own_delegate_slots; _} = - Format.fprintf - fmt - "@[%a@]" - Format.( - pp_print_list - ~pp_sep:pp_print_cut - (fun fmt (_first_slot, {attester; all_slots}) -> - Format.fprintf - fmt - "attester: %a, power: %d, first 10 slots: %a" - pp_consensus_key_and_delegate - attester - (List.length all_slots) - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.pp_print_string fmt ",") - Slot.pp) - (List.filteri (fun i _ -> i < 10) all_slots))) - (SlotMap.bindings (delegate_slots_for_pp own_delegate_slots)) - -let pp_prepared_block fmt - {signed_block_header; delegate = consensus_key_and_delegate; _} = - Format.fprintf - fmt - "predecessor block hash: %a, payload hash: %a, level: %ld, delegate: %a" - Block_hash.pp - signed_block_header.shell.predecessor - Block_payload_hash.pp_short - signed_block_header.protocol_data.contents.payload_hash - signed_block_header.shell.level - pp_consensus_key_and_delegate - consensus_key_and_delegate - -let pp_level_state fmt - { - current_level; - latest_proposal; - is_latest_proposal_applied; - locked_round; - attestable_payload; - elected_block; - delegate_slots; - next_level_delegate_slots; - next_level_proposed_round; - dal_attestable_slots = _; - next_level_dal_attestable_slots = _; - } = - Format.fprintf - fmt - "@[Level state:@ current level: %ld@ @[proposal (applied:%b):@ \ - %a@]@ locked round: %a@ attestable payload: %a@ elected block: %a@ @[own delegate slots:@ %a@]@ @[next level own delegate slots:@ %a@]@ \ - next level proposed round: %a@]" - current_level - is_latest_proposal_applied - pp_proposal - latest_proposal - (pp_option pp_locked_round) - locked_round - (pp_option pp_attestable_payload) - attestable_payload - (pp_option pp_elected_block) - elected_block - pp_delegate_slots - delegate_slots - pp_delegate_slots - next_level_delegate_slots - (pp_option Round.pp) - next_level_proposed_round - -let pp_phase fmt = function - | Idle -> Format.fprintf fmt "idle" - | Awaiting_preattestations -> Format.fprintf fmt "awaiting preattestations" - | Awaiting_application -> Format.fprintf fmt "awaiting application" - | Awaiting_attestations -> Format.fprintf fmt "awaiting attestations" - -let pp_round_state fmt - { - current_round; - current_phase; - delayed_quorum; - early_attestations; - awaiting_unlocking_pqc; - } = - Format.fprintf - fmt - "@[Round state:@ round: %a,@ phase: %a,@ delayed quorum: %a,@ early \ - attestations: %d,@ awaiting unlocking pqc: %b@]" - Round.pp - current_round - pp_phase - current_phase - (pp_option Format.pp_print_int) - (Option.map List.length delayed_quorum) - (List.length early_attestations) - awaiting_unlocking_pqc - -let pp fmt {global_state; level_state; round_state} = - Format.fprintf - fmt - "@[State:@ %a@ %a@ %a@]" - pp_global_state - global_state - pp_level_state - level_state - pp_round_state - round_state - -let pp_timeout_kind fmt = function - | End_of_round {ending_round} -> - Format.fprintf fmt "end of round %a" Round.pp ending_round - | Time_to_prepare_next_level_block {at_round} -> - Format.fprintf - fmt - "time to prepare next level block at round %a" - Round.pp - at_round - -let pp_forge_event fmt = - let open Format in - let pp_signed_consensus_vote fmt {unsigned_consensus_vote; _} = - fprintf - fmt - "for delegate %a at level %ld (round %a)" - pp_consensus_key_and_delegate - unsigned_consensus_vote.delegate - (Raw_level.to_int32 unsigned_consensus_vote.vote_consensus_content.level) - Round.pp - unsigned_consensus_vote.vote_consensus_content.round - in - function - | Block_ready {signed_block_header; round; delegate; _} -> - fprintf - fmt - "block ready for delegate: %a at level %ld (round: %a)" - pp_consensus_key_and_delegate - delegate - signed_block_header.shell.level - Round.pp - round - | Preattestation_ready signed_preattestation -> - fprintf - fmt - "preattestation ready %a" - pp_signed_consensus_vote - signed_preattestation - | Attestation_ready signed_attestation -> - fprintf - fmt - "attestation ready %a" - pp_signed_consensus_vote - signed_attestation - -let pp_event fmt = function - | New_valid_proposal proposal -> - Format.fprintf - fmt - "new valid proposal received: %a" - pp_block_info - proposal.block - | New_head_proposal proposal -> - Format.fprintf - fmt - "new head proposal received: %a" - pp_block_info - proposal.block - | Prequorum_reached (candidate, preattestations) -> - Format.fprintf - fmt - "prequorum reached with %d preattestations for %a at round %a" - (List.length preattestations) - Block_hash.pp - candidate.Operation_worker.hash - Round.pp - candidate.round_watched - | Quorum_reached (candidate, attestations) -> - Format.fprintf - fmt - "quorum reached with %d attestations for %a at round %a" - (List.length attestations) - Block_hash.pp - candidate.Operation_worker.hash - Round.pp - candidate.round_watched - | New_forge_event forge_event -> - Format.fprintf fmt "new forge event: %a" pp_forge_event forge_event - | Timeout kind -> - Format.fprintf fmt "timeout reached: %a" pp_timeout_kind kind - -let pp_short_event fmt = - let open Format in - function - | New_valid_proposal _ -> fprintf fmt "new valid proposal" - | New_head_proposal _ -> fprintf fmt "new head proposal" - | Prequorum_reached (_, _) -> fprintf fmt "prequorum reached" - | Quorum_reached (_, _) -> fprintf fmt "quorum reached" - | Timeout (End_of_round _) -> fprintf fmt "end of round timeout" - | Timeout (Time_to_prepare_next_level_block _) -> - fprintf fmt "time to prepare next level block" - | New_forge_event (Block_ready _) -> fprintf fmt "block ready" - | New_forge_event (Preattestation_ready _) -> - fprintf fmt "preattestation ready" - | New_forge_event (Attestation_ready _) -> fprintf fmt "attestation ready" diff --git a/src/proto_020_PsParisC/lib_delegate/baking_state.mli b/src/proto_020_PsParisC/lib_delegate/baking_state.mli deleted file mode 100644 index e8260a03c492..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_state.mli +++ /dev/null @@ -1,436 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context - -type consensus_key = { - alias : string option; - public_key : Signature.public_key; - public_key_hash : Signature.public_key_hash; - secret_key_uri : Client_keys.sk_uri; -} - -val consensus_key_encoding : consensus_key Data_encoding.t - -val pp_consensus_key : Format.formatter -> consensus_key -> unit - -type consensus_key_and_delegate = consensus_key * Signature.Public_key_hash.t - -val consensus_key_and_delegate_encoding : - consensus_key_and_delegate Data_encoding.t - -val pp_consensus_key_and_delegate : - Format.formatter -> consensus_key_and_delegate -> unit - -(** The validation mode specifies whether the baker (filters and) validates - mempool operations via an RPC to the node, or if it does so "locally", by - using the context. *) -type validation_mode = Node | Local of Abstract_context_index.t - -type prequorum = { - level : int32; - round : Round.t; - block_payload_hash : Block_payload_hash.t; - preattestations : Kind.preattestation operation list; -} - -type block_info = { - hash : Block_hash.t; - shell : Block_header.shell_header; - payload_hash : Block_payload_hash.t; - payload_round : Round.t; - round : Round.t; - prequorum : prequorum option; - quorum : Kind.attestation operation list; - payload : Operation_pool.payload; -} - -type cache = { - known_timestamps : Timestamp.time Baking_cache.Timestamp_of_round_cache.t; - round_timestamps : - (Timestamp.time * Round.t * consensus_key_and_delegate) - Baking_cache.Round_timestamp_interval_cache.t; -} - -type block_kind = - | Fresh of Operation_pool.pool - | Reproposal of { - consensus_operations : packed_operation list; - payload_hash : Block_payload_hash.t; - payload_round : Round.t; - payload : Operation_pool.payload; - } - -type block_to_bake = { - predecessor : block_info; - round : Round.t; - delegate : consensus_key_and_delegate; - kind : block_kind; - force_apply : bool; - (** if true, while baking the block, try and apply the block and its - operations instead of only validating them. this can be permanently - set using the [--force-apply] flag (see [force_apply_switch_arg] in - [baking_commands.ml]). *) -} - -val block_info_encoding : block_info Data_encoding.t - -val round_of_shell_header : Block_header.shell_header -> Round.t tzresult - -module SlotMap : Map.S with type key = Slot.t - -(** A delegate slot consists of the delegate's consensus key, its public key - hash, its first slot, and its attesting power at some level. *) -type delegate_slot = { - consensus_key_and_delegate : consensus_key_and_delegate; - first_slot : Slot.t; - attesting_power : int; -} - -module Delegate_slots : sig - (** Information regarding the slot distribution at some level. *) - type t - - (** Returns the list of our own delegates that have at least a slot. There are - no duplicates, the associated slot is the first one. *) - val own_delegates : t -> delegate_slot list - - (** Returns, among our *own* delegates, the delegate (together with its - first attesting slot) that owns the given slot, if any (even if the - given slot is not the delegate's first slot). *) - val own_slot_owner : t -> slot:Slot.t -> delegate_slot option - - (** Returns the voting power of the delegate whose first slot is the given - slot. Returns [None] if the slot is not the first slot of any delegate. *) - val voting_power : t -> slot:Slot.t -> int option -end - -type delegate_slots = Delegate_slots.t - -type proposal = {block : block_info; predecessor : block_info} - -val proposal_encoding : proposal Data_encoding.t - -(** Identify the first block of the protocol, ie. the block that - activates the current protocol. - - This block should be baked by the baker of the previous protocol - (that's why this same block is also referred to as the last block - of the previous protocol). It is always considered final and - therefore is not attested.*) -val is_first_block_in_protocol : proposal -> bool - -type locked_round = {payload_hash : Block_payload_hash.t; round : Round.t} - -val locked_round_encoding : locked_round Data_encoding.t - -type attestable_payload = {proposal : proposal; prequorum : prequorum} - -val attestable_payload_encoding : attestable_payload Data_encoding.t - -type elected_block = { - proposal : proposal; - attestation_qc : Kind.attestation operation list; -} - -(** [manager_operations_infos] contains information about the number of manager - operations in the forged block and the summing fees from these operations *) -type manager_operations_infos = { - manager_operation_number : int; - total_fees : Int64.t; -} - -val manager_operations_infos_encoding : manager_operations_infos Data_encoding.t - -type prepared_block = { - signed_block_header : block_header; - round : Round.t; - delegate : consensus_key_and_delegate; - operations : Tezos_base.Operation.t list list; - manager_operations_infos : manager_operations_infos option; - baking_votes : Per_block_votes_repr.per_block_votes; -} - -(* An association list between delegates and promises for their DAL attestations - at some level (as obtained through the [get_attestable_slots] RPC). See usage - in {!level_state}. *) -type dal_attestable_slots = - (Signature.Public_key_hash.t - * Tezos_dal_node_services.Types.attestable_slots tzresult Lwt.t) - list - -type consensus_vote_kind = Attestation | Preattestation - -val pp_consensus_vote_kind : Format.formatter -> consensus_vote_kind -> unit - -val consensus_vote_kind_encoding : consensus_vote_kind Data_encoding.t - -type unsigned_consensus_vote = { - vote_kind : consensus_vote_kind; - vote_consensus_content : consensus_content; - delegate : consensus_key_and_delegate; - dal_content : dal_content option; -} - -type signed_consensus_vote = { - unsigned_consensus_vote : unsigned_consensus_vote; - signed_operation : packed_operation; -} - -type batch_content = { - level : Raw_level.t; - round : Round.t; - block_payload_hash : Block_payload_hash.t; -} - -type unsigned_consensus_vote_batch = private { - batch_kind : consensus_vote_kind; - batch_content : batch_content; - batch_branch : Block_hash.t; - unsigned_consensus_votes : unsigned_consensus_vote list; -} - -val make_unsigned_consensus_vote_batch : - consensus_vote_kind -> - batch_content -> - batch_branch:Block_hash.t -> - (consensus_key_and_delegate * Slot.t) list -> - unsigned_consensus_vote_batch - -val dal_content_map_p : - (unsigned_consensus_vote -> dal_content option tzresult Lwt.t) -> - unsigned_consensus_vote_batch -> - unsigned_consensus_vote_batch Lwt.t - -type signed_consensus_vote_batch = private { - batch_kind : consensus_vote_kind; - batch_content : batch_content; - batch_branch : Block_hash.t; - signed_consensus_votes : signed_consensus_vote list; -} - -type error += Mismatch_signed_consensus_vote_in_batch - -val make_signed_consensus_vote_batch : - consensus_vote_kind -> - batch_content -> - batch_branch:Block_hash.t -> - signed_consensus_vote list -> - signed_consensus_vote_batch tzresult - -val make_singleton_consensus_vote_batch : - signed_consensus_vote -> signed_consensus_vote_batch - -type level_state = { - current_level : int32; - latest_proposal : proposal; - is_latest_proposal_applied : bool; - locked_round : locked_round option; - attestable_payload : attestable_payload option; - elected_block : elected_block option; - delegate_slots : delegate_slots; - next_level_delegate_slots : delegate_slots; - next_level_proposed_round : Round.t option; - dal_attestable_slots : dal_attestable_slots; - next_level_dal_attestable_slots : dal_attestable_slots; - (** For each (own) delegate having a DAL slot at the current level, store - a promise to obtain the attestable slots for that level. *) -} - -type phase = - | Idle - | Awaiting_preattestations - | Awaiting_attestations - | Awaiting_application - -val phase_encoding : phase Data_encoding.t - -type round_state = { - current_round : Round.t; - current_phase : phase; - delayed_quorum : Kind.attestation operation list option; - early_attestations : signed_consensus_vote list; - awaiting_unlocking_pqc : bool; -} - -(** [forge_event] type used to return the result of a task completion - in the forge worker. *) -type forge_event = - | Block_ready of prepared_block - | Preattestation_ready of signed_consensus_vote - | Attestation_ready of signed_consensus_vote - -(** [forge_request] type used to push a concurrent forging task in the - forge worker. *) -type forge_request = - | Forge_and_sign_block of block_to_bake - | Forge_and_sign_preattestations of { - unsigned_preattestations : unsigned_consensus_vote_batch; - } - | Forge_and_sign_attestations of { - unsigned_attestations : unsigned_consensus_vote_batch; - } - -(** [forge_worker_hooks] type that allows interactions with the forge - worker. Hooks are needed in order to break a circular dependency. *) -type forge_worker_hooks = { - push_request : forge_request -> unit; - get_forge_event_stream : unit -> forge_event Lwt_stream.t; - cancel_all_pending_tasks : unit -> unit; -} - -type global_state = { - cctxt : Protocol_client_context.full; - chain_id : Chain_id.t; - config : Baking_configuration.t; - constants : Constants.t; - round_durations : Round.round_durations; - operation_worker : Operation_worker.t; - mutable forge_worker_hooks : forge_worker_hooks; - validation_mode : validation_mode; - delegates : consensus_key list; - cache : cache; - dal_node_rpc_ctxt : Tezos_rpc.Context.generic option; -} - -type state = { - global_state : global_state; - level_state : level_state; - round_state : round_state; -} - -type t = state - -val update_current_phase : t -> phase -> t - -(** Returns, among our *own* delegates, the delegate (and its attesting slot) - that has a proposer slot at the given round and the current or next level, - if any. *) -val round_proposer : - state -> level:[`Current | `Next] -> Round.t -> delegate_slot option - -type timeout_kind = - | End_of_round of {ending_round : Round.t} - | Time_to_prepare_next_level_block of {at_round : Round.t} - -val timeout_kind_encoding : timeout_kind Data_encoding.t - -type event = - | New_valid_proposal of proposal - | New_head_proposal of proposal - | Prequorum_reached of - Operation_worker.candidate * Kind.preattestation operation list - | Quorum_reached of - Operation_worker.candidate * Kind.attestation operation list - | New_forge_event of forge_event - | Timeout of timeout_kind - -val event_encoding : event Data_encoding.t - -val forge_event_encoding : forge_event Data_encoding.t - -type state_data = { - level_data : int32; - locked_round_data : locked_round option; - attestable_payload_data : attestable_payload option; -} - -val state_data_encoding : state_data Data_encoding.t - -val record_state : t -> unit tzresult Lwt.t - -val may_record_new_state : - previous_state:t -> new_state:t -> unit tzresult Lwt.t - -val load_attestable_data : - Protocol_client_context.full -> - [`State] Baking_files.location -> - state_data option tzresult Lwt.t - -val may_load_attestable_data : t -> t tzresult Lwt.t - -(** @param block default to [`Head 0]*) -val compute_delegate_slots : - Protocol_client_context.full -> - ?block:Block_services.block -> - level:int32 -> - chain:Shell_services.chain -> - consensus_key list -> - delegate_slots tzresult Lwt.t - -val create_cache : unit -> cache - -(** Memoization wrapper for [Round.timestamp_of_round]. *) -val timestamp_of_round : - state -> - predecessor_timestamp:Time.Protocol.t -> - predecessor_round:Round.t -> - round:Round.t -> - Time.Protocol.t tzresult - -(** From the current [state], the function returns an optional - association pair, which consists of the next round timestamp and its - round. *) -val compute_next_round_time : state -> (Time.Protocol.t * Round.t) option - -val pp_validation_mode : Format.formatter -> validation_mode -> unit - -val pp_global_state : Format.formatter -> global_state -> unit - -val pp_option : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit - -val pp_block_info : Format.formatter -> block_info -> unit - -val pp_proposal : Format.formatter -> proposal -> unit - -val pp_locked_round : Format.formatter -> locked_round -> unit - -val pp_attestable_payload : Format.formatter -> attestable_payload -> unit - -val pp_elected_block : Format.formatter -> elected_block -> unit - -val pp_delegate_slot : Format.formatter -> delegate_slot -> unit - -val pp_delegate_slots : Format.formatter -> delegate_slots -> unit - -val pp_prepared_block : Format.formatter -> prepared_block -> unit - -val pp_level_state : Format.formatter -> level_state -> unit - -val pp_phase : Format.formatter -> phase -> unit - -val pp_round_state : Format.formatter -> round_state -> unit - -val pp : Format.formatter -> t -> unit - -val pp_timeout_kind : Format.formatter -> timeout_kind -> unit - -val pp_event : Format.formatter -> event -> unit - -val pp_forge_event : Format.formatter -> forge_event -> unit - -val pp_short_event : Format.formatter -> event -> unit diff --git a/src/proto_020_PsParisC/lib_delegate/baking_vdf.ml b/src/proto_020_PsParisC/lib_delegate/baking_vdf.ml deleted file mode 100644 index 003e3115c125..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_vdf.ml +++ /dev/null @@ -1,503 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 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 Protocol -open Alpha_context -open Client_baking_blocks -module Events = Baking_events.VDF - -type vdf_solution = Seed_repr.vdf_solution - -type vdf_setup = Seed_repr.vdf_setup - -type forked_process = {pid : int; ch_in : Lwt_io.input_channel} - -type status = - | Not_started - | Started of vdf_setup * forked_process - | Finished of vdf_setup * vdf_solution - | Injected - | Invalid - -type 'a state = { - cctxt : Protocol_client_context.full; - constants : Constants.t; - mutable block_stream : (block_info, 'a) result Lwt_stream.t; - mutable stream_stopper : Tezos_rpc.Context.stopper option; - mutable cycle : Cycle.t option; - mutable computation_status : status; -} - -let init_block_stream_with_stopper cctxt chain = - Client_baking_blocks.monitor_heads - cctxt - ~next_protocols:(Some [Protocol.hash]) - chain - -let stop_block_stream state = - Option.iter - (fun stopper -> - stopper () ; - state.stream_stopper <- None) - state.stream_stopper - -let emit_with_level msg level = - let level_i32 = Raw_level.to_int32 level in - Events.(emit vdf_info) (Printf.sprintf "%s (level %ld)" msg level_i32) - -let emit_revelation_not_injected cycle = - let open Lwt_result_syntax in - let*! () = - Events.(emit vdf_info) - (Printf.sprintf - "VDF revelation was NOT injected for cycle %ld" - (Cycle.to_int32 cycle)) - in - return_unit - -let log_errors_and_continue ~name p = - let open Lwt_syntax in - let* p in - match p with - | Ok () -> return_unit - | Error errs -> Events.(emit vdf_daemon_error) (name, errs) - -let get_seed_computation cctxt chain_id hash = - let chain = `Hash chain_id in - let block = `Hash (hash, 0) in - Alpha_services.Seed_computation.get cctxt (chain, block) - -let get_level_info cctxt level = - let open Lwt_result_syntax in - let level = Raw_level.to_int32 level in - let* {protocol_data = {level_info; _}; _} = - Protocol_client_context.Alpha_block_services.metadata - cctxt - ~chain:cctxt#chain - ~block:(`Level level) - () - in - return level_info - -let is_in_nonce_revelation_stage constants (level : Level.t) = - let open Lwt_result_syntax in - let {Constants.parametric = {nonce_revelation_threshold; _}; _} = constants in - return - (Vdf_helpers.is_in_nonce_revelation_stage - ~nonce_revelation_threshold - ~level) - -(* Checks if the VDF setup saved in the state is equal to the one computed - from a seed *) -let eq_vdf_setup vdf_setup seed_discriminant seed_challenge = - let open Environment.Vdf in - let saved_discriminant, saved_challenge = vdf_setup in - let discriminant, challenge = - Seed.generate_vdf_setup ~seed_discriminant ~seed_challenge - in - Bytes.equal - (discriminant_to_bytes discriminant) - (discriminant_to_bytes saved_discriminant) - && Bytes.equal - (challenge_to_bytes challenge) - (challenge_to_bytes saved_challenge) - -(* Forge the VDF revelation operation and inject it if: - * - it is correct wrt the VDF setup for the current cycle - * - we are still in the VDF revelation stage - * If successful or if the seed no longer needs to be injected, - * update the computation status. *) -let inject_vdf_revelation cctxt state setup solution chain_id hash - (level_info : Level.t) = - let open Lwt_result_syntax in - let chain = `Hash chain_id in - let block = `Hash (hash, 0) in - let level = level_info.level in - let* seed_computation = get_seed_computation cctxt chain_id hash in - match seed_computation with - | Vdf_revelation_stage {seed_discriminant; seed_challenge} -> - if eq_vdf_setup setup seed_discriminant seed_challenge then ( - let* op_bytes = - Plugin.RPC.Forge.vdf_revelation - cctxt - (chain, block) - ~branch:hash - ~solution - () - in - let op_bytes = Tezos_crypto.Signature.V_latest.(concat op_bytes zero) in - let* op_hash = - Shell_services.Injection.operation cctxt ~chain op_bytes - in - (* If injection is successful, update the status to [Injected]. *) - state.computation_status <- Injected ; - let*! () = - Events.(emit vdf_revelation_injected) - ( Cycle.to_int32 level_info.cycle, - Chain_services.to_string chain, - op_hash ) - in - return_unit) - else ( - (* The VDF setup saved in the state is different from the one computed - * from the on-chain seed. In practice this would indicate a bug, since - * it would either mean that the cycle has changed and we have not - * detected it or that the VDF setup changed mid-cycle. *) - state.computation_status <- Invalid ; - let*! () = - emit_with_level "Error injecting VDF: setup has been updated" level - in - return_unit) - | Nonce_revelation_stage -> - state.computation_status <- Not_started ; - let*! () = emit_with_level "Not injecting VDF: new cycle started" level in - return_unit - | Computation_finished -> - state.computation_status <- Injected ; - let*! () = emit_with_level "Not injecting VDF: already injected" level in - return_unit - -(* Launch the heavy VDF computation as a separate process. This is done in order - * to not block the main process, allowing it to continue monitoring blocks and - * to cancel or restart the VDF computation if needed. *) -let fork_vdf_computation state ((discriminant, challenge) as setup) level = - let open Lwt_syntax in - let ch_in, forked_out = Lwt_io.pipe () in - match Lwt_unix.fork () with - | 0 -> ( - (* In the forked process, try to compute the VDF solution, write it - * to [forked_out], then exit. *) - let* () = Lwt_io.close ch_in in - let solution = - Environment.Vdf.prove - discriminant - challenge - state.constants.parametric.vdf_difficulty - in - match - Data_encoding.Binary.to_bytes Seed.vdf_solution_encoding solution - with - | Ok encoded -> - let* () = Lwt_io.write_value forked_out encoded in - exit 0 - | Error _ -> - let* () = Events.(emit vdf_info) "Error encoding VDF solution" in - exit 1) - | pid -> - (* In the main process, change the computation status to [Started], - record the forked process data, and continue. *) - let* () = Lwt_io.close forked_out in - state.computation_status <- Started (setup, {pid; ch_in}) ; - let* () = - emit_with_level - (Printf.sprintf "Started to compute VDF, pid: %d" pid) - level - in - return_unit - -(* Check whether the VDF computation process has exited and read the result. - * Update the computation status accordingly. *) -let get_vdf_solution_if_ready cctxt state proc setup chain_id hash - (level_info : Level.t) = - let open Lwt_result_syntax in - let level = level_info.level in - let*! status = Lwt_unix.waitpid [WNOHANG] proc.pid in - match status with - | 0, _ -> - (* If the process is still running, continue *) - let*! () = emit_with_level "Skipping, VDF computation launched" level in - return_unit - | _, WEXITED 0 -> ( - (* If the process has exited normally, read the solution, update - * the status to [Finished], and attempt to inject the VDF - * revelation. *) - let*! encoded_solution = Lwt_io.read_value proc.ch_in in - match - Data_encoding.Binary.of_bytes - Seed.vdf_solution_encoding - encoded_solution - with - | Ok solution -> - let*! () = Lwt_io.close proc.ch_in in - state.computation_status <- Finished (setup, solution) ; - let*! () = emit_with_level "Finished VDF computation" level in - inject_vdf_revelation - cctxt - state - setup - solution - chain_id - hash - level_info - | Error _ -> - let*! () = Events.(emit vdf_info) "Error decoding VDF solution" in - state.computation_status <- Not_started ; - return_unit) - | _, WEXITED _ | _, WSIGNALED _ | _, WSTOPPED _ -> - (* If process has exited abnormally, reset the computation status to - * [Not_started] and continue *) - state.computation_status <- Not_started ; - let*! () = - Events.(emit vdf_info) "VDF computation process exited abnormally" - in - return_unit - -let kill_forked_process {pid; _} = - let open Lwt_syntax in - let* () = - match Unix.kill pid Sys.sigterm with - | () -> - Events.(emit vdf_info) - (Printf.sprintf - "Sent SIGTERM to VDF computation process (pid %d)" - pid) - | exception Unix.Unix_error (err, _, _) -> - let msg = Printf.sprintf "%s (pid %d)" (Unix.error_message err) pid in - Events.(emit vdf_daemon_cannot_kill_computation) msg - in - let* pid, status = Lwt_unix.waitpid [] pid in - let status = - match status with - | WEXITED n -> Printf.sprintf "WEXITED %d" n - | WSIGNALED n -> Printf.sprintf "WSIGNALED %d" n - | WSTOPPED n -> Printf.sprintf "WSTOPPED %d" n - in - Events.(emit vdf_info) - (Printf.sprintf - "Exit status for child VDF computation process %d: %s" - pid - status) - -(* Kill the VDF computation process if one was launched. *) -let maybe_kill_running_vdf_computation state = - let open Lwt_syntax in - match state.computation_status with - | Started (_, proc) -> - let* () = kill_forked_process proc in - return_unit - | _ -> return_unit - -(* Checks if the cycle of the last processed block is different from the cycle - * of the block at [level_info]. *) -let check_new_cycle state (level_info : Level.t) = - let open Lwt_result_syntax in - let current_cycle = level_info.cycle in - match state.cycle with - | None -> - (* First processed block, initialise [state.cycle] *) - state.cycle <- Some current_cycle ; - return_unit - | Some cycle -> - if Cycle.(cycle < current_cycle) then ( - (* The cycle of this block is different from the cycle of the last - * processed block. Emit an event if the VDF for the previous cycle - * has not been injected, kill any running VDF computation, and - * reset the computation status. *) - let* () = - match state.computation_status with - | Injected -> return_unit - | Started ((_ : vdf_setup), proc) -> - let*! () = kill_forked_process proc in - emit_revelation_not_injected cycle - | Not_started | Finished _ | Invalid -> - emit_revelation_not_injected cycle - in - state.cycle <- Some current_cycle ; - state.computation_status <- Not_started ; - return_unit) - else return_unit - -(* The daemon's main job is to launch the VDF computation as soon as it - * can (i.e., when the nonce revelation stage ends) and to inject - * the VDF solution as soon as it finishes computing it. - * Additionally, it must cancel a running VDF computation if its result - * is no longer required and restart a computation if it failed. - * The daemon processes the stream of blocks and monitors both - * the level of the head within a cycle and the [Seed_computation] RPC. - * The core of this function is a pattern match on the product of - * [seed_computation] (the on-chain status of the seed computation) - * and [state.computation_status] (the internal status of the daemon). - * - * [seed_computation] is reset at the beginning of a cycle to - * [Nonce_revelation_stage], mirroring the on-chain change of the computation - * status. No action is taken while in this state. - * After [nonce_revelation_threshold] blocks, the status becomes - * [Vdf_revelation_stage]. A call to the RPC confirms this and provides the seed - * required to launch the VDF computation. - * If a VDF revelation operation is injected before the end of the cycle, - * the status is updated to [Computation_finished]. If a VDF computation is - * running at that point (i.e., another daemon injected first), - * it is canceled. *) -let process_new_block (cctxt : #Protocol_client_context.full) state - {hash; chain_id; protocol; next_protocol; level; _} = - let open Lwt_result_syntax in - if Protocol_hash.(protocol <> next_protocol) then - (* If the protocol has changed, emit an event on every new block and take - * no further action. It is expected that the daemon corresponding to - * the new protocol is used instead. *) - let*! () = Delegate_events.Denunciator.(emit protocol_change_detected) () in - return_unit - else - let* level_info = get_level_info cctxt level in - (* If head is in a new cycle record it in [state.cycle] and reset - * [state.computation_status] to [Not_started]. *) - let* () = check_new_cycle state level_info in - (* If the chain is in the nonce revelation stage, there is nothing to do. *) - let* out = is_in_nonce_revelation_stage state.constants level_info in - if out then - let*! () = - emit_with_level "Skipping, still in nonce revelation stage" level - in - return_unit - else - (* Enter main loop if we are not in the nonce revelation stage and - * the expected protocol has been activated. *) - match state.computation_status with - | Not_started -> ( - let* seed_computation = get_seed_computation cctxt chain_id hash in - match seed_computation with - | Vdf_revelation_stage {seed_discriminant; seed_challenge} -> - (* The chain is in the VDF revelation stage and the computation - * has not been started, so it is started here, in a separate - * process. The computation status is updated to [Started]. *) - let setup = - Seed.generate_vdf_setup ~seed_discriminant ~seed_challenge - in - let*! () = fork_vdf_computation state setup level in - return_unit - | Computation_finished -> - let*! () = - emit_with_level - "Skipping, VDF solution has already been injected" - level - in - return_unit - | Nonce_revelation_stage -> - (* At this point the chain cannot be in the nonce revelation - * stage. This is checked in [is_in_nonce_revelation_stage]. *) - assert false) - | Started (setup, proc) -> ( - let* seed_computation = get_seed_computation cctxt chain_id hash in - match seed_computation with - | Vdf_revelation_stage _ -> - (* The chain is in the VDF computation stage and we have - * previously started the computation. Check whether it is - * finished and, if so, update the computation status to - * [Finished] and immediately inject the solution. *) - let* () = - get_vdf_solution_if_ready - cctxt - state - proc - setup - chain_id - hash - level_info - in - return_unit - | Computation_finished -> - (* The chain is no longer in the VDF revelation stage because - * the solution has already been injected: abort the running - * computation. *) - let*! () = kill_forked_process proc in - let*! () = - emit_with_level - "VDF solution already injected, aborting VDF computation" - level - in - state.computation_status <- Injected ; - return_unit - | Nonce_revelation_stage -> - (* At this point the chain cannot be in the nonce revelation - * stage. This is checked in [is_in_nonce_revelation_stage]. *) - assert false) - | Finished (setup, solution) -> - (* VDF solution computed, but not injected. We are only in this case - * if the first attempt to inject, right after getting the solution, - * was unsuccessful. While the chain is in the VDF revelation stage, - * and the solution has not been injected (computation status is - * [Finished]), we try to inject. If successful, the computation - * status is updated to [Injected]. *) - inject_vdf_revelation - cctxt - state - setup - solution - chain_id - hash - level_info - | Injected -> - let*! () = - emit_with_level "Skipping, VDF solution already injected" level - in - return_unit - | Invalid -> - let*! () = emit_with_level "Skipping, failed to compute VDF" level in - return_unit - -let start_vdf_worker (cctxt : Protocol_client_context.full) ~canceler constants - chain = - let open Lwt_result_syntax in - let* block_stream, stream_stopper = - init_block_stream_with_stopper cctxt chain - in - let state = - { - cctxt; - constants; - block_stream; - stream_stopper = Some stream_stopper; - cycle = None; - computation_status = Not_started; - } - in - Lwt_canceler.on_cancel canceler (fun () -> - let*! () = maybe_kill_running_vdf_computation state in - stop_block_stream state ; - Lwt.return_unit) ; - let rec worker_loop () = - let*! b = - Lwt.choose - [ - (let*! _ = Lwt_exit.clean_up_starts in - Lwt.return `Termination); - (let*! e = Lwt_stream.get state.block_stream in - Lwt.return (`Block e)); - ] - in - match b with - | `Termination -> return_unit - | `Block (None | Some (Error _)) -> - (* Exit when the node is unavailable *) - stop_block_stream state ; - let*! () = Events.(emit vdf_daemon_connection_lost) name in - tzfail Baking_errors.Node_connection_lost - | `Block (Some (Ok bi)) -> - let*! () = - log_errors_and_continue ~name @@ process_new_block cctxt state bi - in - worker_loop () - in - worker_loop () diff --git a/src/proto_020_PsParisC/lib_delegate/baking_vdf.mli b/src/proto_020_PsParisC/lib_delegate/baking_vdf.mli deleted file mode 100644 index 84751f723af8..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/baking_vdf.mli +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 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 Protocol.Alpha_context - -val start_vdf_worker : - Protocol_client_context.full -> - canceler:Lwt_canceler.t -> - Constants.t -> - Chain_services.chain -> - unit tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/block_forge.ml b/src/proto_020_PsParisC/lib_delegate/block_forge.ml deleted file mode 100644 index 61985125b2fb..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/block_forge.ml +++ /dev/null @@ -1,533 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context - -type unsigned_block = { - unsigned_block_header : Block_header.t; - operations : Tezos_base.Operation.t list list; - manager_operations_infos : Baking_state.manager_operations_infos option; -} - -type simulation_kind = - | Filter of Operation_pool.Prioritized.t - | Apply of { - ordered_pool : Operation_pool.ordered_pool; - payload_hash : Block_payload_hash.t; - } - -(* [forge_faked_protocol_data ?payload_hash ~payload_round ~seed_nonce_hash - ~liquidity_baking_toggle_vote ~adaptive_issuance_vote] forges a fake [block_header_data] with - [payload_hash] ([zero] by default), [payload_round], [seed_nonce_hash], - [liquidity_baking_toggle_vote] and with an empty [proof_of_work_nonce] and a - dummy [signature]. *) -let forge_faked_protocol_data ?(payload_hash = Block_payload_hash.zero) - ~payload_round ~seed_nonce_hash ~liquidity_baking_toggle_vote - ~adaptive_issuance_vote () = - Block_header. - { - contents = - { - payload_hash; - payload_round; - seed_nonce_hash; - proof_of_work_nonce = Baking_pow.empty_proof_of_work_nonce; - per_block_votes = - { - liquidity_baking_vote = liquidity_baking_toggle_vote; - adaptive_issuance_vote; - }; - }; - signature = Signature.zero; - } - -let convert_operation (op : packed_operation) : Tezos_base.Operation.t = - { - shell = op.shell; - proto = - Data_encoding.Binary.to_bytes_exn - Alpha_context.Operation.protocol_data_encoding - op.protocol_data; - } - -(* [finalize_block_header] updates the [shell_header] that was created - with dummy fields at the beginning of the block construction. It - increments the [level] and sets the actual [operations_hash], - [fitness], [validation_passes], and [context] (the predecessor - resulting context hash). - - When the operations from the block have been applied, the [fitness] - is simply retrieved from the [validation_result]. Otherwise, the - [fitness] is computed from the [round] and [locked_round] - arguments. *) -let finalize_block_header ~shell_header ~validation_result ~operations_hash - ~(pred_info : Baking_state.block_info) ~pred_resulting_context_hash ~round - ~locked_round = - let open Lwt_result_syntax in - let* fitness = - match validation_result with - | Some {Tezos_protocol_environment.fitness; _} -> return fitness - | None -> - let*? level = - Environment.wrap_tzresult @@ Raw_level.of_int32 - @@ Int32.succ shell_header.Tezos_base.Block_header.level - in - let*? fitness = - Environment.wrap_tzresult - @@ Fitness.create - ~level - ~round - ~predecessor_round:pred_info.round - ~locked_round - in - return (Fitness.to_raw fitness) - in - let validation_passes = List.length Main.validation_passes in - let header = - Tezos_base.Block_header. - { - shell_header with - level = Int32.succ shell_header.level; - validation_passes; - operations_hash; - fitness; - context = pred_resulting_context_hash; - } - in - return header - -let retain_live_operations_only ~live_blocks operation_pool = - Operation_pool.Prioritized.filter - (fun ({shell; _} : packed_operation) -> - Block_hash.Set.mem shell.branch live_blocks) - operation_pool - -(* [check_protocol_changed] checks whether the protocol will change with the current - block. This function returns true if the block is the last of an [adoption] - period. It can also return true if an [user_activated_upgrades] is given. *) -let check_protocol_changed ~user_activated_upgrades ~level - ~(validation_result : Tezos_protocol_environment.validation_result option) - ~(incremental : Baking_simulator.incremental) = - let open Lwt_result_syntax in - match - Tezos_base.Block_header.get_forced_protocol_upgrade - ~user_activated_upgrades - ~level - with - | None -> ( - match validation_result with - | None -> ( - let context = Validate.get_initial_ctxt (fst incremental.state) in - let* voting_period = - Lwt.map - Environment.wrap_tzresult - (Voting_period.get_current context) - in - match voting_period.kind with - | Voting_period.Proposal | Exploration | Cooldown | Promotion -> - return_false - | Adoption -> - Lwt.map - Environment.wrap_tzresult - (Voting_period.is_last_block context)) - | Some validation_result -> - let*! next_protocol = - Context_ops.get_protocol validation_result.context - in - return Protocol_hash.(Protocol.hash <> next_protocol)) - | Some next_protocol -> return Protocol_hash.(Protocol.hash <> next_protocol) - -(* [filter_via_node] filters operations using - {!Operation_selection.filter_operations_without_simulation} and then applies - them in a block via {!Node_rpc.preapply_block}. [filter_via_node] returns a - [shell_header], the list of operations that have been applied in the block - and the [payload_hash] corresponding to these operations. *) -let filter_via_node ~chain_id ~fees_config ~hard_gas_limit_per_block - ~faked_protocol_data ~timestamp ~(pred_info : Baking_state.block_info) - ~payload_round ~operation_pool cctxt = - let open Lwt_result_syntax in - let chain = `Hash chain_id in - let filtered_operations = - Operation_selection.filter_operations_without_simulation - fees_config - ~hard_gas_limit_per_block - operation_pool - in - let* shell_header, preapply_result = - Node_rpc.preapply_block - cctxt - ~chain - ~head:pred_info.hash - ~timestamp - ~protocol_data:faked_protocol_data - filtered_operations - in - (* only retain valid operations *) - let operations = - List.map (fun l -> List.map snd l.Preapply_result.applied) preapply_result - in - let payload_hash = - let operation_hashes = - Stdlib.List.tl operations |> List.flatten - |> List.map Tezos_base.Operation.hash - in - Block_payload.hash - ~predecessor_hash:shell_header.predecessor - ~payload_round - operation_hashes - in - let manager_operations_infos = - None - (* We do not compute operations infos from node results to avoid potential - costly computation *) - in - return (shell_header, operations, manager_operations_infos, payload_hash) - -(* [filter_with_context] filters operations using a local context via - {!Operation_selection.filter_operations_with_simulation} and a fresh state - from {!Baking_simulator.begin_construction}. [finalize_block_header] is then - called and a [shell_header], the list of operations and the corresponding - [payload_hash] are returned. If the block is a transition block, - [filter_via_node] is called to return these values. *) -let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block - ~faked_protocol_data ~user_activated_upgrades ~timestamp - ~(pred_info : Baking_state.block_info) ~pred_resulting_context_hash - ~force_apply ~round ~context_index ~payload_round ~operation_pool cctxt = - let open Lwt_result_syntax in - let* incremental = - Baking_simulator.begin_construction - ~timestamp - ~protocol_data:faked_protocol_data - ~force_apply - ~pred_resulting_context_hash - context_index - pred_info - chain_id - in - let* { - Operation_selection.operations; - validation_result; - operations_hash; - manager_operations_infos; - _; - } = - Operation_selection.filter_operations_with_simulation - incremental - fees_config - ~hard_gas_limit_per_block - operation_pool - in - let* changed = - check_protocol_changed - ~level:(Int32.succ pred_info.shell.level) - ~user_activated_upgrades - ~validation_result - ~incremental - in - if changed then - (* Fallback to processing via node, which knows both old and new protocol. *) - filter_via_node - ~chain_id - ~fees_config - ~hard_gas_limit_per_block - ~faked_protocol_data - ~timestamp - ~pred_info - ~payload_round - ~operation_pool - cctxt - else - let* shell_header = - finalize_block_header - ~shell_header:incremental.header - ~validation_result - ~operations_hash - ~pred_info - ~pred_resulting_context_hash - ~round - ~locked_round:None - in - let operations = List.map (List.map convert_operation) operations in - let payload_hash = - let operation_hashes = - Stdlib.List.tl operations |> List.flatten - |> List.map Tezos_base.Operation.hash - in - Block_payload.hash - ~predecessor_hash:shell_header.predecessor - ~payload_round - operation_hashes - in - return (shell_header, operations, manager_operations_infos, payload_hash) - -(* [apply_via_node] applies already filtered and validated operations in a block - via {!Node_rpc.preapply_block}. A [shell_header] is recovered from this call - and returned alongside of the list of operations and the payload_hash. *) -let apply_via_node ~chain_id ~faked_protocol_data ~timestamp - ~(pred_info : Baking_state.block_info) ~ordered_pool ~payload_hash cctxt = - let open Lwt_result_syntax in - let chain = `Hash chain_id in - let operations = Operation_pool.ordered_to_list_list ordered_pool in - let* shell_header, _preapply_result = - Node_rpc.preapply_block - cctxt - ~chain - ~head:pred_info.hash - ~timestamp - ~protocol_data:faked_protocol_data - operations - in - let operations = List.map (List.map convert_operation) operations in - let manager_operations_infos = - None - (* We do not compute operations infos from node results to avoid potential - costly computation *) - in - return (shell_header, operations, manager_operations_infos, payload_hash) - -(* [apply_with_context] is similar to [filter_with_context] but filters - consensus operations only from an [ordered_pool] via - {!Operation_selection.filter_consensus_operations_only}. *) -let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades - ~timestamp ~(pred_info : Baking_state.block_info) - ~pred_resulting_context_hash ~force_apply ~round ~ordered_pool - ~context_index ~payload_hash cctxt = - let open Lwt_result_syntax in - let* incremental = - Baking_simulator.begin_construction - ~timestamp - ~protocol_data:faked_protocol_data - ~force_apply - ~pred_resulting_context_hash - context_index - pred_info - chain_id - in - (* We still need to filter attestations. Two attestations could be - referring to the same slot. *) - let* incremental, ordered_pool = - Operation_selection.filter_consensus_operations_only - incremental - ordered_pool - in - let operations = Operation_pool.ordered_to_list_list ordered_pool in - let operations_hash = - Operation_list_list_hash.compute - (List.map - (fun sl -> - Operation_list_hash.compute (List.map Operation.hash_packed sl)) - operations) - in - (* We need to compute the final [operations_hash] before - finalizing the block because it will be used in the cache's nonce. *) - let incremental = - {incremental with header = {incremental.header with operations_hash}} - in - let* validation_result = Baking_simulator.finalize_construction incremental in - let validation_result = Option.map fst validation_result in - let* changed = - check_protocol_changed - ~level:(Int32.succ pred_info.shell.level) - ~user_activated_upgrades - ~validation_result - ~incremental - in - if changed then - (* Fallback to processing via node, which knows both old and new protocol. *) - apply_via_node - ~chain_id - ~faked_protocol_data - ~timestamp - ~pred_info - ~ordered_pool - ~payload_hash - cctxt - else - let locked_round_when_no_validation_result = - (* [locked_round] will not be used in [finalize_block_header] if there is - a [validation_result] *) - if Option.is_some validation_result then None - else - List.find_map - (fun {protocol_data = Operation_data protocol_data; _} -> - match protocol_data.contents with - | Single (Preattestation {round; _}) -> Some round - | _ -> None) - (Option.value (List.hd operations) ~default:[]) - in - let* shell_header = - finalize_block_header - ~shell_header:incremental.header - ~validation_result - ~operations_hash - ~pred_info - ~pred_resulting_context_hash - ~round - ~locked_round:locked_round_when_no_validation_result - in - let operations = List.map (List.map convert_operation) operations in - let manager_operations_infos = - None - (* We do not compute operations infos from node results to avoid potential - costly computation *) - in - return (shell_header, operations, manager_operations_infos, payload_hash) - -(* [forge] a new [unsigned_block] in accordance with [simulation_kind] and - [simulation_mode] *) -let forge (cctxt : #Protocol_client_context.full) ~chain_id - ~(pred_info : Baking_state.block_info) ~pred_resulting_context_hash - ~pred_live_blocks ~timestamp ~round ~liquidity_baking_toggle_vote - ~adaptive_issuance_vote ~user_activated_upgrades fees_config ~force_apply - ~seed_nonce_hash ~payload_round simulation_mode simulation_kind constants = - let open Lwt_result_syntax in - let hard_gas_limit_per_block = - constants.Constants.Parametric.hard_gas_limit_per_block - in - let simulation_kind = - match simulation_kind with - | Filter operation_pool -> - (* We cannot include operations that are not live with respect - to our predecessor otherwise the node would reject the block. *) - let filtered_pool = - retain_live_operations_only - ~live_blocks:pred_live_blocks - operation_pool - in - Filter filtered_pool - | Apply _ as x -> x - in - let* shell_header, operations, manager_operations_infos, payload_hash = - match (simulation_mode, simulation_kind) with - | Baking_state.Node, Filter operation_pool -> - let faked_protocol_data = - forge_faked_protocol_data - ~payload_round - ~seed_nonce_hash - ~liquidity_baking_toggle_vote - ~adaptive_issuance_vote - () - in - filter_via_node - ~chain_id - ~faked_protocol_data - ~fees_config - ~hard_gas_limit_per_block - ~timestamp - ~pred_info - ~payload_round - ~operation_pool - cctxt - | Node, Apply {ordered_pool; payload_hash} -> - let faked_protocol_data = - forge_faked_protocol_data - ~payload_hash - ~payload_round - ~seed_nonce_hash - ~liquidity_baking_toggle_vote - ~adaptive_issuance_vote - () - in - apply_via_node - ~chain_id - ~faked_protocol_data - ~timestamp - ~pred_info - ~ordered_pool - ~payload_hash - cctxt - | Local context_index, Filter operation_pool -> - let faked_protocol_data = - forge_faked_protocol_data - ~payload_round - ~seed_nonce_hash - ~liquidity_baking_toggle_vote - ~adaptive_issuance_vote - () - in - filter_with_context - ~chain_id - ~faked_protocol_data - ~fees_config - ~hard_gas_limit_per_block - ~user_activated_upgrades - ~timestamp - ~pred_info - ~pred_resulting_context_hash - ~force_apply - ~round - ~context_index - ~payload_round - ~operation_pool - cctxt - | Local context_index, Apply {ordered_pool; payload_hash} -> - let faked_protocol_data = - forge_faked_protocol_data - ~payload_hash - ~payload_round - ~seed_nonce_hash - ~liquidity_baking_toggle_vote - ~adaptive_issuance_vote - () - in - apply_with_context - ~chain_id - ~faked_protocol_data - ~user_activated_upgrades - ~timestamp - ~pred_info - ~pred_resulting_context_hash - ~force_apply - ~round - ~ordered_pool - ~context_index - ~payload_hash - cctxt - in - let* contents = - Baking_pow.mine - ~proof_of_work_threshold:constants.proof_of_work_threshold - shell_header - (fun proof_of_work_nonce -> - { - Block_header.payload_hash; - payload_round; - seed_nonce_hash; - proof_of_work_nonce; - per_block_votes = - { - liquidity_baking_vote = liquidity_baking_toggle_vote; - adaptive_issuance_vote; - }; - }) - in - let unsigned_block_header = - { - Block_header.shell = shell_header; - protocol_data = {contents; signature = Signature.zero}; - } - in - return {unsigned_block_header; operations; manager_operations_infos} diff --git a/src/proto_020_PsParisC/lib_delegate/block_forge.mli b/src/proto_020_PsParisC/lib_delegate/block_forge.mli deleted file mode 100644 index 81efcfcc71c3..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/block_forge.mli +++ /dev/null @@ -1,64 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context - -type unsigned_block = { - unsigned_block_header : Block_header.t; - operations : Tezos_base.Operation.t list list; - manager_operations_infos : Baking_state.manager_operations_infos option; -} - -(** The simulation kind specifies whether the baker should first filter (and - then apply) the provided operations, or just apply them. The former case is - used for fresh proposals, while the latter for re-proposals (of an already - proposed payload). *) -type simulation_kind = - | Filter of Operation_pool.Prioritized.t - | Apply of { - ordered_pool : Operation_pool.ordered_pool; - payload_hash : Block_payload_hash.t; - } - -val forge : - #Protocol_client_context.full -> - chain_id:Chain_id.t -> - pred_info:Baking_state.block_info -> - pred_resulting_context_hash:Context_hash.t -> - pred_live_blocks:Block_hash.Set.t -> - timestamp:Time.Protocol.t -> - round:Round.t -> - liquidity_baking_toggle_vote:Per_block_votes.per_block_vote -> - adaptive_issuance_vote:Per_block_votes.per_block_vote -> - user_activated_upgrades:User_activated.upgrades -> - Baking_configuration.fees_config -> - force_apply:bool -> - seed_nonce_hash:Nonce_hash.t option -> - payload_round:Round.t -> - Baking_state.validation_mode -> - simulation_kind -> - Constants.Parametric.t -> - unsigned_block tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/client_baking_blocks.ml b/src/proto_020_PsParisC/lib_delegate/client_baking_blocks.ml deleted file mode 100644 index 360bf2e0bec5..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/client_baking_blocks.ml +++ /dev/null @@ -1,219 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol -open Alpha_context -open Baking_errors - -type block_info = { - hash : Block_hash.t; - chain_id : Chain_id.t; - predecessor : Block_hash.t; - fitness : Bytes.t list; - timestamp : Time.Protocol.t; - protocol : Protocol_hash.t; - next_protocol : Protocol_hash.t; - proto_level : int; - level : Raw_level.t; - context : Context_hash.t; -} - -let raw_info cctxt ?(chain = `Main) hash shell_header = - let open Lwt_result_syntax in - let block = `Hash (hash, 0) in - let* chain_id = Shell_services.Chain.chain_id cctxt ~chain () in - let* {current_protocol = protocol; next_protocol} = - Shell_services.Blocks.protocols cctxt ~chain ~block () - in - let { - Tezos_base.Block_header.predecessor; - fitness; - timestamp; - level; - context; - proto_level; - _; - } = - shell_header - in - match Raw_level.of_int32 level with - | Ok level -> - return - { - hash; - chain_id; - predecessor; - fitness; - timestamp; - protocol; - next_protocol; - proto_level; - level; - context; - } - | Error _ -> failwith "Cannot convert level into int32" - -let info cctxt ?(chain = `Main) block = - let open Lwt_result_syntax in - let* hash = Shell_services.Blocks.hash cctxt ~chain ~block () in - let* shell_header = - Shell_services.Blocks.Header.shell_header cctxt ~chain ~block () - in - raw_info cctxt ~chain hash shell_header - -module Block_seen_event = struct - type t = { - hash : Block_hash.t; - header : Tezos_base.Block_header.t; - occurrence : [`Valid_blocks of Chain_id.t | `Heads]; - } - - let make hash header occurrence = {hash; header; occurrence} - - module Definition = struct - let section = None - - let name = "block-seen-" ^ Protocol.name - - type nonrec t = t - - let encoding = - let open Data_encoding in - let v0_encoding = - conv - (function {hash; header; occurrence} -> (hash, occurrence, header)) - (fun (hash, occurrence, header) -> make hash header occurrence) - (obj3 - (req "hash" Block_hash.encoding) - (* Occurrence has to come before header, because: - (Invalid_argument - "Cannot merge two objects when the left element is of - variable length and the right one of dynamic - length. You should use the reverse order, or wrap the - second one with Data_encoding.dynamic_size.") *) - (req - "occurrence" - (union - [ - case - ~title:"heads" - (Tag 0) - (obj1 (req "occurrence-kind" (constant "heads"))) - (function `Heads -> Some () | _ -> None) - (fun () -> `Heads); - case - ~title:"valid-blocks" - (Tag 1) - (obj2 - (req "occurrence-kind" (constant "valid-blocks")) - (req "chain-id" Chain_id.encoding)) - (function - | `Valid_blocks ch -> Some ((), ch) | _ -> None) - (fun ((), ch) -> `Valid_blocks ch); - ])) - (req "header" Tezos_base.Block_header.encoding)) - in - With_version.(encoding ~name (first_version v0_encoding)) - - let pp ~all_fields:_ ~block:_ ppf {hash; _} = - Format.fprintf ppf "Saw block %a" Block_hash.pp_short hash - - let doc = "Block observed while monitoring a blockchain." - - let level = Internal_event.Info - - let alternative_color = None - end - - module Event = Internal_event.Make (Definition) -end - -let monitor_applied_blocks cctxt ?chains ?protocols ~next_protocols () = - let open Lwt_result_syntax in - let* block_stream, stop = - Monitor_services.applied_blocks cctxt ?chains ?protocols ?next_protocols () - in - return - ( Lwt_stream.map_s - (fun (chain, block, header, _ops) -> - let* () = - Block_seen_event.( - Event.emit (make block header (`Valid_blocks chain))) - in - raw_info - cctxt - ~chain:(`Hash chain) - block - header.Tezos_base.Block_header.shell) - block_stream, - stop ) - -let monitor_heads cctxt ~next_protocols chain = - let open Lwt_result_syntax in - let* block_stream, stop = - Monitor_services.heads cctxt ?next_protocols chain - in - return - ( Lwt_stream.map_s - (fun (block, ({Tezos_base.Block_header.shell; _} as header)) -> - let* () = Block_seen_event.(Event.emit (make block header `Heads)) in - raw_info cctxt ~chain block shell) - block_stream, - stop ) - -let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = - let open Lwt_result_syntax in - let* hash = Shell_services.Blocks.hash cctxt ~chain ~block () in - let* {level; _} = - Shell_services.Blocks.Header.shell_header cctxt ~chain ~block () - in - let*! result = - Plugin.RPC.levels_in_current_cycle cctxt ~offset (chain, block) - in - match result with - | Error (Tezos_rpc.Context.Not_found _ :: _) -> return_nil - | Error _ as err -> Lwt.return err - | Ok (first, last) -> - let length = Int32.to_int (Int32.sub level (Raw_level.to_int32 first)) in - let* head = - let* list = - Shell_services.Blocks.list cctxt ~chain ~heads:[hash] ~length () - in - match list with - | hd :: _ -> return hd - | [] -> - tzfail - (Unexpected_empty_block_list - { - chain = Block_services.chain_to_string chain; - block_hash = hash; - length; - }) - in - let blocks = - List.drop_n (length - Int32.to_int (Raw_level.diff last first)) head - in - if Int32.equal level (Raw_level.to_int32 last) then return (hash :: blocks) - else return blocks diff --git a/src/proto_020_PsParisC/lib_delegate/client_baking_blocks.mli b/src/proto_020_PsParisC/lib_delegate/client_baking_blocks.mli deleted file mode 100644 index 8426c19b8994..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/client_baking_blocks.mli +++ /dev/null @@ -1,68 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol -open Alpha_context - -type block_info = { - hash : Block_hash.t; - chain_id : Chain_id.t; - predecessor : Block_hash.t; - fitness : Bytes.t list; - timestamp : Time.Protocol.t; - protocol : Protocol_hash.t; - next_protocol : Protocol_hash.t; - proto_level : int; - level : Raw_level.t; - context : Context_hash.t; -} - -val info : - #Protocol_client_context.rpc_context -> - ?chain:Chain_services.chain -> - Block_services.block -> - block_info tzresult Lwt.t - -val monitor_applied_blocks : - #Protocol_client_context.rpc_context -> - ?chains:Chain_services.chain list -> - ?protocols:Protocol_hash.t list -> - next_protocols:Protocol_hash.t list option -> - unit -> - (block_info tzresult Lwt_stream.t * Tezos_rpc.Context.stopper) tzresult Lwt.t - -val monitor_heads : - #Protocol_client_context.rpc_context -> - next_protocols:Protocol_hash.t list option -> - Chain_services.chain -> - (block_info tzresult Lwt_stream.t * Tezos_rpc.Context.stopper) tzresult Lwt.t - -val blocks_from_current_cycle : - #Protocol_client_context.rpc_context -> - ?chain:Chain_services.chain -> - Block_services.block -> - ?offset:int32 -> - unit -> - Block_hash.t list tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/client_baking_denunciation.ml b/src/proto_020_PsParisC/lib_delegate/client_baking_denunciation.ml deleted file mode 100644 index 49a3cb5aeafe..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/client_baking_denunciation.ml +++ /dev/null @@ -1,639 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol -open Alpha_context -open Protocol_client_context -open Client_baking_blocks -module Events = Delegate_events.Denunciator -module B_Events = Delegate_events.Baking_scheduling - -module HLevel = Hashtbl.Make (struct - type t = Chain_id.t * Raw_level.t * Round.t - - let equal (c, l, r) (c', l', r') = - Chain_id.equal c c' && Raw_level.equal l l' && Round.equal r r' - - let hash (c, lvl, r) = Hashtbl.hash (c, lvl, r) -end) - -(* Blocks are associated to the delegates who baked them *) -module Delegate_map = Signature.Public_key_hash.Map - -module Validators_cache = - Aches.Vache.Map (Aches.Vache.FIFO_Precise) (Aches.Vache.Strong) - (struct - type t = Raw_level.t - - let equal = Raw_level.equal - - let hash = Hashtbl.hash - end) - -(* type of operations stream, as returned by monitor_operations RPC *) -type ops_stream = - ((Operation_hash.t * packed_operation) * error trace option) list Lwt_stream.t - -type 'kind recorded_consensus = - | No_operation_seen - | Operation_seen of { - operation : 'kind operation; - previously_denounced_oph : Operation_hash.t option; - } - -type recorded_consensus_operations = { - attestation : Kind.attestation recorded_consensus; - preattestation : Kind.preattestation recorded_consensus; -} - -type 'a state = { - (* Validators rights for the last preserved levels *) - validators_rights : public_key_hash Slot.Map.t Validators_cache.t; - (* Consensus operations seen so far *) - consensus_operations_table : - recorded_consensus_operations Delegate_map.t HLevel.t; - (* Blocks received so far *) - blocks_table : Block_hash.t Delegate_map.t HLevel.t; - (* Maximum delta of level to register *) - preserved_levels : int; - (* Highest level seen in a block *) - mutable highest_level_encountered : Raw_level.t; - (* This constant allows to set at which frequency (expressed in blocks levels) - the tables above are cleaned. Cleaning the table means removing information - stored about old levels up to - 'highest_level_encountered - preserved_levels'. - *) - clean_frequency : int; - (* the decreasing cleaning countdown for the next cleaning *) - mutable cleaning_countdown : int; - (* stream of all valid blocks *) - blocks_stream : (block_info, 'a) result Lwt_stream.t; - (* operations stream. Reset on new heads flush *) - mutable ops_stream : ops_stream; - (* operatons stream stopper. Used when a q new *) - mutable ops_stream_stopper : unit -> unit; -} - -let create_state ~preserved_levels blocks_stream ops_stream ops_stream_stopper = - let clean_frequency = max 1 (preserved_levels / 10) in - let validators_rights = Validators_cache.create (preserved_levels + 2) in - (* We keep rights for [preserved_levels] in the past, and 2 levels in the - future from [highest_level_encountered] *) - Lwt.return - { - validators_rights; - consensus_operations_table = HLevel.create preserved_levels; - blocks_table = HLevel.create preserved_levels; - preserved_levels; - highest_level_encountered = Raw_level.root (* 0l *); - clean_frequency; - cleaning_countdown = clean_frequency; - blocks_stream; - ops_stream; - ops_stream_stopper; - } - -(* We choose a previous offset (5 blocks from head) to ensure that the - injected operation is branched from a valid - predecessor. Denunciation operations can be emitted when the - consensus is under attack and may occur so you want to inject the - operation from a block which is considered "final". *) -let get_block_offset level = - let open Lwt_syntax in - match Raw_level.of_int32 5l with - | Ok min_level -> - let offset = Raw_level.diff level min_level in - if Compare.Int32.(offset >= 0l) then return (`Head 5) - else - (* offset < 0l *) - let negative_offset = Int32.to_int offset in - (* We cannot inject at at level 0 : this is the genesis - level. We inject starting from level 1 thus the '- 1'. *) - return (`Head (5 + negative_offset - 1)) - | Error errs -> - let* () = - Events.(emit invalid_level_conversion) (Environment.wrap_tztrace errs) - in - return (`Head 0) - -let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) - (op : kind Operation.t) = - match (op_kind, op.protocol_data.contents) with - | Preattestation, Single (Preattestation consensus_content) - | Attestation, Single (Attestation {consensus_content; _}) -> - consensus_content.block_payload_hash - -let get_slot (type kind) (op_kind : kind consensus_operation_type) - (op : kind Operation.t) = - match (op_kind, op.protocol_data.contents) with - | Preattestation, Single (Preattestation consensus_content) - | Attestation, Single (Attestation {consensus_content; _}) -> - consensus_content.slot - -let double_consensus_op_evidence (type kind) : - kind consensus_operation_type -> - #Protocol_client_context.full -> - 'a -> - branch:Block_hash.t -> - op1:kind Alpha_context.operation -> - op2:kind Alpha_context.operation -> - unit -> - bytes Environment.Error_monad.shell_tzresult Lwt.t = function - | Attestation -> Plugin.RPC.Forge.double_attestation_evidence - | Preattestation -> Plugin.RPC.Forge.double_preattestation_evidence - -let lookup_recorded_consensus (type kind) consensus_key - (op_kind : kind consensus_operation_type) map : kind recorded_consensus = - match Delegate_map.find consensus_key map with - | None -> No_operation_seen - | Some {attestation; preattestation} -> ( - match op_kind with - | Attestation -> attestation - | Preattestation -> preattestation) - -let add_consensus_operation (type kind) consensus_key - (op_kind : kind consensus_operation_type) - (recorded_operation : kind recorded_consensus) map = - Delegate_map.update - consensus_key - (fun x -> - let record = - Option.value - ~default: - { - attestation = No_operation_seen; - preattestation = No_operation_seen; - } - x - in - match op_kind with - | Attestation -> Some {record with attestation = recorded_operation} - | Preattestation -> Some {record with preattestation = recorded_operation}) - map - -let get_validator_rights state cctxt level = - let open Lwt_result_syntax in - match Validators_cache.find_opt state.validators_rights level with - | None -> - let* validators = - Plugin.RPC.Validators.get cctxt (cctxt#chain, `Head 0) ~levels:[level] - in - let validators = - List.fold_left - (fun acc ({consensus_key; slots; _} : RPC.Validators.t) -> - List.fold_left - (fun acc slot -> Slot.Map.add slot consensus_key acc) - acc - slots) - Slot.Map.empty - validators - in - Validators_cache.replace state.validators_rights level validators ; - return validators - | Some t -> return t - -let process_consensus_op (type kind) state cctxt - (op_kind : kind consensus_operation_type) (new_op : kind Operation.t) - chain_id level round slot = - let open Lwt_result_syntax in - let diff = Raw_level.diff state.highest_level_encountered level in - if Int32.(diff > of_int state.preserved_levels) then - (* We do not handle operations older than [preserved_levels] *) - let*! () = - Events.(emit consensus_operation_too_old) (Operation.hash new_op) - in - return_unit - else if diff < -2l then - (* We do not handle operations too far in the future *) - let*! () = - Events.(emit consensus_operation_too_far_in_future) - (Operation.hash new_op) - in - return_unit - else - let* attesting_rights = get_validator_rights state cctxt level in - match Slot.Map.find slot attesting_rights with - | None -> - (* We do not handle operations that do not have a valid slot *) - return_unit - | Some consensus_key -> ( - let round_map = - Option.value ~default:Delegate_map.empty - @@ HLevel.find - state.consensus_operations_table - (chain_id, level, round) - in - match lookup_recorded_consensus consensus_key op_kind round_map with - | No_operation_seen -> - return - @@ HLevel.add - state.consensus_operations_table - (chain_id, level, round) - (add_consensus_operation - consensus_key - op_kind - (Operation_seen - {operation = new_op; previously_denounced_oph = None}) - round_map) - | Operation_seen {operation = existing_op; previously_denounced_oph} - when Block_payload_hash.( - get_payload_hash op_kind existing_op - <> get_payload_hash op_kind new_op) - || Slot.(get_slot op_kind existing_op <> slot) - || Block_hash.(existing_op.shell.branch <> new_op.shell.branch) - -> - (* Same level, round, and delegate, and: - different payload hash OR different slot OR different branch *) - let new_op_hash, existing_op_hash = - (Operation.hash new_op, Operation.hash existing_op) - in - let op1, op2 = - if Operation_hash.(new_op_hash < existing_op_hash) then - (new_op, existing_op) - else (existing_op, new_op) - in - let*! block = get_block_offset level in - let chain = `Hash chain_id in - let* block_hash = - Alpha_block_services.hash cctxt ~chain ~block () - in - let* bytes = - double_consensus_op_evidence - op_kind - cctxt - (`Hash chain_id, block) - ~branch:block_hash - ~op1 - ~op2 - () - in - let bytes = Signature.concat bytes Signature.zero in - let double_op_detected, double_op_denounced = - Events.( - match op_kind with - | Attestation -> - (double_attestation_detected, double_attestation_denounced) - | Preattestation -> - ( double_preattestation_detected, - double_preattestation_denounced )) - in - let*! () = - Events.(emit double_op_detected) (new_op_hash, existing_op_hash) - in - let* op_hash = - Shell_services.Injection.private_operation cctxt ~chain bytes - in - let*! () = - match previously_denounced_oph with - | Some oph -> Events.(emit double_consensus_already_denounced) oph - | None -> Lwt.return_unit - in - HLevel.replace - state.consensus_operations_table - (chain_id, level, round) - (add_consensus_operation - consensus_key - op_kind - (Operation_seen - { - operation = new_op; - previously_denounced_oph = Some op_hash; - }) - round_map) ; - let*! () = Events.(emit double_op_denounced) (op_hash, bytes) in - return_unit - | _ -> return_unit) - -let process_operations (cctxt : #Protocol_client_context.full) state - (attestations : 'a list) ~packed_op chain_id = - let open Lwt_result_syntax in - List.iter_es - (fun op -> - let {shell; protocol_data; _} = packed_op op in - match protocol_data with - | Operation_data - ({contents = Single (Preattestation {round; slot; level; _}); _} as - protocol_data) -> - let new_preattestation : Kind.preattestation Alpha_context.operation = - {shell; protocol_data} - in - process_consensus_op - state - cctxt - Preattestation - new_preattestation - chain_id - level - round - slot - | Operation_data - ({ - contents = - Single - (Attestation {consensus_content = {round; slot; level; _}; _}); - _; - } as protocol_data) -> - let new_attestation : Kind.attestation Alpha_context.operation = - {shell; protocol_data} - in - process_consensus_op - state - cctxt - Attestation - new_attestation - chain_id - level - round - slot - | _ -> - (* not a consensus operation *) - return_unit) - attestations - -let context_block_header cctxt ~chain b_hash = - let open Lwt_result_syntax in - let* ({shell; protocol_data; _} : Alpha_block_services.block_header) = - Alpha_block_services.header cctxt ~chain ~block:(`Hash (b_hash, 0)) () - in - return {Alpha_context.Block_header.shell; protocol_data} - -let process_block (cctxt : #Protocol_client_context.full) state - (header : Alpha_block_services.block_info) = - let open Lwt_result_syntax in - match header with - | {hash; metadata = None; _} -> - let*! () = Events.(emit unexpected_pruned_block) hash in - return_unit - | { - Alpha_block_services.chain_id; - hash = new_hash; - metadata = Some {protocol_data = {baker; level_info = {level; _}; _}; _}; - header = {shell = {fitness; _}; _}; - _; - } -> ( - let fitness = Fitness.from_raw fitness in - let*? round = - match fitness with - | Ok fitness -> Ok (Fitness.round fitness) - | Error errs -> Error (Environment.wrap_tztrace errs) - in - let chain = `Hash chain_id in - let map = - Option.value ~default:Delegate_map.empty - @@ HLevel.find state.blocks_table (chain_id, level, round) - in - match Delegate_map.find baker.delegate map with - | None -> - return - @@ HLevel.add - state.blocks_table - (chain_id, level, round) - (Delegate_map.add baker.delegate new_hash map) - | Some existing_hash when Block_hash.(existing_hash = new_hash) -> - (* This case should never happen *) - let*! () = Events.(emit double_baking_but_not) () in - return - @@ HLevel.replace - state.blocks_table - (chain_id, level, round) - (Delegate_map.add baker.delegate new_hash map) - | Some existing_hash -> - (* If a previous block made by this pkh is found for - the same (level, round) we inject a double_baking_evidence *) - let* bh1 = context_block_header cctxt ~chain existing_hash in - let* bh2 = context_block_header cctxt ~chain new_hash in - let hash1 = Block_header.hash bh1 in - let hash2 = Block_header.hash bh2 in - let bh1, bh2 = - if Block_hash.(hash1 < hash2) then (bh1, bh2) else (bh2, bh1) - in - (* If the blocks are on different chains then skip it *) - let*! block = get_block_offset level in - let* block_hash = Alpha_block_services.hash cctxt ~chain ~block () in - let* bytes = - Plugin.RPC.Forge.double_baking_evidence - cctxt - (chain, block) - ~branch:block_hash - ~bh1 - ~bh2 - () - in - let bytes = Signature.concat bytes Signature.zero in - let*! () = Events.(emit double_baking_detected) () in - let* op_hash = - Shell_services.Injection.operation cctxt ~chain bytes - in - let*! () = Events.(emit double_baking_denounced) (op_hash, bytes) in - return - @@ HLevel.replace - state.blocks_table - (chain_id, level, round) - (Delegate_map.add baker.delegate new_hash map)) - -(* Remove levels that are lower than the - [highest_level_encountered] minus [preserved_levels] *) -let cleanup_old_operations state = - state.cleaning_countdown <- state.cleaning_countdown - 1 ; - if state.cleaning_countdown < 0 then ( - (* It's time to remove old levels *) - state.cleaning_countdown <- state.clean_frequency ; - let highest_level_encountered = - Int32.to_int (Raw_level.to_int32 state.highest_level_encountered) - in - let diff = highest_level_encountered - state.preserved_levels in - let threshold = - if diff < 0 then Raw_level.root - else - Raw_level.of_int32 (Int32.of_int diff) |> function - | Ok threshold -> threshold - | Error _ -> Raw_level.root - in - let filter hmap = - HLevel.filter_map_inplace - (fun (_, level, _) x -> - if Raw_level.(level < threshold) then None else Some x) - hmap - in - filter state.consensus_operations_table ; - filter state.blocks_table) - -(* Each new block is processed : - - Check that every baker injected a proposal only once at the block's level and round - - Check that every baker (pre)attested only once at the block's level and round -*) -let process_new_block (cctxt : #Protocol_client_context.full) state - {hash; chain_id; level; protocol; next_protocol; _} = - let open Lwt_result_syntax in - if Protocol_hash.(protocol <> next_protocol) then - let*! () = Events.(emit protocol_change_detected) () in - return_unit - else - let*! () = Events.(emit accuser_saw_block) (level, hash) in - let chain = `Hash chain_id in - let block = `Hash (hash, 0) in - state.highest_level_encountered <- - Raw_level.max level state.highest_level_encountered ; - (* Processing blocks *) - let* () = - let*! block_info = Alpha_block_services.info cctxt ~chain ~block () in - match block_info with - | Ok block_info -> ( - let* () = process_block cctxt state block_info in - (* Processing (pre)attestations in the block *) - match block_info.operations with - | consensus_ops :: _ -> - let packed_op {Alpha_block_services.shell; protocol_data; _} = - {shell; protocol_data} - in - process_operations cctxt state consensus_ops ~packed_op chain_id - | _ -> - (* Should not happen as a block should contain 4 lists of - operations, the first list being dedicated to consensus - operations. *) - let*! () = Events.(emit fetch_operations_error hash) in - return_unit) - | Error errs -> - let*! () = Events.(emit accuser_block_error) (hash, errs) in - return_unit - in - cleanup_old_operations state ; - return_unit - -let process_new_block cctxt state bi = - let open Lwt_syntax in - let* result = process_new_block cctxt state bi in - match result with - | Ok () -> - let* () = Events.(emit accuser_processed_block) bi.hash in - return_unit - | Error errs -> - let* () = Events.(emit accuser_block_error) (bi.hash, errs) in - return_unit - -let log_errors_and_continue ~name p = - let open Lwt_syntax in - let* result = p in - match result with - | Ok () -> return_unit - | Error errs -> B_Events.(emit daemon_error) (name, errs) - -let start_ops_monitor cctxt = - Alpha_block_services.Mempool.monitor_operations - cctxt - ~chain:cctxt#chain - ~validated:true - ~branch_delayed:true - ~branch_refused:false - ~refused:false - ~outdated:false - () - -let create (cctxt : #Protocol_client_context.full) ?canceler ~preserved_levels - valid_blocks_stream = - let open Lwt_result_syntax in - let*! () = B_Events.(emit daemon_setup) name in - let* ops_stream, ops_stream_stopper = start_ops_monitor cctxt in - let*! state = - create_state - ~preserved_levels - valid_blocks_stream - ops_stream - ops_stream_stopper - in - Option.iter - (fun canceler -> - Lwt_canceler.on_cancel canceler (fun () -> - state.ops_stream_stopper () ; - Lwt.return_unit)) - canceler ; - let last_get_block = ref None in - let get_block () = - match !last_get_block with - | None -> - let t = - let*! e = Lwt_stream.get state.blocks_stream in - Lwt.return (`Block e) - in - last_get_block := Some t ; - t - | Some t -> t - in - let last_get_ops = ref None in - let get_ops () = - match !last_get_ops with - | None -> - let t = - let*! e = Lwt_stream.get state.ops_stream in - Lwt.return (`Operations e) - in - last_get_ops := Some t ; - t - | Some t -> t - in - let* chain_id = Chain_services.chain_id cctxt () in - (* main loop *) - (* Only allocate once the termination promise *) - let terminated = - let*! _ = Lwt_exit.clean_up_starts in - Lwt.return `Termination - in - let rec worker_loop () = - let*! result = Lwt.choose [terminated; get_block (); get_ops ()] in - match result with - (* event matching *) - | `Termination -> return_unit - | `Block (None | Some (Error _)) -> - (* exit when the node is unavailable *) - last_get_block := None ; - let*! () = B_Events.(emit daemon_connection_lost) name in - tzfail Baking_errors.Node_connection_lost - | `Block (Some (Ok bi)) -> - last_get_block := None ; - let*! () = process_new_block cctxt state bi in - worker_loop () - | `Operations None -> - (* restart a new operations monitor stream *) - last_get_ops := None ; - state.ops_stream_stopper () ; - let* ops_stream, ops_stream_stopper = start_ops_monitor cctxt in - state.ops_stream <- ops_stream ; - state.ops_stream_stopper <- ops_stream_stopper ; - worker_loop () - | `Operations (Some ops) -> - last_get_ops := None ; - let*! () = - log_errors_and_continue ~name - @@ process_operations - cctxt - state - ops - ~packed_op:(fun ((_h, op), _errl) -> op) - chain_id - in - worker_loop () - in - let*! () = B_Events.(emit daemon_start) name in - worker_loop () diff --git a/src/proto_020_PsParisC/lib_delegate/client_baking_denunciation.mli b/src/proto_020_PsParisC/lib_delegate/client_baking_denunciation.mli deleted file mode 100644 index 46e784d132b4..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/client_baking_denunciation.mli +++ /dev/null @@ -1,31 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 create : - #Protocol_client_context.full -> - ?canceler:Lwt_canceler.t -> - preserved_levels:int -> - Client_baking_blocks.block_info tzresult Lwt_stream.t -> - unit tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/client_baking_scheduling.ml b/src/proto_020_PsParisC/lib_delegate/client_baking_scheduling.ml deleted file mode 100644 index f34bf9da1c20..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/client_baking_scheduling.ml +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Events = Delegate_events.Baking_scheduling - -let sleep_until time = - (* Sleeping is a system op, baking is a protocol op, this is where we convert *) - let time = Time.System.of_protocol_exn time in - let delay = Ptime.diff time (Time.System.now ()) in - if Ptime.Span.compare delay Ptime.Span.zero < 0 then None - else Some (Lwt_unix.sleep (Ptime.Span.to_float_s delay)) diff --git a/src/proto_020_PsParisC/lib_delegate/client_baking_scheduling.mli b/src/proto_020_PsParisC/lib_delegate/client_baking_scheduling.mli deleted file mode 100644 index ae4a323ca1cc..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/client_baking_scheduling.mli +++ /dev/null @@ -1,54 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 sleep_until : Time.Protocol.t -> unit Lwt.t option - -(* val wait_for_first_event : - * name:string -> 'event tzresult Lwt_stream.t -> 'event Lwt.t - * - * val main : - * name:string -> - * cctxt:(#Protocol_client_context.full as 'a) -> - * stream:'event tzresult Lwt_stream.t -> - * state_maker:('event -> 'state tzresult Lwt.t) -> - * pre_loop:('a -> 'state -> 'event -> unit tzresult Lwt.t) -> - * compute_timeout:('state -> 'timesup Lwt.t) -> - * timeout_k:('a -> 'state -> 'timesup -> unit tzresult Lwt.t) -> - * event_k:('a -> 'state -> 'event -> unit tzresult Lwt.t) -> - * finalizer:('state -> unit Lwt.t) -> - * unit tzresult Lwt.t *) - -(** [main ~name ~cctxt ~stream ~state_maker ~pre_loop ~timeout_maker ~timeout_k - ~event_k] is an infinitely running loop that - monitors new events arriving on [stream]. The loop exits when the - [stream] gives an error. - - The function [pre_loop] is called before the loop starts. - - The loop maintains a state (of type ['state]) initialized by [state_maker] - and passed to the callbacks [timeout_maker] (used to set up waking-up - timeouts), [timeout_k] (when a computed timeout happens), and [event_k] - (when a new event arrives on the stream). -*) diff --git a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml b/src/proto_020_PsParisC/lib_delegate/client_daemon.ml deleted file mode 100644 index cb1cfe348bd8..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/client_daemon.ml +++ /dev/null @@ -1,236 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 rec retry_on_disconnection (cctxt : #Protocol_client_context.full) f = - let open Lwt_result_syntax in - let*! result = f () in - match result with - | Ok () -> return_unit - | Error (Baking_errors.Node_connection_lost :: _) -> - let*! () = - cctxt#warning - "Lost connection with the node. Retrying to establish connection..." - in - (* Wait forever when the node stops responding... *) - let* () = - Client_confirmations.wait_for_bootstrapped - ~retry: - (Baking_scheduling.retry - cctxt - ~max_delay:10. - ~delay:1. - ~factor:1.5 - ~tries:max_int) - cctxt - in - retry_on_disconnection cctxt f - | Error err -> - cctxt#error "Unexpected error: %a. Exiting..." pp_print_trace err - -let await_protocol_start (cctxt : #Protocol_client_context.full) ~chain = - let open Lwt_result_syntax in - let*! () = - cctxt#message "Waiting for protocol %s to start..." Protocol.name - in - Node_rpc.await_protocol_activation cctxt ~chain () - -let[@warning "-32"] may_start_profiler baking_dir = - match Tezos_base_unix.Profiler_instance.selected_backend () with - | Some profiler_maker -> - let profiler_maker = profiler_maker ~directory:baking_dir in - Baking_profiler.activate_all ~profiler_maker ; - RPC_profiler.init profiler_maker - | None -> () - -module Baker = struct - let run (cctxt : Protocol_client_context.full) ?minimal_fees - ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?votes - ?extra_operations ?dal_node_endpoint ?pre_emptive_forge_time ?force_apply - ?remote_calls_timeout ?context_path ?state_recorder ~chain ~keep_alive - delegates = - let open Lwt_result_syntax in - let process () = - let* user_activated_upgrades = - Config_services.user_activated_upgrades cctxt - in - let* constants = - let* chain_id = - Shell_services.Chain.chain_id cctxt ~chain:cctxt#chain () - in - Protocol.Alpha_services.Constants.all cctxt (`Hash chain_id, `Head 0) - in - let block_time_s = - Int64.to_float - (Protocol.Alpha_context.Period.to_seconds - constants.parametric.minimal_block_delay) - in - let* pre_emptive_forge_time = - match Option.map Q.to_float pre_emptive_forge_time with - | Some t -> - if t >= block_time_s then - failwith - "pre-emptive-forge-time must be less than current block time \ - (<= %f seconds)" - block_time_s - else return t - | None -> return (Float.mul 0.15 block_time_s) - in - let*! () = - if pre_emptive_forge_time <> 0. then - cctxt#message - "pre-emptive-forge-time optimization set to %fs. Operation \ - inclusion window is ~%fs. Caution: Setting this too high may \ - result in reduced block proposal rewards." - pre_emptive_forge_time - (Float.sub block_time_s pre_emptive_forge_time) - else Lwt.return_unit - in - let pre_emptive_forge_time = - Time.System.Span.of_seconds_exn pre_emptive_forge_time - in - let remote_calls_timeout = Option.map Q.to_float remote_calls_timeout in - let config = - Baking_configuration.make - ?minimal_fees - ?minimal_nanotez_per_gas_unit - ?minimal_nanotez_per_byte - ?votes - ?extra_operations - ?dal_node_endpoint - ~pre_emptive_forge_time - ?force_apply - ?remote_calls_timeout - ?context_path - ~user_activated_upgrades - ?state_recorder - () - in - let*! () = - cctxt#message - "Baker %a (%s) for %a started." - Tezos_version.Version.pp_simple - Tezos_version_value.Current_git_info.octez_version - Tezos_version_value.Current_git_info.abbreviated_commit_hash - Protocol_hash.pp_short - Protocol.hash - in - let canceler = Lwt_canceler.create () in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - let*! () = cctxt#message "Shutting down the baker..." in - let*! _ = Lwt_canceler.cancel canceler in - Lwt.return_unit) - in - () [@profiler.custom may_start_profiler cctxt#get_base_dir] ; - let consumer = Protocol_logging.make_log_message_consumer () in - Lifted_protocol.set_log_message_consumer consumer ; - Baking_scheduling.run cctxt ~canceler ~chain ~constants config delegates - in - let* () = - Client_confirmations.wait_for_bootstrapped - ~retry:(Baking_scheduling.retry cctxt ~delay:1. ~factor:1.5 ~tries:5) - cctxt - in - let* () = await_protocol_start cctxt ~chain in - if keep_alive then retry_on_disconnection cctxt process else process () -end - -module Accuser = struct - let run (cctxt : #Protocol_client_context.full) ~chain ~preserved_levels - ~keep_alive = - let open Lwt_result_syntax in - let process () = - let*! () = - cctxt#message - "Accuser %a (%s) for %a started." - Tezos_version.Version.pp_simple - Tezos_version_value.Current_git_info.octez_version - Tezos_version_value.Current_git_info.abbreviated_commit_hash - Protocol_hash.pp_short - Protocol.hash - in - let* valid_blocks_stream, _ = - Client_baking_blocks.monitor_applied_blocks - ~next_protocols:(Some [Protocol.hash]) - cctxt - ~chains:[chain] - () - in - let canceler = Lwt_canceler.create () in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - let*! () = cctxt#message "Shutting down the accuser..." in - let*! _ = Lwt_canceler.cancel canceler in - Lwt.return_unit) - in - Client_baking_denunciation.create - cctxt - ~canceler - ~preserved_levels - valid_blocks_stream - in - let* () = - Client_confirmations.wait_for_bootstrapped - ~retry:(Baking_scheduling.retry cctxt ~delay:1. ~factor:1.5 ~tries:5) - cctxt - in - let* () = await_protocol_start cctxt ~chain in - if keep_alive then retry_on_disconnection cctxt process else process () -end - -module VDF = struct - let run (cctxt : Protocol_client_context.full) ~chain ~keep_alive = - let open Lwt_result_syntax in - let process () = - let*! () = - cctxt#message - "VDF daemon %a (%s) for %a started." - Tezos_version.Version.pp_simple - Tezos_version_value.Current_git_info.octez_version - Tezos_version_value.Current_git_info.abbreviated_commit_hash - Protocol_hash.pp_short - Protocol.hash - in - let* chain_id = Shell_services.Chain.chain_id cctxt ~chain () in - let* constants = - Protocol.Alpha_services.Constants.all cctxt (`Hash chain_id, `Head 0) - in - let canceler = Lwt_canceler.create () in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - let*! () = cctxt#message "Shutting down the VDF daemon..." in - let*! _ = Lwt_canceler.cancel canceler in - Lwt.return_unit) - in - Baking_vdf.start_vdf_worker cctxt ~canceler constants chain - in - let* () = - Client_confirmations.wait_for_bootstrapped - ~retry:(Baking_scheduling.retry cctxt ~delay:1. ~factor:1.5 ~tries:5) - cctxt - in - let* () = await_protocol_start cctxt ~chain in - if keep_alive then retry_on_disconnection cctxt process else process () -end diff --git a/src/proto_020_PsParisC/lib_delegate/client_daemon.mli b/src/proto_020_PsParisC/lib_delegate/client_daemon.mli deleted file mode 100644 index 705dac68cc72..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/client_daemon.mli +++ /dev/null @@ -1,68 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Daemons directly supported by lib_delegate *) - -(** {1 Baker daemon} *) -module Baker : sig - val run : - Protocol_client_context.full -> - ?minimal_fees:Protocol.Alpha_context.Tez.t -> - ?minimal_nanotez_per_gas_unit:Q.t -> - ?minimal_nanotez_per_byte:Q.t -> - ?votes:Baking_configuration.per_block_votes_config -> - ?extra_operations:Baking_configuration.Operations_source.t -> - ?dal_node_endpoint:Uri.t -> - ?pre_emptive_forge_time:Q.t -> - ?force_apply:bool -> - ?remote_calls_timeout:Q.t -> - ?context_path:string -> - ?state_recorder:Baking_configuration.state_recorder_config -> - chain:Shell_services.chain -> - keep_alive:bool -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t -end - -(** {1 Accuser daemon} *) - -module Accuser : sig - val run : - #Protocol_client_context.full -> - chain:Chain_services.chain -> - preserved_levels:int -> - keep_alive:bool -> - unit tzresult Lwt.t -end - -(** {1 VDF computation daemon} *) - -module VDF : sig - val run : - Protocol_client_context.full -> - chain:Chain_services.chain -> - keep_alive:bool -> - unit tzresult Lwt.t -end diff --git a/src/proto_020_PsParisC/lib_delegate/delegate_events.ml b/src/proto_020_PsParisC/lib_delegate/delegate_events.ml deleted file mode 100644 index 1efa1dd56e68..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/delegate_events.ml +++ /dev/null @@ -1,256 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Tocqueville Group, 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 Protocol - -let level = Internal_event.Notice - -(* Ignore the value in the output. *) -let pp_ignore fmt _ = Format.pp_print_string fmt "" - -module Denunciator = struct - include Internal_event.Simple - - let section = [Protocol.name; "delegate"; "denunciation"] - - let invalid_level_conversion = - declare_1 - ~section - ~level:Error - ~name:"invalid_level_conversion" - ~msg:"invalid level conversion: {errors}" - ~pp1:pp_print_top_error_of_trace - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - - let double_attestation_detected = - declare_2 - ~alternative_color:Internal_event.Magenta - ~section - ~level - ~name:"double_attestation_detected" - ~msg:"double attestation detected" - ("existing_attestation", Operation_hash.encoding) - ("new_attestation", Operation_hash.encoding) - - let double_attestation_denounced = - declare_2 - ~alternative_color:Internal_event.Blue - ~section - ~level - ~name:"double_attestation_denounced" - ~msg:"double attestation evidence injected: {hash}" - ("hash", Operation_hash.encoding) - ~pp2:pp_ignore - ("bytes", Data_encoding.bytes) - - let double_preattestation_detected = - declare_2 - ~alternative_color:Internal_event.Magenta - ~section - ~level - ~name:"double_preattestation_detected" - ~msg:"double preattestation detected" - ("existing_preattestation", Operation_hash.encoding) - ("new_preattestation", Operation_hash.encoding) - - let double_preattestation_denounced = - declare_2 - ~alternative_color:Internal_event.Blue - ~section - ~level - ~name:"double_preattestation_denounced" - ~msg:"double preattestation evidence injected: {hash}" - ("hash", Operation_hash.encoding) - ~pp2:pp_ignore - ("bytes", Data_encoding.bytes) - - let double_consensus_already_denounced = - declare_1 - ~section - ~level:Debug - ~name:"double_consensus_already_denounced" - ~msg:"double consensus operation already denounced in {hash}" - ("hash", Operation_hash.encoding) - - let consensus_operation_too_old = - declare_1 - ~section - ~level:Debug - ~name:"consensus_operation_too_old" - ~msg:"operation {hash} is too old to be handled" - ("hash", Operation_hash.encoding) - - let consensus_operation_too_far_in_future = - declare_1 - ~section - ~level:Debug - ~name:"consensus_operation_too_far_in_future" - ~msg:"operation {hash} too far in the future" - ("hash", Operation_hash.encoding) - - let inconsistent_attestation = - declare_1 - ~section - ~level:Error - ~name:"inconsistent_attestation" - ~msg:"inconsistent attestation found {hash}" - ("hash", Operation_hash.encoding) - - let unexpected_pruned_block = - declare_1 - ~section - ~level:Error - ~name:"unexpected_pruned_block" - ~msg:"unexpected pruned block: {hash}" - ("hash", Block_hash.encoding) - - let double_baking_but_not = - declare_0 - ~section - ~level:Debug - ~name:"double_baking_but_not" - ~msg:"double baking detected but block hashes are equivalent; skipping" - () - - let double_baking_detected = - declare_0 - ~alternative_color:Internal_event.Magenta - ~section - ~level - ~name:"double_baking_detected" - ~msg:"double baking detected" - () - - let double_baking_denounced = - declare_2 - ~alternative_color:Internal_event.Blue - ~section - ~level - ~name:"double_baking_denounced" - ~msg:"double baking evidence injected {hash}" - ("hash", Operation_hash.encoding) - ~pp2:pp_ignore - ("bytes", Data_encoding.bytes) - - let protocol_change_detected = - declare_0 - ~section - ~level:Error - ~name:"protocol_change_detected" - ~msg:"protocol changing detected; skipping the block" - () - - let accuser_saw_block = - declare_2 - ~section - ~level:Debug - ~name:"accuser_saw_block" - ~msg:"block level: {level}" - ("level", Alpha_context.Raw_level.encoding) - ("hash", Block_hash.encoding) - - let fetch_operations_error = - declare_1 - ~section - ~level:Error - ~name:"fetch_operations_error" - ~msg:"error while fetching operations of block {hash}" - ("hash", Block_hash.encoding) - ~pp1:Block_hash.pp - - let accuser_processed_block = - declare_1 - ~section - ~level - ~name:"accuser_processed_block" - ~msg:"block {hash} registered" - ("hash", Block_hash.encoding) - - let accuser_block_error = - declare_2 - ~section - ~level:Error - ~name:"accuser_block_error" - ~msg:"error while processing block {hash} {errors}" - ~pp2:pp_print_top_error_of_trace - ("hash", Block_hash.encoding) - ("errors", Error_monad.(TzTrace.encoding error_encoding)) -end - -module Baking_scheduling = struct - include Internal_event.Simple - - let section = [Protocol.name; "delegate"; "baking-scheduling"] - - let cannot_fetch_event = - declare_1 - ~section - ~level:Info - ~name:"cannot_fetch_event" - ~msg:"{worker}: can't fetch the current event; waiting for new event" - ("worker", Data_encoding.string) - - let daemon_error = - declare_2 - ~section - ~level:Error - ~name:"daemon_error" - ~msg:"{worker}: error while baking: {errors}" - ~pp2:pp_print_top_error_of_trace - ("worker", Data_encoding.string) - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - - let daemon_setup = - declare_1 - ~section - ~level:Info - ~name:"daemon_setup" - ~msg:"setting up before the {worker} can start" - ("worker", Data_encoding.string) - - let daemon_connection_lost = - declare_1 - ~section - ~level:Error - ~name:"daemon_connection_lost" - ~msg:"connection to node lost, {worker} exiting" - ("worker", Data_encoding.string) - - let daemon_wakeup = - declare_1 - ~section - ~level:Debug - ~name:"daemon_wakeup" - ~msg:"waking up for {worker}" - ("worker", Data_encoding.string) - - let daemon_start = - declare_1 - ~section - ~level:Info - ~name:"daemon_start" - ~msg:"starting {worker} daemon" - ("worker", Data_encoding.string) -end diff --git a/src/proto_020_PsParisC/lib_delegate/dune b/src/proto_020_PsParisC/lib_delegate/dune deleted file mode 100644 index b00b7088d3cd..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/dune +++ /dev/null @@ -1,111 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tezos_baking_020_PsParisC) - (public_name octez-protocol-020-PsParisC-libs.baking) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - octez-libs.clic - octez-version.value - tezos-protocol-020-PsParisC.protocol - tezos-protocol-020-PsParisC.protocol.lifted - octez-protocol-020-PsParisC-libs.plugin - octez-proto-libs.protocol-environment - octez-shell-libs.shell-services - octez-node-config - octez-shell-libs.client-base - octez-protocol-020-PsParisC-libs.client - octez-shell-libs.client-commands - octez-libs.stdlib - octez-libs.stdlib-unix - octez-libs.rpc-http-client-unix - octez-libs.rpc-http-client - octez-shell-libs.context-ops - octez-libs.rpc - octez-libs.rpc-http - octez-libs.crypto-dal - tezos-dal-node-services - lwt-canceler - lwt-exit - uri) - (preprocess (pps octez-libs.ppx_profiler)) - (preprocessor_deps (env_var TEZOS_PPX_PROFILER)) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_protocol_020_PsParisC - -open Tezos_protocol_020_PsParisC_lifted - -open Tezos_protocol_plugin_020_PsParisC - -open Tezos_shell_services - -open Tezos_client_base - -open Tezos_client_020_PsParisC - -open Tezos_client_commands - -open Tezos_stdlib - -open Tezos_stdlib_unix - -open Tezos_rpc_http_client - -open Tezos_context_ops - -open Tezos_rpc_http - -open Tezos_crypto_dal) - (modules (:standard \ Baking_commands Baking_commands_registration))) - -(library - (name tezos_baking_020_PsParisC_commands) - (public_name octez-protocol-020-PsParisC-libs.baking-commands) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - tezos-protocol-020-PsParisC.protocol - tezos-protocol-020-PsParisC.parameters - octez-libs.stdlib-unix - octez-proto-libs.protocol-environment - octez-shell-libs.shell-services - octez-shell-libs.client-base - octez-protocol-020-PsParisC-libs.client - octez-shell-libs.client-commands - octez-protocol-020-PsParisC-libs.baking - octez-libs.rpc - uri) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_protocol_020_PsParisC - -open Tezos_protocol_020_PsParisC_parameters - -open Tezos_stdlib_unix - -open Tezos_shell_services - -open Tezos_client_base - -open Tezos_client_020_PsParisC - -open Tezos_client_commands - -open Tezos_baking_020_PsParisC) - (modules Baking_commands)) - -(library - (name tezos_baking_020_PsParisC_commands_registration) - (public_name octez-protocol-020-PsParisC-libs.baking-commands.registration) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - tezos-protocol-020-PsParisC.protocol - octez-proto-libs.protocol-environment - octez-shell-libs.shell-services - octez-shell-libs.client-base - octez-protocol-020-PsParisC-libs.client - octez-shell-libs.client-commands - octez-protocol-020-PsParisC-libs.baking - octez-protocol-020-PsParisC-libs.baking-commands - octez-libs.rpc) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_protocol_020_PsParisC - -open Tezos_shell_services - -open Tezos_client_base - -open Tezos_client_020_PsParisC - -open Tezos_client_commands - -open Tezos_baking_020_PsParisC - -open Tezos_baking_020_PsParisC_commands) - (modules Baking_commands_registration)) diff --git a/src/proto_020_PsParisC/lib_delegate/forge_worker.ml b/src/proto_020_PsParisC/lib_delegate/forge_worker.ml deleted file mode 100644 index 1fbdcedfb477..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/forge_worker.ml +++ /dev/null @@ -1,238 +0,0 @@ -(*****************************************************************************) -(* *) -(* SPDX-License-Identifier: MIT *) -(* Copyright (c) 2024 Nomadic Labs, *) -(* *) -(*****************************************************************************) - -open Baking_state -open Protocol -open Alpha_context - -module Events = struct - include Baking_events.Forge_worker - include Baking_events.Actions -end - -module Delegate_signing_queue = struct - type t = { - delegate : consensus_key_and_delegate; - task_stream : (unit -> unit Lwt.t) Lwt_stream.t; - push : (unit -> unit Lwt.t) option -> unit; - worker : unit Lwt.t; - } - - let start_delegate_worker_queue task_stream = - let open Lwt_syntax in - let rec loop () = - let* task = Lwt_stream.get task_stream in - match task with - | None -> (* End of stream *) return_unit - | Some task -> - let* () = task () in - loop () - in - loop () - - let create delegate = - let task_stream, push = Lwt_stream.create () in - let worker = start_delegate_worker_queue task_stream in - {delegate; task_stream; push; worker} - - let cancel_pending_tasks state = Lwt_stream.junk_old state.task_stream - - let wait_all_tasks_and_close state = - state.push None ; - state.worker - - let cancel_all_tasks_and_close state = - let open Lwt_syntax in - let* () = cancel_pending_tasks state in - wait_all_tasks_and_close state - - let push_task ~(on_error : tztrace -> unit Lwt.t) - (f : unit -> unit tzresult Lwt.t) state = - let open Lwt_result_syntax in - let task () = - let*! r = - protect - ~on_error:(fun trace -> - let*! () = on_error trace in - return_unit) - (fun () -> f ()) - in - match r with Error _err -> assert false | Ok () -> Lwt.return_unit - in - state.push (Some task) -end - -type worker = { - push_task : forge_request option -> unit; - push_event : forge_event option -> unit; - event_stream : forge_event Lwt_stream.t; - delegate_signing_queues : - Delegate_signing_queue.t Signature.Public_key_hash.Table.t; -} - -type t = worker - -let push_request state request = state.push_task (Some request) - -let get_event_stream state = state.event_stream - -let cancel_all_pending_tasks {delegate_signing_queues; _} = - Lwt.dont_wait - (fun () -> - Signature.Public_key_hash.Table.iter_p - (fun _ queue -> Delegate_signing_queue.cancel_pending_tasks queue) - delegate_signing_queues) - (fun _exn -> ()) - -let shutdown state = - let open Lwt_syntax in - let* () = - Signature.Public_key_hash.Table.iter_p - (fun _ queue -> Delegate_signing_queue.cancel_all_tasks_and_close queue) - state.delegate_signing_queues - in - state.push_task None ; - return_unit - -let get_or_create_queue worker delegate = - match - Signature.Public_key_hash.Table.find_opt - worker.delegate_signing_queues - (fst delegate).public_key_hash - with - | None -> - let queue = Delegate_signing_queue.create delegate in - Signature.Public_key_hash.Table.add - worker.delegate_signing_queues - (fst delegate).public_key_hash - queue ; - queue - | Some queue -> queue - -let handle_forge_block worker baking_state (block_to_bake : block_to_bake) = - let open Lwt_result_syntax in - let task () = - let* prepared_block = - Baking_actions.prepare_block baking_state block_to_bake - in - worker.push_event (Some (Block_ready prepared_block)) ; - return_unit - in - let queue = get_or_create_queue worker block_to_bake.delegate in - Delegate_signing_queue.push_task - ~on_error:(fun err -> - let*! () = - Events.(emit failed_to_forge_block (block_to_bake.delegate, err)) - in - Lwt.return_unit) - task - queue - -let handle_forge_consensus_votes worker baking_state - (unsigned_consensus_votes : unsigned_consensus_vote_batch) = - let open Lwt_result_syntax in - let batch_branch = unsigned_consensus_votes.batch_branch in - let task - ({vote_consensus_content; vote_kind; delegate; dal_content = _} as - unsigned_consensus_vote) = - let*! signed_consensus_vote_r = - Baking_actions.forge_and_sign_consensus_vote - baking_state - ~branch:batch_branch - unsigned_consensus_vote - in - match signed_consensus_vote_r with - | Error err -> - let level, round = - ( Raw_level.to_int32 vote_consensus_content.level, - vote_consensus_content.round ) - in - let*! () = - Events.( - emit skipping_consensus_vote (vote_kind, delegate, level, round, err)) - in - fail err - | Ok signed_consensus_vote -> ( - match vote_kind with - | Preattestation -> - worker.push_event - (Some (Preattestation_ready signed_consensus_vote)) ; - return_unit - | Attestation -> - worker.push_event (Some (Attestation_ready signed_consensus_vote)) ; - return_unit) - in - let* (authorized_consensus_votes : unsigned_consensus_vote list) = - protect - ~on_error:(fun err -> - let*! () = Events.(emit error_while_authorizing_consensus_votes err) in - return_nil) - (fun () -> - Baking_actions.authorized_consensus_votes - baking_state - unsigned_consensus_votes) - in - List.iter - (fun unsigned_preattestation -> - let queue = get_or_create_queue worker unsigned_preattestation.delegate in - Delegate_signing_queue.push_task - ~on_error:(fun _err -> Lwt.return_unit) - (fun () -> task unsigned_preattestation) - queue) - authorized_consensus_votes ; - return_unit - -let start (baking_state : Baking_state.global_state) = - let open Lwt_result_syntax in - let task_stream, push_task = Lwt_stream.create () in - let event_stream, push_event = Lwt_stream.create () in - let delegate_signing_queues = Signature.Public_key_hash.Table.create 13 in - let state : worker = - {push_task; push_event; event_stream; delegate_signing_queues} - in - let rec worker_loop () = - let*! (forge_request_opt : forge_request option) = - Lwt_stream.get task_stream - in - let process_request = function - | Forge_and_sign_block block_to_bake -> - handle_forge_block state baking_state block_to_bake ; - return_unit - | Forge_and_sign_preattestations {unsigned_preattestations} -> - handle_forge_consensus_votes - state - baking_state - unsigned_preattestations - | Forge_and_sign_attestations {unsigned_attestations} -> - handle_forge_consensus_votes state baking_state unsigned_attestations - in - match forge_request_opt with - | None -> (* Shutdown called *) return_unit - | Some request -> - let*! result = process_request request in - let*! () = - match result with - | Ok () -> Lwt.return_unit - | Error errs -> - let*! () = - Events.(emit error_while_processing_forge_request errs) - in - Lwt.return_unit - in - worker_loop () - in - Lwt.dont_wait - (fun () -> - Lwt.finalize - (fun () -> - let*! _r = worker_loop () in - Lwt.return_unit) - (fun () -> - let () = Lwt.dont_wait (fun () -> shutdown state) (fun _exn -> ()) in - Lwt.return_unit)) - (fun _exn -> ()) ; - state diff --git a/src/proto_020_PsParisC/lib_delegate/forge_worker.mli b/src/proto_020_PsParisC/lib_delegate/forge_worker.mli deleted file mode 100644 index 61f417587718..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/forge_worker.mli +++ /dev/null @@ -1,71 +0,0 @@ -(*****************************************************************************) -(* *) -(* SPDX-License-Identifier: MIT *) -(* Copyright (c) 2024 Nomadic Labs, *) -(* *) -(*****************************************************************************) - -(** Concurrent worker for consensus operations and block forging *) - -(** - {2 Description} - - This component allows the concurrent production of consensus - operations and blocks. It's meant to be used by pushing specific - requests as tasks and waiting for their completions on a dedicated - event stream. - - Block forging implies the retrieval of current operations and context - validation (and application if needed) and then producing a - signature. For consensus operations, the heavy work is mostly on - producing a signature. Signatures are expected to be concurrent in - order not to block the main execution thread. - - {2 Concurrency} - - Each task is associated to a delegate. This worker is designed to - work concurrently on each delegate's tasks. However, if a request - is pushed for a delegate while an existing one is active, this new - request will be enqueued and only be executed after the completion - of the first one. Hence, only one request may be active per - delegate at any time. - - {2 Cancellation} - - It is possible to cancel all pending tasks but it is not possible - to cancel each delegate's active tasks. This is explained by the - fact that we do not have control over the different signers scheme - and, in particular, some are not cancellable at all (e.g., - ledger). -*) - -open Baking_state - -(** Worker type *) -type worker - -type t = worker - -(** [push_request worker request] pushes the [request] to the worker - to be treated. Each [forge_request] is associated to a specific - delegate. The request will be treated whenever the delegate's - associated queue is available. If, the delegate's queue did not - previously exist, it will be created. *) -val push_request : worker -> forge_request -> unit - -(** [get_event_stream worker] returns the worker's stream of events - onto which tasks completion results are pushed. *) -val get_event_stream : worker -> forge_event Lwt_stream.t - -(** [cancel_all_pending_tasks worker] cancels all the worker's - delegate queues pending tasks. *) -val cancel_all_pending_tasks : worker -> unit - -(** [shutdown worker] triggers the [worker] shutdown. This function - cancels all pending tasks but still waits for each active one to - complete. *) -val shutdown : worker -> unit Lwt.t - -(** [start global_state] creates and runs a worker based on a baker's - [global_state]. *) -val start : global_state -> worker diff --git a/src/proto_020_PsParisC/lib_delegate/node_rpc.ml b/src/proto_020_PsParisC/lib_delegate/node_rpc.ml deleted file mode 100644 index bd06cfd7be8f..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/node_rpc.ml +++ /dev/null @@ -1,414 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol -open Alpha_context -open Baking_cache -open Baking_state -module Block_services = Block_services.Make (Protocol) (Protocol) -module Events = Baking_events.Node_rpc - -module Profiler = struct - include (val Profiler.wrap Baking_profiler.node_rpc_profiler) - - let[@warning "-32"] reset_block_section = - Baking_profiler.create_reset_block_section Baking_profiler.node_rpc_profiler -end - -module RPC_profiler = struct - include (val Tezos_base.Profiler.wrap RPC_profiler.rpc_client_profiler) - - let[@warning "-32"] reset_block_section = - RPC_profiler.create_reset_block_section RPC_profiler.rpc_client_profiler -end - -let inject_block cctxt ?(force = false) ~chain signed_block_header operations = - let signed_shell_header_bytes = - Data_encoding.Binary.to_bytes_exn Block_header.encoding signed_block_header - in - Shell_services.Injection.block - ~async:true - cctxt - ~chain - ~force - signed_shell_header_bytes - operations - -let inject_operation cctxt ~chain operation = - let encoded_op = - Data_encoding.Binary.to_bytes_exn Operation.encoding operation - in - Shell_services.Injection.operation cctxt ~async:true ~chain encoded_op - -let preapply_block cctxt ~chain ~head ~timestamp ~protocol_data operations = - Block_services.Helpers.Preapply.block - cctxt - ~chain - ~timestamp - ~block:(`Hash (head, 0)) - operations - ~protocol_data - -let extract_prequorum preattestations = - match preattestations with - | h :: _ -> - let {protocol_data = {contents = Single (Preattestation content); _}; _} = - (h : Kind.preattestation Operation.t) - in - Some - { - level = Raw_level.to_int32 content.level; - round = content.round; - block_payload_hash = content.block_payload_hash; - preattestations; - } - | _ -> None - -let info_of_header_and_ops ~in_protocol block_hash block_header operations = - let open Result_syntax in - let shell = block_header.Tezos_base.Block_header.shell in - let dummy_payload_hash = Block_payload_hash.zero in - let* round = - Environment.wrap_tzresult @@ Fitness.round_from_raw shell.fitness - in - let payload_hash, payload_round, prequorum, quorum, payload = - if not in_protocol then - (* The first block in the protocol is baked using the previous - protocol, the encodings might change. The baker's logic is to - consider final the first block of a new protocol and not - attest it. Therefore, we do not need to have the correct - values here. *) - (dummy_payload_hash, Round.zero, None, [], Operation_pool.empty_payload) - else - let payload_hash, payload_round = - match - Data_encoding.Binary.of_bytes_opt - Protocol.block_header_data_encoding - block_header.protocol_data - with - | Some {contents = {payload_hash; payload_round; _}; _} -> - (payload_hash, payload_round) - | None -> assert false - in - let preattestations, quorum, payload = - (WithExceptions.Option.get - ~loc:__LOC__ - (Operation_pool.extract_operations_of_list_list operations) - [@profiler.record_f {verbosity = Debug} "operations classification"]) - in - let prequorum = Option.bind preattestations extract_prequorum in - (payload_hash, payload_round, prequorum, quorum, payload) - in - return - { - hash = block_hash; - shell; - payload_hash; - payload_round; - round; - prequorum; - quorum; - payload; - } - -let compute_block_info cctxt ~in_protocol ?operations ~chain block_hash - block_header = - let open Lwt_result_syntax in - (let* operations = - match operations with - | None when not in_protocol -> return_nil - | None -> - let open Protocol_client_context in - (let* operations = - Alpha_block_services.Operations.operations - cctxt - ~chain - ~block:(`Hash (block_hash, 0)) - () - in - let packed_operations = - List.map - (fun l -> - List.map - (fun {Alpha_block_services.shell; protocol_data; _} -> - {Alpha_context.shell; protocol_data}) - l) - operations - in - return packed_operations) - [@profiler.record_s - {verbosity = Debug} - ("retrieve block " - ^ Block_hash.to_short_b58check block_hash - ^ " operations")] - | Some operations -> - let parse_op (raw_op : Tezos_base.Operation.t) = - let protocol_data = - (Data_encoding.Binary.of_bytes_exn - Operation.protocol_data_encoding - raw_op.proto - [@profiler.aggregate_f {verbosity = Debug} "parse operation"]) - in - {shell = raw_op.shell; protocol_data} - in - protect @@ fun () -> - return - (List.mapi - (fun [@warning "-27"] i -> function - | [] -> [] - | l -> - List.map - parse_op - l - [@profiler.record_f - {verbosity = Debug} - (Printf.sprintf "parse operations (pass : %d)" i)]) - operations) - in - let*? block_info = - info_of_header_and_ops ~in_protocol block_hash block_header operations - in - return block_info) - [@profiler.record_s - {verbosity = Info} - ("compute block " ^ Block_hash.to_short_b58check block_hash ^ " info")] - -let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain - block_hash (block_header : Tezos_base.Block_header.t) = - let open Lwt_result_syntax in - let predecessor_hash = block_header.shell.predecessor in - let pred_block = `Hash (predecessor_hash, 0) in - let predecessor_opt = - Option.bind cache (fun cache -> Block_cache.find_opt cache predecessor_hash) - in - let* is_proposal_in_protocol, predecessor = - match predecessor_opt with - | Some predecessor -> - () - [@profiler.mark - {verbosity = Info} - [ - "pred_block(" - ^ Block_hash.to_short_b58check predecessor_hash - ^ ") : cache_hit"; - ]] ; - return - ( predecessor.shell.proto_level = block_header.shell.proto_level, - predecessor ) - | None -> - () - [@profiler.mark - {verbosity = Info} - [ - "pred_block(" - ^ Block_hash.to_short_b58check predecessor_hash - ^ ") : cache_miss"; - ]] ; - let* { - current_protocol = pred_current_protocol; - next_protocol = pred_next_protocol; - } = - (Shell_services.Blocks.protocols - cctxt - ~chain - ~block:pred_block - () - [@profiler.record_s {verbosity = Info} "pred block protocol RPC"]) - in - let is_proposal_in_protocol = - Protocol_hash.(pred_next_protocol = Protocol.hash) - in - let* predecessor = - let in_protocol = - Protocol_hash.(pred_current_protocol = Protocol.hash) - in - let* raw_header_b = - Shell_services.Blocks.raw_header cctxt ~chain ~block:pred_block () - in - let predecessor_header = - (Data_encoding.Binary.of_bytes_exn - Tezos_base.Block_header.encoding - raw_header_b - [@profiler.record_f {verbosity = Info} "parse pred block header"]) - in - compute_block_info - cctxt - ~in_protocol - ~chain - predecessor_hash - predecessor_header - in - Option.iter - (fun cache -> Block_cache.replace cache predecessor_hash predecessor) - cache ; - return (is_proposal_in_protocol, predecessor) - in - let block_opt = - Option.bind cache (fun cache -> Block_cache.find_opt cache block_hash) - in - let* block = - match block_opt with - | Some pi -> - () - [@profiler.mark - {verbosity = Info} - [ - "new_block(" - ^ Block_hash.to_short_b58check pi.hash - ^ ") : cache_hit"; - ]] ; - return pi - | None -> - () - [@profiler.mark - {verbosity = Info} - [ - "new_block(" - ^ Block_hash.to_short_b58check block_hash - ^ ") : cache_miss"; - ]] ; - let* pi = - compute_block_info - cctxt - ~in_protocol:is_proposal_in_protocol - ?operations - ~chain - block_hash - block_header - in - Option.iter (fun cache -> Block_cache.replace cache block_hash pi) cache ; - return pi - in - return {block; predecessor} - -let proposal cctxt ?cache ?operations ~chain block_hash block_header = - ( (protect @@ fun () -> - proposal cctxt ?cache ?operations ~chain block_hash block_header) - [@profiler.record_s {verbosity = Notice} "proposal_computation"] ) - -let monitor_valid_proposals cctxt ~chain ?cache () = - let open Lwt_result_syntax in - let next_protocols = [Protocol.hash] in - let* block_stream, stopper = - Monitor_services.validated_blocks cctxt ~chains:[chain] ~next_protocols () - in - let stream = - let map (_chain_id, block_hash, block_header, operations) = - () [@profiler.reset_block_section {profiler_module = Profiler} block_hash] ; - () - [@profiler.reset_block_section - {profiler_module = RPC_profiler} block_hash] ; - (let*! map_result = - proposal cctxt ?cache ~operations ~chain block_hash block_header - in - match map_result with - | Ok proposal -> Lwt.return_some proposal - | Error err -> - let*! () = - Events.(emit error_while_monitoring_valid_proposals err) - in - Lwt.return_none) - [@profiler.record_s {verbosity = Notice} "received valid proposal"] - in - Lwt_stream.filter_map_s map block_stream - in - return (stream, stopper) - -let monitor_heads cctxt ~chain ?cache () = - let open Lwt_result_syntax in - let next_protocols = [Protocol.hash] in - let* block_stream, stopper = - Monitor_services.heads cctxt ~next_protocols chain - in - let stream = - let map (block_hash, block_header) = - () [@profiler.reset_block_section block_hash] ; - (let*! map_result = - proposal cctxt ?cache ~chain block_hash block_header - in - match map_result with - | Ok proposal -> Lwt.return_some proposal - | Error err -> - let*! () = Events.(emit error_while_monitoring_heads err) in - Lwt.return_none) - [@profiler.record_s {verbosity = Notice} "received new head"] - in - Lwt_stream.filter_map_s map block_stream - in - return (stream, stopper) - -let await_protocol_activation cctxt ~chain () = - let open Lwt_result_syntax in - let* block_stream, stop = - Monitor_services.heads cctxt ~next_protocols:[Protocol.hash] chain - in - let*! _ = Lwt_stream.get block_stream in - stop () ; - return_unit - -let fetch_dal_config cctxt = - let open Lwt_syntax in - let* r = Config_services.dal_config cctxt in - match r with - | Error e -> return_error e - | Ok dal_config -> return_ok dal_config - -let get_attestable_slots dal_node_rpc_ctxt pkh ~attested_level = - Tezos_rpc.Context.make_call - Tezos_dal_node_services.Services.get_attestable_slots - dal_node_rpc_ctxt - (((), pkh), attested_level) - () - () - -let dal_attestable_slots (dal_node_rpc_ctxt : Tezos_rpc.Context.generic) - ~attestation_level delegate_slots = - let attested_level = Int32.succ attestation_level in - List.map - (fun delegate_slot -> - let pkh = snd delegate_slot.consensus_key_and_delegate in - (pkh, get_attestable_slots dal_node_rpc_ctxt pkh ~attested_level)) - delegate_slots - -let register_dal_profiles dal_node_rpc_ctxt delegates = - let profiles = - Tezos_dal_node_services.Operator_profile.make - ~attesters:(List.map (fun k -> k.public_key_hash) delegates) - () - in - Tezos_rpc.Context.make_call - Tezos_dal_node_services.Services.patch_profiles - dal_node_rpc_ctxt - () - () - profiles - -let get_dal_health dal_node_rpc_ctxt = - Tezos_rpc.Context.make_call - Tezos_dal_node_services.Services.health - dal_node_rpc_ctxt - () - () - () diff --git a/src/proto_020_PsParisC/lib_delegate/node_rpc.mli b/src/proto_020_PsParisC/lib_delegate/node_rpc.mli deleted file mode 100644 index 2998ac346c30..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/node_rpc.mli +++ /dev/null @@ -1,110 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Protocol -open Alpha_context - -(** Inject a block. - - @param force defaults to [false] - @return block hash of the newly injected block -*) -val inject_block : - #Protocol_client_context.full -> - ?force:bool -> - chain:Shell_services.chain -> - Block_header.t -> - Tezos_base.Operation.t list list -> - Block_hash.t tzresult Lwt.t - -(** Inject an operation. - - @return operation hash of the newly injected operation -*) -val inject_operation : - #Protocol_client_context.full -> - chain:Shell_services.chain -> - packed_operation -> - Operation_hash.t tzresult Lwt.t - -(** Preapply a block using the node validation mechanism.*) -val preapply_block : - #Protocol_client_context.full -> - chain:Shell_services.chain -> - head:Block_hash.t -> - timestamp:Time.Protocol.t -> - protocol_data:Protocol.block_header_data -> - packed_operation list list -> - (Tezos_base.Block_header.shell_header * error Preapply_result.t list) tzresult - Lwt.t - -(** Monitor validated blocks/proposals from the node. *) -val monitor_valid_proposals : - #Protocol_client_context.rpc_context -> - chain:Shell_services.chain -> - ?cache:Baking_state.block_info Baking_cache.Block_cache.t -> - unit -> - (Baking_state.proposal Lwt_stream.t * (unit -> unit)) tzresult Lwt.t - -(** Monitor heads from the node. *) -val monitor_heads : - #Protocol_client_context.rpc_context -> - chain:Shell_services.chain -> - ?cache:Baking_state.block_info Baking_cache.Block_cache.t -> - unit -> - (Baking_state.proposal Lwt_stream.t * (unit -> unit)) tzresult Lwt.t - -(** Await the current protocol to be activated. *) -val await_protocol_activation : - #Protocol_client_context.rpc_context -> - chain:Shell_services.chain -> - unit -> - unit tzresult Lwt.t - -val fetch_dal_config : - #Protocol_client_context.rpc_context -> Cryptobox.Config.t tzresult Lwt.t - -(** [dal_attestable_slots ctxt ~attestation_level delegates_slots] calls the DAL - node RPC GET /profiles//attested_levels//attestable_slots/ - for each of the delegates in [delegate_slots] and returns the corresponding - promises. *) -val dal_attestable_slots : - Tezos_rpc.Context.generic -> - attestation_level:int32 -> - Baking_state.delegate_slot list -> - Baking_state.dal_attestable_slots - -(** [register_dal_profiles ctxt delegates] calls the DAL node RPC PATCH - /profiles/ to register each profile corresponding to a delegate in - [delegates]. *) -val register_dal_profiles : - Tezos_rpc.Context.generic -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t - -(** [get_dal_health ctxt] calls the DAL node RPC 'GET /health' *) -val get_dal_health : - Tezos_rpc.Context.generic -> - Tezos_dal_node_services.Types.Health.t tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/operation_pool.ml b/src/proto_020_PsParisC/lib_delegate/operation_pool.ml deleted file mode 100644 index 8049254510a6..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/operation_pool.ml +++ /dev/null @@ -1,402 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context - -(* Should we use a better ordering ? *) - -type 'collection t = { - consensus : 'collection; - votes : 'collection; - anonymous : 'collection; - managers : 'collection; -} - -let compare_op op1 op2 = - try Stdlib.compare op1 op2 - with _ -> - (* FIXME some operations (e.g. tx_rollup_rejection) pack - functional values which could raise an exception. In this - specific case, we default to comparing their hashes. *) - Operation_hash.compare - (Alpha_context.Operation.hash_packed op1) - (Alpha_context.Operation.hash_packed op2) - -module Prioritized_operation = struct - (* Higher priority operations will be included first *) - type t = Prioritized of int * packed_operation | Low of packed_operation - - let extern ?(priority = 1) op = Prioritized (priority, op) - - let node op = Low op - - let packed = function Prioritized (_, op) | Low op -> op - - let compare_priority t1 t2 = - match (t1, t2) with - | Prioritized _, Low _ -> 1 - | Low _, Prioritized _ -> -1 - | Low _, Low _ -> 0 - | Prioritized (p0, _), Prioritized (p1, _) -> Compare.Int.compare p0 p1 - - let compare a b = - let c = compare_priority a b in - if c <> 0 then c else compare_op (packed a) (packed b) -end - -module Operation_set = Set.Make (struct - type t = packed_operation - - let compare = compare_op -end) - -module Prioritized_operation_set = struct - include Set.Make (struct - type t = Prioritized_operation.t - - let compare = Prioritized_operation.compare - end) - - let operations set = elements set |> List.map Prioritized_operation.packed -end - -(* TODO refine this: unpack operations *) -type pool = Operation_set.t t - -(* TODO refine this: unpack operations *) -type ordered_pool = packed_operation list t - -let ordered_pool_encoding = - let open Data_encoding in - conv - (fun {consensus; votes; anonymous; managers} -> - (consensus, votes, anonymous, managers)) - (fun (consensus, votes, anonymous, managers) -> - {consensus; votes; anonymous; managers}) - (obj4 - (req "ordered_consensus" (list (dynamic_size Operation.encoding))) - (req "ordered_votes" (list (dynamic_size Operation.encoding))) - (req "ordered_anonymouns" (list (dynamic_size Operation.encoding))) - (req "ordered_managers" (list (dynamic_size Operation.encoding)))) - -type payload = { - votes_payload : packed_operation list; - anonymous_payload : packed_operation list; - managers_payload : packed_operation list; -} - -let empty_payload = - {votes_payload = []; anonymous_payload = []; managers_payload = []} - -let payload_encoding = - let open Data_encoding in - conv - (fun {votes_payload; anonymous_payload; managers_payload} -> - (votes_payload, anonymous_payload, managers_payload)) - (fun (votes_payload, anonymous_payload, managers_payload) -> - {votes_payload; anonymous_payload; managers_payload}) - (obj3 - (req "votes_payload" (list (dynamic_size Operation.encoding))) - (req "anonymous_payload" (list (dynamic_size Operation.encoding))) - (req "managers_payload" (list (dynamic_size Operation.encoding)))) - -let pp_payload fmt {votes_payload; anonymous_payload; managers_payload} = - Format.fprintf - fmt - "[votes: %d, anonymous: %d, managers: %d]" - (List.length votes_payload) - (List.length anonymous_payload) - (List.length managers_payload) - -let empty = - { - consensus = Operation_set.empty; - votes = Operation_set.empty; - anonymous = Operation_set.empty; - managers = Operation_set.empty; - } - -let empty_ordered = {consensus = []; votes = []; anonymous = []; managers = []} - -let pp_pool fmt {consensus; votes; anonymous; managers} = - Format.fprintf - fmt - "[consensus: %d, votes: %d, anonymous: %d, managers: %d]" - (Operation_set.cardinal consensus) - (Operation_set.cardinal votes) - (Operation_set.cardinal anonymous) - (Operation_set.cardinal managers) - -let pp_ordered_pool fmt {consensus; votes; anonymous; managers} = - Format.fprintf - fmt - "[consensus: %d, votes: %d, anonymous: %d, managers: %d]" - (List.length consensus) - (List.length votes) - (List.length anonymous) - (List.length managers) - -let classify op = - (* Hypothesis: acceptable passes on an ill-formed operation returns - None. *) - let pass = Main.acceptable_pass op in - match pass with - | None -> `Bad - | Some pass -> - let open Operation_repr in - if pass = consensus_pass then - `Consensus (* TODO filter outdated consensus ops ? *) - else if pass = voting_pass then `Votes - else if pass = anonymous_pass then `Anonymous - else if pass = manager_pass then `Managers - else `Bad - -let add_operation_to_pool add classify pool operation = - match classify operation with - | `Consensus -> - let consensus = add operation pool.consensus in - {pool with consensus} - | `Votes -> - let votes = add operation pool.votes in - {pool with votes} - | `Anonymous -> - let anonymous = add operation pool.anonymous in - {pool with anonymous} - | `Managers -> - let managers = add operation pool.managers in - {pool with managers} - | `Bad -> pool - -let add_operation = add_operation_to_pool Operation_set.add classify - -let add_operations pool ops = List.fold_left add_operation pool ops - -type consensus_filter = { - level : int32; - round : Round.t; - payload_hash : Block_payload_hash.t; -} - -(** From a pool of operations [operation_pool], the function filters - out the attestations that are different from the [current_level], - the [current_round] or the optional [current_block_payload_hash], - as well as preattestations. *) -let filter_with_relevant_consensus_ops ~(attestation_filter : consensus_filter) - ~(preattestation_filter : consensus_filter option) operation_set = - Operation_set.filter - (fun {protocol_data; _} -> - match (protocol_data, preattestation_filter) with - (* 1a. Remove preattestations. *) - | Operation_data {contents = Single (Preattestation _); _}, None -> false - (* 1b. Filter preattestations. *) - | ( Operation_data - { - contents = - Single (Preattestation {level; round; block_payload_hash; _}); - _; - }, - Some - {level = level'; round = round'; payload_hash = block_payload_hash'} - ) -> - Compare.Int32.(Raw_level.to_int32 level = level') - && Round.(round = round') - && Block_payload_hash.(block_payload_hash = block_payload_hash') - (* 2. Filter attestations. *) - | ( Operation_data - { - contents = - Single - (Attestation - { - consensus_content = {level; round; block_payload_hash; _}; - dal_content = _; - }); - _; - }, - _ ) -> - Compare.Int32.(Raw_level.to_int32 level = attestation_filter.level) - && Round.(round = attestation_filter.round) - && Block_payload_hash.( - block_payload_hash = attestation_filter.payload_hash) - (* 3. Preserve all non-consensus operations. *) - | _ -> true) - operation_set - -let unpack_preattestation packed_preattestation = - let {shell; protocol_data = Operation_data data} = packed_preattestation in - match data with - | {contents = Single (Preattestation _); _} -> - Some ({shell; protocol_data = data} : Kind.preattestation Operation.t) - | _ -> None - -let unpack_attestation packed_attestation = - let {shell; protocol_data = Operation_data data} = packed_attestation in - match data with - | {contents = Single (Attestation _); _} -> - Some ({shell; protocol_data = data} : Kind.attestation Operation.t) - | _ -> None - -let filter_preattestations ops = - List.filter_map - (function - | { - shell = {branch}; - protocol_data = - Operation_data - ({contents = Single (Preattestation _); _} as content); - _; - } -> - Some - ({shell = {branch}; protocol_data = content} - : Kind.preattestation operation) - | _ -> None) - ops - -let filter_attestations ops = - List.filter_map - (function - | { - shell = {branch}; - protocol_data = - Operation_data ({contents = Single (Attestation _); _} as content); - _; - } -> - Some - ({shell = {branch}; protocol_data = content} - : Kind.attestation operation) - | _ -> None) - ops - -let ordered_to_list_list {consensus; votes; anonymous; managers} = - [consensus; votes; anonymous; managers] - -let ordered_of_list_list = function - | [consensus; votes; anonymous; managers] -> - Some {consensus; votes; anonymous; managers} - | _ -> None - -let payload_of_ordered_pool {votes; anonymous; managers; _} = - { - votes_payload = votes; - anonymous_payload = anonymous; - managers_payload = managers; - } - -let ordered_pool_of_payload ~consensus_operations - {votes_payload; anonymous_payload; managers_payload} = - { - consensus = consensus_operations; - votes = votes_payload; - anonymous = anonymous_payload; - managers = managers_payload; - } - -let extract_operations_of_list_list = function - | [consensus; votes_payload; anonymous_payload; managers_payload] -> - let preattestations, attestations = - List.fold_left - (fun ( (preattestations : Kind.preattestation Operation.t list), - (attestations : Kind.attestation Operation.t list) ) - packed_op -> - let {shell; protocol_data = Operation_data data} = packed_op in - match data with - | {contents = Single (Preattestation _); _} -> - ({shell; protocol_data = data} :: preattestations, attestations) - | {contents = Single (Attestation _); _} -> - (preattestations, {shell; protocol_data = data} :: attestations) - | _ -> - (* unreachable *) - (preattestations, attestations)) - ([], []) - consensus - (* N.b. the order doesn't matter *) - in - let preattestations = - if preattestations = [] then None else Some preattestations - in - let payload = {votes_payload; anonymous_payload; managers_payload} in - Some (preattestations, attestations, payload) - | _ -> None - -let filter_pool p {consensus; votes; anonymous; managers} = - { - consensus = Operation_set.filter p consensus; - votes = Operation_set.filter p votes; - anonymous = Operation_set.filter p anonymous; - managers = Operation_set.filter p managers; - } - -module Prioritized = struct - type nonrec t = Prioritized_operation_set.t t - - let of_operation_set (operation_set : Operation_set.t) = - Operation_set.fold - (fun elt set -> - Prioritized_operation_set.add (Prioritized_operation.node elt) set) - operation_set - Prioritized_operation_set.empty - - let of_pool (pool : pool) : t = - { - consensus = of_operation_set pool.consensus; - votes = of_operation_set pool.votes; - anonymous = of_operation_set pool.anonymous; - managers = of_operation_set pool.managers; - } - - let add_operation = - add_operation_to_pool Prioritized_operation_set.add (fun op -> - classify (Prioritized_operation.packed op)) - - let add_external_operation pool priority operation = - add_operation pool (Prioritized_operation.extern ~priority operation) - - let add_operations prioritized_pool operations = - List.fold_left add_operation prioritized_pool operations - - (* [merge_external_operations] considers that the list of operation - represents an ordererd list of operation with the head having the highest - prioritiy. - *) - let merge_external_operations pool - (external_operations : packed_operation list) = - List.fold_left_i - (fun i pool op -> add_external_operation pool (-i) op) - pool - external_operations - - let filter p {consensus; votes; anonymous; managers} = - let filter = - Prioritized_operation_set.filter (fun pop -> - p (Prioritized_operation.packed pop)) - in - { - consensus = filter consensus; - votes = filter votes; - anonymous = filter anonymous; - managers = filter managers; - } -end diff --git a/src/proto_020_PsParisC/lib_delegate/operation_pool.mli b/src/proto_020_PsParisC/lib_delegate/operation_pool.mli deleted file mode 100644 index a7159f557254..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/operation_pool.mli +++ /dev/null @@ -1,168 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context - -module Operation_set : Set.S with type elt = packed_operation - -(** Generic base type for pools *) -type 'collection t = { - consensus : 'collection; - votes : 'collection; - anonymous : 'collection; - managers : 'collection; -} - -(** A pool of operations for a single origin, or undifferenciated origin, - typically used for operations coming from the node *) -type pool = Operation_set.t t - -(** A pool of operations for a single origin, or undifferenciated origin, - typically used for operations coming from the node *) - -(** on pool *) -val empty : pool - -val pp_pool : Format.formatter -> pool -> unit - -val filter_pool : (packed_operation -> bool) -> pool -> pool - -val add_operation : pool -> packed_operation -> pool - -val add_operations : pool -> packed_operation list -> pool - -(** {2 Ordered pool of operations} *) -type ordered_pool = packed_operation list t - -val ordered_pool_encoding : ordered_pool Data_encoding.t - -val empty_ordered : ordered_pool - -val pp_ordered_pool : Format.formatter -> ordered_pool -> unit - -type payload = { - votes_payload : packed_operation list; - anonymous_payload : packed_operation list; - managers_payload : packed_operation list; -} - -val empty_payload : payload - -val payload_encoding : payload Data_encoding.t - -val pp_payload : Format.formatter -> payload -> unit - -val payload_of_ordered_pool : ordered_pool -> payload - -val ordered_pool_of_payload : - consensus_operations:packed_operation list -> payload -> ordered_pool - -type consensus_filter = { - level : int32; - round : Round.t; - payload_hash : Block_payload_hash.t; -} - -val filter_with_relevant_consensus_ops : - attestation_filter:consensus_filter -> - preattestation_filter:consensus_filter option -> - Operation_set.t -> - Operation_set.t - -val unpack_preattestation : - packed_operation -> Kind.preattestation operation option - -val unpack_attestation : packed_operation -> Kind.attestation operation option - -val filter_preattestations : - packed_operation list -> Kind.preattestation operation list - -val filter_attestations : - packed_operation list -> Kind.attestation operation list - -val ordered_to_list_list : ordered_pool -> packed_operation list list - -val ordered_of_list_list : packed_operation list list -> ordered_pool option - -(** [preattestation] <> None => (List.length preattestations > 0) *) -val extract_operations_of_list_list : - packed_operation list list -> - (Kind.preattestation operation list option - * Kind.attestation operation list - * payload) - option - -module Prioritized_operation : sig - type t - - (** prioritize operations coming from an external source (file, uri, ...). - An operation with higher [priority] (aka a bigger integer) will be - included before others with lower [priority]. *) - val extern : ?priority:int -> packed_operation -> t - - (** prioritize operations coming from a node *) - val node : packed_operation -> t - - (** [packed t] retrieves the [packed_operation] wrapped inside [t] *) - val packed : t -> packed_operation - - (** [compare_priority o1 o2] compares whether [o1] has higher priority than [o2] *) - val compare_priority : t -> t -> int - - (** [compare] is [compare_priority] when non-zero. This is suitable to - construct sets of prioritized operations **) - val compare : t -> t -> int -end - -module Prioritized_operation_set : sig - include Set.S with type elt = Prioritized_operation.t - - (** [operations set] is [elements set |> List.map Prioritized_operation.packed]*) - val operations : t -> packed_operation list -end - -(** Pool of prioritized operations *) -module Prioritized : sig - (** Same record fields as [type pool], but with a different set base *) - type nonrec t = Prioritized_operation_set.t t - - (** [of_pool pool] transforms [pool] into a prioritized pool of operations of - low priority. *) - val of_pool : pool -> t - - (** [merge_external_operations ?initial_priority pool extern_ops] creates a prioritized pool - from a [pool] and [extern_ops] coming from an external source, which we - prioritize. - - Priorities for these operations is given according to the order of the - list. The first element of the list has highest priority. - *) - val merge_external_operations : t -> packed_operation list -> t - - val filter : (packed_operation -> bool) -> t -> t - - val add_operations : t -> Prioritized_operation.t list -> t -end diff --git a/src/proto_020_PsParisC/lib_delegate/operation_selection.ml b/src/proto_020_PsParisC/lib_delegate/operation_selection.ml deleted file mode 100644 index 313c727ca0cd..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/operation_selection.ml +++ /dev/null @@ -1,426 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context -open Operation_pool -module Events = Baking_events.Selection - -let quota = Main.validation_passes - -let consensus_quota = Stdlib.List.nth quota Operation_repr.consensus_pass - -let votes_quota = Stdlib.List.nth quota Operation_repr.voting_pass - -let anonymous_quota = Stdlib.List.nth quota Operation_repr.anonymous_pass - -let managers_quota = Stdlib.List.nth quota Operation_repr.manager_pass - -type prioritized_manager = { - op : Prioritized_operation.t; - size : int; - fee : Tez.t; - gas : Fixed_point_repr.integral_tag Gas.Arith.t; - weight : Q.t; - source : public_key_hash; - counter : Manager_counter.t; -} - -module PrioritizedManagerSet = Set.Make (struct - type t = prioritized_manager - - (* We order the operations by their weights except if they belong - to the same manager, if they do, we order them by their - counter. *) - let compare {source; counter; weight; op; _} - {source = source'; counter = counter'; weight = weight'; op = op'; _} = - (* Be careful with the [compare] *) - let cmp_src = Signature.Public_key_hash.compare source source' in - if cmp_src = 0 then - (* we want the smallest counter first *) - let c = Manager_counter.compare counter counter' in - if c <> 0 then c - else - let c = Prioritized_operation.compare_priority op' op in - if c <> 0 then c else Q.compare weight' weight - (* if same counter, biggest weight first *) - else - let c = Prioritized_operation.compare_priority op' op in - if c <> 0 then c - else - (* We want the biggest weight first *) - let c = Q.compare weight' weight in - if c <> 0 then c else cmp_src -end) - -(* Note: This weight is also used by the plugin and the prevalidator to sort - operations in the pending mempool. - See {!Tezos_protocol_plugin_alpha.Plugin.Mempool.weight_manager_operation}. *) -let prioritize_manager ~max_size ~hard_gas_limit_per_block ~minimal_fees - ~minimal_nanotez_per_gas_unit ~minimal_nanotez_per_byte operation = - let open Result_syntax in - let op = Operation_pool.Prioritized_operation.packed operation in - let {protocol_data = Operation_data {contents; _}; _} = op in - let open Operation in - let l = to_list (Contents_list contents) in - List.fold_left_e - (fun ((first_source, first_counter, total_fee, total_gas) as acc) -> - function - | Contents (Manager_operation {source; counter; fee; gas_limit; _}) -> - let* total_fee = - Environment.wrap_tzresult @@ Tez.(total_fee +? fee) - in - (* There is only one unique source per packed transaction *) - let first_source = Option.value ~default:source first_source in - (* We only care about the first counter *) - let first_counter = Option.value ~default:counter first_counter in - return - ( Some first_source, - Some first_counter, - total_fee, - Gas.Arith.add total_gas gas_limit ) - | _ -> return acc) - (None, None, Tez.zero, Gas.Arith.zero) - l - |> function - | Ok (Some source, Some counter, fee, gas) -> - if Tez.(fee < minimal_fees) then None - else - let size = Data_encoding.Binary.length Operation.encoding op in - let size_f = Q.of_int size in - let gas_f = Q.of_bigint (Gas.Arith.integral_to_z gas) in - let fee_f = Q.of_int64 (Tez.to_mutez fee) in - let size_ratio = Q.(size_f / Q.of_int max_size) in - let gas_ratio = - Q.( - gas_f - / Q.of_bigint (Gas.Arith.integral_to_z hard_gas_limit_per_block)) - in - let weight = Q.(fee_f / max size_ratio gas_ratio) in - let fees_in_nanotez = - Q.mul (Q.of_int64 (Tez.to_mutez fee)) (Q.of_int 1000) - in - let enough_fees_for_gas = - let minimal_fees_in_nanotez = - Q.mul - minimal_nanotez_per_gas_unit - (Q.of_bigint @@ Gas.Arith.integral_to_z gas) - in - Q.compare minimal_fees_in_nanotez fees_in_nanotez <= 0 - in - let enough_fees_for_size = - let minimal_fees_in_nanotez = - Q.mul minimal_nanotez_per_byte (Q.of_int size) - in - Q.compare minimal_fees_in_nanotez fees_in_nanotez <= 0 - in - if enough_fees_for_size && enough_fees_for_gas then - Some {op = operation; size; weight; fee; gas; source; counter} - else None - | _ -> None - -let prioritize_managers ~hard_gas_limit_per_block ~minimal_fees - ~minimal_nanotez_per_gas_unit ~minimal_nanotez_per_byte managers = - Prioritized_operation_set.fold - (fun op acc -> - match - prioritize_manager - ~max_size:managers_quota.max_size - ~hard_gas_limit_per_block - ~minimal_fees - ~minimal_nanotez_per_gas_unit - ~minimal_nanotez_per_byte - op - with - | None -> acc - | Some w_op -> PrioritizedManagerSet.add w_op acc) - managers - PrioritizedManagerSet.empty - -(** Simulation *) - -type simulation_result = { - validation_result : Tezos_protocol_environment.validation_result option; - block_header_metadata : block_header_metadata option; - operations : packed_operation list list; - operations_hash : Operation_list_list_hash.t; - manager_operations_infos : Baking_state.manager_operations_infos option; -} - -let validate_operation inc op = - let open Lwt_syntax in - let* result = Baking_simulator.add_operation inc op in - match result with - | Error errs -> - let* () = - Events.(emit invalid_operation_filtered) (Operation.hash_packed op, errs) - in - return_none - | Ok (resulting_state, None) -> - (* No receipt if force_apply is not set *) - return_some resulting_state - | Ok (resulting_state, Some receipt) -> ( - (* Check that the metadata are serializable/deserializable *) - let encoding_result = - let enc = Protocol.operation_receipt_encoding in - Option.bind - (Data_encoding.Binary.to_bytes_opt enc receipt) - (Data_encoding.Binary.of_bytes_opt enc) - in - match encoding_result with - | None -> - let* () = - Events.(emit cannot_serialize_operation_metadata) - (Operation.hash_packed op) - in - return_none - | Some _b -> return_some resulting_state) - -let filter_valid_operations_up_to_quota inc (ops, quota) = - let open Lwt_syntax in - let {Tezos_protocol_environment.max_size; max_op} = quota in - let exception Full of (Baking_simulator.incremental * packed_operation list) - in - try - let* inc, _, _, l = - List.fold_left_s - (fun (inc, curr_size, nb_ops, acc) op -> - let op_size = - Data_encoding.Binary.length Alpha_context.Operation.encoding op - in - let new_size = curr_size + op_size in - if new_size > max_size then return (inc, curr_size, nb_ops, acc) - else ( - Option.iter - (fun max_op -> - if max_op = nb_ops + 1 then raise (Full (inc, acc))) - max_op ; - let* inc'_opt = validate_operation inc op in - match inc'_opt with - | None -> return (inc, curr_size, nb_ops, acc) - | Some inc' -> return (inc', new_size, nb_ops + 1, op :: acc))) - (inc, 0, 0, []) - ops - in - return (inc, List.rev l) - with Full (inc, l) -> return (inc, List.rev l) - -let filter_valid_managers_up_to_quota inc ~hard_gas_limit_per_block (ops, quota) - = - let open Lwt_syntax in - let {Tezos_protocol_environment.max_size; max_op} = quota in - let rec loop (inc, curr_size, nb_ops, total_fees, remaining_gas, acc) = - function - | [] -> return (inc, nb_ops, total_fees, List.rev acc) - | {op; size = op_size; gas = op_gas; fee; _} :: l -> ( - match max_op with - | Some max_op when max_op = nb_ops + 1 -> - return (inc, nb_ops, total_fees, List.rev acc) - | None | Some _ -> ( - if Gas.Arith.(remaining_gas < op_gas) then - (* If the remaining available gas is lower than the - considered operation's gas, we ignore this operation. *) - loop (inc, curr_size, nb_ops, total_fees, remaining_gas, acc) l - else - let new_size = curr_size + op_size in - if new_size > max_size then - (* We ignore the operation if summing its size to the - size of managers operations already validated is - greater than the quota. *) - loop (inc, curr_size, nb_ops, total_fees, remaining_gas, acc) l - else - let packed_op = Prioritized_operation.packed op in - let* inc'_opt = validate_operation inc packed_op in - match inc'_opt with - | None -> - loop - (inc, curr_size, nb_ops, total_fees, remaining_gas, acc) - l - | Some inc' -> - let new_remaining_gas = - Gas.Arith.sub remaining_gas op_gas - in - loop - ( inc', - new_size, - succ nb_ops, - Int64.add total_fees (Tez.to_mutez fee), - new_remaining_gas, - packed_op :: acc ) - l)) - in - loop (inc, 0, 0, Int64.zero, hard_gas_limit_per_block, []) ops - -let filter_operations_with_simulation initial_inc fees_config - ~hard_gas_limit_per_block {consensus; votes; anonymous; managers} = - let open Lwt_result_syntax in - let { - Baking_configuration.minimal_fees; - minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte; - } = - fees_config - in - let*! inc, consensus = - filter_valid_operations_up_to_quota - initial_inc - (Prioritized_operation_set.operations consensus, consensus_quota) - in - let*! inc, votes = - filter_valid_operations_up_to_quota - inc - (Prioritized_operation_set.operations votes, votes_quota) - in - let*! inc, anonymous = - filter_valid_operations_up_to_quota - inc - (Prioritized_operation_set.operations anonymous, anonymous_quota) - in - (* Sort the managers *) - let prioritized_managers = - prioritize_managers - ~hard_gas_limit_per_block - ~minimal_fees - ~minimal_nanotez_per_gas_unit - ~minimal_nanotez_per_byte - managers - in - let*! inc, manager_operation_number, total_fees, managers = - filter_valid_managers_up_to_quota - inc - ~hard_gas_limit_per_block - (PrioritizedManagerSet.elements prioritized_managers, managers_quota) - in - let operations = [consensus; votes; anonymous; managers] in - let operations_hash = - Operation_list_list_hash.compute - (List.map - (fun sl -> - Operation_list_hash.compute (List.map Operation.hash_packed sl)) - operations) - in - let inc = {inc with header = {inc.header with operations_hash}} in - let* result = Baking_simulator.finalize_construction inc in - match result with - | Some (validation_result, block_header_metadata) -> - return - { - validation_result = Some validation_result; - block_header_metadata = Some block_header_metadata; - operations; - operations_hash; - manager_operations_infos = Some {manager_operation_number; total_fees}; - } - | None -> - return - { - validation_result = None; - block_header_metadata = None; - operations; - operations_hash; - manager_operations_infos = None; - } - -let filter_valid_operations_up_to_quota_without_simulation (ops, quota) = - let {Tezos_protocol_environment.max_size; max_op} = quota in - let exception Full of packed_operation list in - try - List.fold_left - (fun (curr_size, nb_ops, acc) op -> - let op_size = - Data_encoding.Binary.length Alpha_context.Operation.encoding op - in - let new_size = curr_size + op_size in - if new_size > max_size then (curr_size, nb_ops, acc) - else ( - Option.iter - (fun max_op -> if max_op = nb_ops + 1 then raise (Full acc)) - max_op ; - (new_size, nb_ops + 1, op :: acc))) - (0, 0, []) - ops - |> fun (_, _, l) -> List.rev l - with Full l -> List.rev l - -let filter_operations_without_simulation fees_config ~hard_gas_limit_per_block - {consensus; votes; anonymous; managers} = - let consensus = - filter_valid_operations_up_to_quota_without_simulation - (Prioritized_operation_set.operations consensus, consensus_quota) - in - let votes = - filter_valid_operations_up_to_quota_without_simulation - (Prioritized_operation_set.operations votes, votes_quota) - in - let anonymous = - filter_valid_operations_up_to_quota_without_simulation - (Prioritized_operation_set.operations anonymous, anonymous_quota) - in - let { - Baking_configuration.minimal_fees; - minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte; - } = - fees_config - in - (* Sort the managers *) - let prioritized_managers = - prioritize_managers - ~hard_gas_limit_per_block - ~minimal_fees - ~minimal_nanotez_per_gas_unit - ~minimal_nanotez_per_byte - managers - in - let managers = - filter_valid_operations_up_to_quota_without_simulation - ( PrioritizedManagerSet.elements prioritized_managers - |> List.map (fun {op; _} -> Prioritized_operation.packed op), - managers_quota ) - in - let operations = [consensus; votes; anonymous; managers] in - operations - -let filter_consensus_operations_only inc - ({consensus; votes; anonymous; managers} as ordered_pool) = - let open Lwt_result_syntax in - let*! incremental, filtered_consensus = - filter_valid_operations_up_to_quota inc (consensus, consensus_quota) - in - let payload = Operation_pool.payload_of_ordered_pool ordered_pool in - let* incremental = - List.fold_left_es - (fun inc op -> - let* inc, _ = Baking_simulator.add_operation inc op in - return inc) - incremental - (List.flatten [votes; anonymous; managers]) - in - let filtered_pool = - Operation_pool.ordered_pool_of_payload - ~consensus_operations:filtered_consensus - payload - in - return (incremental, filtered_pool) diff --git a/src/proto_020_PsParisC/lib_delegate/operation_selection.mli b/src/proto_020_PsParisC/lib_delegate/operation_selection.mli deleted file mode 100644 index af0ca7658096..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/operation_selection.mli +++ /dev/null @@ -1,72 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context -open Tezos_protocol_environment - -type simulation_result = { - validation_result : validation_result option; - block_header_metadata : Apply_results.block_metadata option; - operations : packed_operation list list; - operations_hash : Operation_list_list_hash.t; - manager_operations_infos : Baking_state.manager_operations_infos option; -} - -(** [filter_operations_with_simulation incremental fees_config - ~hard_gas_limit_per_block ops] tries to validate prioritized operations (and - apply them if [incremental] has been initialised with an - [application_state]) and filter them regarding the quota of each validation - pass. Manager operations are prioritized based on a weight computed from - their fees/gas/bytes. [filter_operations_with_simulation] function returns a - [simulation_result], containing the validated operation, their resulting - [operations_hash], optional [validation_result] and [block_header_metadata] - if the operations were applied. *) -val filter_operations_with_simulation : - Baking_simulator.incremental -> - Baking_configuration.fees_config -> - hard_gas_limit_per_block:Gas.Arith.integral -> - Operation_pool.Prioritized.t -> - simulation_result tzresult Lwt.t - -(** [filter_operations_without_simulation fees_config ~hard_gas_limit_per_block - ops] is similar to [filter_operations_with_simulation] but does not validate - (and apply) operations from [ops] and returns only the operations instead of - a [simulation_result]. - - Hypothesis: operations from [ops] have previously been validated. *) -val filter_operations_without_simulation : - Baking_configuration.fees_config -> - hard_gas_limit_per_block:Gas.Arith.integral -> - Operation_pool.Prioritized.t -> - packed_operation list list - -(** [filter_consensus_operations_only incremental ops] is similar to - [filter_operations_with_simulation] but only filters consensus operations - from [ops]. *) -val filter_consensus_operations_only : - Baking_simulator.incremental -> - Operation_pool.ordered_pool -> - (Baking_simulator.incremental * Operation_pool.ordered_pool) tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/operation_worker.ml b/src/proto_020_PsParisC/lib_delegate/operation_worker.ml deleted file mode 100644 index 2d2b9c54fcea..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/operation_worker.ml +++ /dev/null @@ -1,771 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol_client_context -open Protocol -open Alpha_context - -module Profiler = (val Profiler.wrap Baking_profiler.operation_worker_profiler) - -module Events = struct - include Internal_event.Simple - - let section = [Protocol.name; "baker"; "operation_worker"] - - let pp_int = Format.pp_print_int - - let loop_failed = - declare_1 - ~section - ~name:"loop_failed" - ~level:Error - ~msg:"loop failed with {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let ended = - declare_1 - ~section - ~name:"ended" - ~level:Error - ~msg:"ended with error {stacktrace}" - ("stacktrace", Data_encoding.string) - - let pqc_reached = - declare_2 - ~section - ~name:"pqc_reached" - ~level:Info - ~msg: - "prequorum reached (voting power: {voting_power}, {preattestations} \ - preattestations)" - ~pp1:pp_int - ("voting_power", Data_encoding.int31) - ~pp2:pp_int - ("preattestations", Data_encoding.int31) - - let preattestations_received = - declare_4 - ~section - ~name:"preattestations_received" - ~level:Debug - ~msg: - "received {count} preattestations (power: {delta_power}) (total voting \ - power: {voting_power}, {preattestations} preattestations)" - ~pp1:pp_int - ("count", Data_encoding.int31) - ~pp2:pp_int - ("delta_power", Data_encoding.int31) - ~pp3:pp_int - ("voting_power", Data_encoding.int31) - ~pp4:pp_int - ("preattestations", Data_encoding.int31) - - let pqc_progression = - declare_2 - ~section - ~name:"pqc_progression" - ~level:Info - ~msg: - "preattesting voting power at {quorum_progression}% of the stake with \ - {preattestations} preattestations" - ~pp1:pp_int - ("quorum_progression", Data_encoding.int31) - ~pp2:pp_int - ("preattestations", Data_encoding.int31) - - let qc_reached = - declare_2 - ~section - ~name:"qc_reached" - ~level:Info - ~msg: - "quorum reached (voting power: {voting_power}, {attestations} \ - attestations)" - ~pp1:pp_int - ("voting_power", Data_encoding.int31) - ~pp2:pp_int - ("attestations", Data_encoding.int31) - - let attestations_received = - declare_4 - ~section - ~name:"attestations_received" - ~level:Debug - ~msg: - "received {count} attestations (power: {delta_power}) (total voting \ - power: {voting_power}, {attestations} attestations)" - ~pp1:pp_int - ("count", Data_encoding.int31) - ~pp2:pp_int - ("delta_power", Data_encoding.int31) - ~pp3:pp_int - ("voting_power", Data_encoding.int31) - ~pp4:pp_int - ("attestations", Data_encoding.int31) - - let qc_progression = - declare_2 - ~section - ~name:"qc_progression" - ~level:Info - ~msg: - "attesting voting power at {quorum_progression}% of the stake with \ - {attestations} attestations" - ~pp1:pp_int - ("quorum_progression", Data_encoding.int31) - ~pp2:pp_int - ("attestations", Data_encoding.int31) - - let starting_new_monitoring = - declare_0 - ~section - ~name:"starting_new_monitoring" - ~level:Debug - ~msg:"starting new monitoring" - () - - let resetting_monitoring = - declare_0 - ~section - ~name:"resetting_monitoring" - ~level:Debug - ~msg:"resetting monitoring after a mempool flush" - () - - let end_of_stream = - declare_0 - ~section - ~name:"end_of_stream" - ~level:Debug - ~msg:"end of stream" - () - - (* info messages *) - let shutting_down = - declare_0 - ~section - ~name:"shutting_down" - ~level:Info - ~msg:"shutting down operation worker" - () -end - -type candidate = { - hash : Block_hash.t; - round_watched : Round.t; - payload_hash_watched : Block_payload_hash.t; -} - -let candidate_encoding = - let open Data_encoding in - conv - (fun {hash; round_watched; payload_hash_watched} -> - (hash, round_watched, payload_hash_watched)) - (fun (hash, round_watched, payload_hash_watched) -> - {hash; round_watched; payload_hash_watched}) - (obj3 - (req "hash" Block_hash.encoding) - (req "round_watched" Round.encoding) - (req "payload_hash_watched" Block_payload_hash.encoding)) - -type event = - | Prequorum_reached of candidate * Kind.preattestation operation list - | Quorum_reached of candidate * Kind.attestation operation list - -let compare_consensus_contents (op1 : consensus_content) - (op2 : consensus_content) = - Compare.or_else (Raw_level.compare op1.level op2.level) @@ fun () -> - Compare.or_else (Round.compare op1.round op2.round) @@ fun () -> - Compare.or_else (Slot.compare op1.slot op2.slot) @@ fun () -> - Block_payload_hash.compare op1.block_payload_hash op2.block_payload_hash - -module Preattestation_set = Set.Make (struct - type t = Kind.preattestation operation - - let compare - ({protocol_data = {contents = Single (Preattestation op1); _}; shell = _} : - t) - ({protocol_data = {contents = Single (Preattestation op2); _}; shell = _} : - t) = - compare_consensus_contents op1 op2 -end) - -module Attestation_set = Set.Make (struct - type t = Kind.attestation operation - - let compare - ({ - protocol_data = - { - contents = - Single (Attestation {consensus_content = op1; dal_content = _}); - _; - }; - shell = _; - } : - t) - ({ - protocol_data = - { - contents = - Single (Attestation {consensus_content = op2; dal_content = _}); - _; - }; - shell = _; - } : - t) = - (* We do not consider the DAL content (therefore two attestations with the - same consensus content but different DAL content are considered equal), - in order to correctly count the voting power. Note however that there - should be no such operations in the mempool in the first place. *) - compare_consensus_contents op1 op2 -end) - -type pqc_watched = { - candidate_watched : candidate; - get_slot_voting_power : slot:Slot.t -> int option; - consensus_threshold : int; - mutable current_voting_power : int; - mutable preattestations_received : Preattestation_set.t; - mutable preattestations_count : int; - mutable previous_prequorum_progression : int; -} - -type qc_watched = { - candidate_watched : candidate; - get_slot_voting_power : slot:Slot.t -> int option; - consensus_threshold : int; - mutable current_voting_power : int; - mutable attestations_received : Attestation_set.t; - mutable attestations_count : int; - mutable previous_quorum_progression : int; -} - -(* [quorum_progression_increment] is a constant used to output an event only if - the quorum progression has progressed of at least - [quorum_progression_increment] since the last output *) -let quorum_progression_increment = 10 - -type watch_kind = Pqc_watch of pqc_watched | Qc_watch of qc_watched - -type quorum_event_stream = { - stream : event Lwt_stream.t; - push : event option -> unit; -} - -type t = { - mutable operation_pool : Operation_pool.pool; - mutable canceler : Lwt_canceler.t; - mutable proposal_watched : watch_kind option; - qc_event_stream : quorum_event_stream; - lock : Lwt_mutex.t; - monitor_node_operations : bool; (* Keep on monitoring node operations *) - committee_size : int; -} - -let monitor_operations (cctxt : #Protocol_client_context.full) = - let open Lwt_result_syntax in - let* operation_stream, stream_stopper = - (Alpha_block_services.Mempool.monitor_operations - cctxt - ~chain:cctxt#chain - ~validated:true - ~branch_delayed:true - ~branch_refused:false - ~refused:false - () [@profiler.record_s {verbosity = Info} "monitor_operations RPC"]) - in - let operation_stream = - Lwt_stream.map - (fun ops -> List.map (fun ((_, op), _) -> op) ops) - operation_stream - in - let* shell_header = - (Shell_services.Blocks.Header.shell_header - cctxt - ~chain:cctxt#chain - ~block:(`Head 0) - () [@profiler.record_s {verbosity = Info} "shell_header RPC"]) - in - let round = - match Fitness.(round_from_raw shell_header.fitness) with - | Ok r -> r - | Error _ -> Round.zero - in - return ((shell_header.level, round), operation_stream, stream_stopper) - -let make_initial_state ?(monitor_node_operations = true) ~constants () = - let qc_event_stream = - let stream, push = Lwt_stream.create () in - {stream; push} - in - let committee_size = - constants.Constants.parametric.consensus_committee_size - in - let canceler = Lwt_canceler.create () in - let operation_pool = Operation_pool.empty in - let lock = Lwt_mutex.create () in - { - operation_pool; - canceler; - proposal_watched = None; - qc_event_stream; - lock; - monitor_node_operations; - committee_size; - } - -let is_valid_consensus_content (candidate : candidate) consensus_content = - let {hash = _; round_watched; payload_hash_watched} = candidate in - Round.equal consensus_content.round round_watched - && Block_payload_hash.equal - consensus_content.block_payload_hash - payload_hash_watched - -let cancel_monitoring state = state.proposal_watched <- None - -let reset_monitoring state = - let open Lwt_syntax in - Lwt_mutex.with_lock state.lock @@ fun () -> - let* () = Events.(emit resetting_monitoring ()) in - match state.proposal_watched with - | None -> return_unit - | Some (Pqc_watch pqc_watched) -> - pqc_watched.current_voting_power <- 0 ; - pqc_watched.preattestations_count <- 0 ; - pqc_watched.preattestations_received <- Preattestation_set.empty ; - pqc_watched.previous_prequorum_progression <- 0 ; - return_unit - | Some (Qc_watch qc_watched) -> - qc_watched.current_voting_power <- 0 ; - qc_watched.attestations_count <- 0 ; - qc_watched.attestations_received <- Attestation_set.empty ; - qc_watched.previous_quorum_progression <- 0 ; - return_unit - -let update_monitoring ?(should_lock = true) state ops = - let open Lwt_syntax in - (if should_lock then Lwt_mutex.with_lock state.lock else fun f -> f ()) - @@ fun () -> - (* If no block is watched, don't do anything *) - match state.proposal_watched with - | None -> return_unit - | Some - (Pqc_watch - ({ - candidate_watched; - get_slot_voting_power; - consensus_threshold; - preattestations_received; - _; - } as proposal_watched)) -> - let preattestations = Operation_pool.filter_preattestations ops in - let preattestations = - List.filter - (fun new_preattestation -> - not - (Preattestation_set.mem - new_preattestation - preattestations_received)) - preattestations - in - let preattestations_count, voting_power = - List.fold_left - (fun (count, power) (op : Kind.preattestation Operation.t) -> - let { - shell = _; - protocol_data = - {contents = Single (Preattestation consensus_content); _}; - _; - } = - op - in - if is_valid_consensus_content candidate_watched consensus_content - then - match get_slot_voting_power ~slot:consensus_content.slot with - | Some op_power -> - proposal_watched.preattestations_received <- - Preattestation_set.add - op - proposal_watched.preattestations_received ; - (succ count, power + op_power) - | None -> - (* preattestations that do not use the first slot of a - delegate are not added to the quorum *) - (count, power) - else (count, power)) - (0, 0) - preattestations - in - proposal_watched.current_voting_power <- - proposal_watched.current_voting_power + voting_power ; - proposal_watched.preattestations_count <- - proposal_watched.preattestations_count + preattestations_count ; - if proposal_watched.current_voting_power >= consensus_threshold then ( - let* () = - Events.( - emit - pqc_reached - ( proposal_watched.current_voting_power, - proposal_watched.preattestations_count )) - in - state.qc_event_stream.push - (Some - (Prequorum_reached - ( candidate_watched, - Preattestation_set.elements - proposal_watched.preattestations_received ))) ; - (* Once the event has been emitted, we cancel the monitoring *) - cancel_monitoring state ; - return_unit) - else - let* () = - let current_ratio = - proposal_watched.current_voting_power * 100 / state.committee_size - in - (* We only want to output an event if the quorum progression has - progressed of at least [quorum_progression_increment] *) - if - current_ratio - > proposal_watched.previous_prequorum_progression - + quorum_progression_increment - then ( - proposal_watched.previous_prequorum_progression <- current_ratio ; - Events.( - emit - pqc_progression - (current_ratio, proposal_watched.preattestations_count))) - else return_unit - in - Events.( - emit - preattestations_received - ( preattestations_count, - voting_power, - proposal_watched.current_voting_power, - proposal_watched.preattestations_count )) - | Some - (Qc_watch - ({ - candidate_watched; - get_slot_voting_power; - consensus_threshold; - attestations_received; - _; - } as proposal_watched)) -> - let attestations = Operation_pool.filter_attestations ops in - let attestations = - List.filter - (fun new_attestation -> - not (Attestation_set.mem new_attestation attestations_received)) - attestations - in - let attestations_count, voting_power = - List.fold_left - (fun (count, power) (op : Kind.attestation Operation.t) -> - let { - shell = _; - protocol_data = - {contents = Single (Attestation {consensus_content; _}); _}; - _; - } = - op - in - if is_valid_consensus_content candidate_watched consensus_content - then - match get_slot_voting_power ~slot:consensus_content.slot with - | Some op_power -> - proposal_watched.attestations_received <- - Attestation_set.add - op - proposal_watched.attestations_received ; - (succ count, power + op_power) - | None -> - (* attestations that do not use the first slot of a delegate - are not added to the quorum *) - (count, power) - else (count, power)) - (0, 0) - attestations - in - proposal_watched.current_voting_power <- - proposal_watched.current_voting_power + voting_power ; - proposal_watched.attestations_count <- - proposal_watched.attestations_count + attestations_count ; - if proposal_watched.current_voting_power >= consensus_threshold then ( - let* () = - Events.( - emit - qc_reached - ( proposal_watched.current_voting_power, - proposal_watched.attestations_count )) - in - state.qc_event_stream.push - (Some - (Quorum_reached - ( candidate_watched, - Attestation_set.elements - proposal_watched.attestations_received ))) ; - (* Once the event has been emitted, we cancel the monitoring *) - cancel_monitoring state ; - return_unit) - else - let* () = - let current_ratio = - proposal_watched.current_voting_power * 100 / state.committee_size - in - (* We only want to output an event if the quorum progression has - progressed of at least [quorum_progression_increment] *) - if - current_ratio - > proposal_watched.previous_quorum_progression - + quorum_progression_increment - then ( - proposal_watched.previous_quorum_progression <- current_ratio ; - Events.( - emit - qc_progression - (current_ratio, proposal_watched.attestations_count))) - else return_unit - in - Events.( - emit - attestations_received - ( attestations_count, - voting_power, - proposal_watched.current_voting_power, - proposal_watched.attestations_count )) - -let monitor_quorum state new_proposal_watched = - Lwt_mutex.with_lock state.lock @@ fun () -> - (* if a previous monitoring was registered, we cancel it *) - if state.proposal_watched <> None then cancel_monitoring state ; - state.proposal_watched <- new_proposal_watched ; - let current_consensus_operations = - Operation_pool.Operation_set.elements state.operation_pool.consensus - in - (* initialize with the currently present consensus operations *) - update_monitoring ~should_lock:false state current_consensus_operations - -let monitor_preattestation_quorum state ~consensus_threshold - ~get_slot_voting_power candidate_watched = - let new_proposal = - Some - (Pqc_watch - { - candidate_watched; - get_slot_voting_power; - consensus_threshold; - current_voting_power = 0; - preattestations_received = Preattestation_set.empty; - preattestations_count = 0; - previous_prequorum_progression = 0; - }) - in - monitor_quorum state new_proposal - -let monitor_attestation_quorum state ~consensus_threshold ~get_slot_voting_power - candidate_watched = - let new_proposal = - Some - (Qc_watch - { - candidate_watched; - get_slot_voting_power; - consensus_threshold; - current_voting_power = 0; - attestations_received = Attestation_set.empty; - attestations_count = 0; - previous_quorum_progression = 0; - }) - in - monitor_quorum state new_proposal - -let shutdown_worker state = - let open Lwt_result_syntax in - let*! () = Events.(emit shutting_down ()) in - Lwt_canceler.cancel state.canceler - -(* Each time a new head is received, the operation_pool field of the state is - cleaned/reset by this function. Instead of emptying it completely, we keep - the attestations of at most 5 rounds and 1 level in the past, to be able to - include as much attestations as possible in the next block if this baker is - the proposer. This allows to handle the following situations: - - - The baker observes an EQC for (L, R), but a proposal arrived for (L, R+1). - After the flush, extra attestations on top of (L, R) are 'Branch_refused', - and are not re-sent by the node. If the baker proposes at (L+1, 1), he should - be able to include these extra attestations. Hence the cache for old rounds. - - - The baker receives a head at (L+1, 0) on top of (L, 0), but this head - didn't reach consensus. If the baker who proposes at (L+1, 1) observed some - extra attestations for (L, 0) that are not included in (L+1, 0), he may want - to add them. But these attestations become 'Outdated' in the mempool once - (L+1, 0) is received. Hence the cache for previous level. -*) -let update_operations_pool state (head_level, head_round) = - let attestations = - let head_round_i32 = Round.to_int32 head_round in - let head_level_i32 = head_level in - Operation_pool.Operation_set.filter - (function - | { - protocol_data = - Operation_data - { - contents = - Single - (Attestation {consensus_content = {round; level; _}; _}); - _; - }; - _; - } -> - let round_i32 = Round.to_int32 round in - let level_i32 = Raw_level.to_int32 level in - let delta_round = Int32.sub head_round_i32 round_i32 in - let delta_level = Int32.sub head_level_i32 level_i32 in - (* Only retain attestations that are maximum 5 rounds old and - 1 level in the last *) - Compare.Int32.(delta_round <= 5l && delta_level <= 1l) - | _ -> false) - state.operation_pool.consensus - in - let operation_pool = {Operation_pool.empty with consensus = attestations} in - state.operation_pool <- operation_pool - -let create ?(monitor_node_operations = true) ~constants - (cctxt : #Protocol_client_context.full) = - let open Lwt_syntax in - let state = - (make_initial_state - ~constants - ~monitor_node_operations - () [@profiler.record_f {verbosity = Notice} "make initial state"]) - in - (* TODO should we continue forever ? *) - let rec worker_loop () = - let* result = - (monitor_operations - cctxt [@profiler.record_s {verbosity = Notice} "monitor operations"]) - in - match result with - | Error err -> Events.(emit loop_failed err) - | Ok (head, operation_stream, op_stream_stopper) -> - () [@profiler.stop] ; - () - [@profiler.record - {verbosity = Notice} - (Format.sprintf - "level : %ld, round : %s" - (fst head) - (Int32.to_string @@ Round.to_int32 @@ snd head))] ; - let* () = Events.(emit starting_new_monitoring ()) in - state.canceler <- Lwt_canceler.create () ; - Lwt_canceler.on_cancel state.canceler (fun () -> - op_stream_stopper - () [@profiler.record_f {verbosity = Notice} "stream stopped"] ; - cancel_monitoring - state - [@profiler.record_f {verbosity = Notice} "cancel monitoring state"] ; - () [@profiler.stop] ; - return_unit) ; - update_operations_pool - state - head - [@profiler.record_f {verbosity = Notice} "update operations pool"] ; - let rec loop () = - let* ops = Lwt_stream.get operation_stream in - match ops with - | None -> - (* When the stream closes, it means a new head has been set, - we reset the monitoring and flush current operations *) - let* () = Events.(emit end_of_stream ()) in - op_stream_stopper - () [@profiler.record_f {verbosity = Info} "stream stopped"] ; - let* () = - (reset_monitoring - state - [@profiler.record_s - {verbosity = Info} "reset monitoring state"]) - in - () [@profiler.stop] ; - worker_loop () - | Some ops -> - (state.operation_pool <- - Operation_pool.add_operations state.operation_pool ops) - [@profiler.aggregate_f {verbosity = Info} "add operations"] ; - let* () = - (update_monitoring - state - ops - [@profiler.aggregate_f - {verbosity = Info} "update monitoring state"]) - in - loop () - in - (loop - () [@profiler.record_s {verbosity = Notice} "operations processing"]) - in - Lwt.dont_wait - (fun () -> - Lwt.finalize - (fun () -> - if state.monitor_node_operations then worker_loop () else return_unit) - (fun () -> - let* _ = shutdown_worker state in - return_unit)) - (fun exn -> - Events.(emit__dont_wait__use_with_care ended (Printexc.to_string exn))) ; - return state - -let retrieve_pending_operations cctxt state = - let open Lwt_result_syntax in - let open Protocol_client_context in - let* pending_mempool = - Alpha_block_services.Mempool.pending_operations - cctxt - ~chain:cctxt#chain - ~validated:true - ~branch_delayed:true - ~branch_refused:false - ~refused:false - ~outdated:false - () - in - state.operation_pool <- - Operation_pool.add_operations state.operation_pool - @@ List.rev_map snd pending_mempool.validated ; - state.operation_pool <- - Operation_pool.add_operations - state.operation_pool - (List.rev_map - (fun (_, (op, _)) -> op) - (Operation_hash.Map.bindings pending_mempool.branch_delayed)) ; - return_unit - -let get_current_operations state = state.operation_pool - -let get_quorum_event_stream state = state.qc_event_stream.stream diff --git a/src/proto_020_PsParisC/lib_delegate/operation_worker.mli b/src/proto_020_PsParisC/lib_delegate/operation_worker.mli deleted file mode 100644 index 2ddcfca5c4b2..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/operation_worker.mli +++ /dev/null @@ -1,91 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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. *) -(* *) -(*****************************************************************************) - -(** Launch processes to gather operations from the mempool and make them - available for the baker. *) - -open Protocol -open Alpha_context - -(** {1 Datatypes}*) - -type t - -type candidate = { - hash : Block_hash.t; - round_watched : Round.t; - payload_hash_watched : Block_payload_hash.t; -} - -val candidate_encoding : candidate Data_encoding.t - -type event = - | Prequorum_reached of candidate * Kind.preattestation operation list - | Quorum_reached of candidate * Kind.attestation operation list - -(** {1 Constructors}*) - -(** [create ?monitor_node_operations cctxt] creates a monitoring process to - fetch operations for the baker to process. - - @param monitor_node_operations monitor operations on the node (defaults: - [true]). Set [monitor_node_operations] to [false] to only consider - externally provided (non-node) operations. *) -val create : - ?monitor_node_operations:bool -> - constants:Constants.t -> - #Protocol_client_context.full -> - t Lwt.t - -(** {1 Utilities} *) - -val retrieve_pending_operations : - #Protocol_client_context.full -> t -> unit tzresult Lwt.t - -(** {1 Accessors}*) - -val get_current_operations : t -> Operation_pool.pool - -val get_quorum_event_stream : t -> event Lwt_stream.t - -(** {1 Observers} *) - -val monitor_preattestation_quorum : - t -> - consensus_threshold:int -> - get_slot_voting_power:(slot:Slot.t -> int option) -> - candidate -> - unit Lwt.t - -val monitor_attestation_quorum : - t -> - consensus_threshold:int -> - get_slot_voting_power:(slot:Slot.t -> int option) -> - candidate -> - unit Lwt.t - -val cancel_monitoring : t -> unit - -val shutdown_worker : t -> (unit, exn list) result Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/per_block_vote_file.ml b/src/proto_020_PsParisC/lib_delegate/per_block_vote_file.ml deleted file mode 100644 index fb903bde0422..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/per_block_vote_file.ml +++ /dev/null @@ -1,154 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 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 Baking_errors -module Events = Baking_events.Per_block_votes - -let default_vote_json_filename = "per_block_votes.json" - -type per_block_votes = { - liquidity_baking_toggle_vote : - Protocol.Alpha_context.Per_block_votes.per_block_vote; - adaptive_issuance_vote_opt : - Protocol.Alpha_context.Per_block_votes.per_block_vote option; -} - -let vote_file_content_encoding = - let open Data_encoding in - def (String.concat "." [Protocol.name; "vote_file_content"]) - @@ conv - (fun {liquidity_baking_toggle_vote; adaptive_issuance_vote_opt} -> - (liquidity_baking_toggle_vote, adaptive_issuance_vote_opt)) - (fun (liquidity_baking_toggle_vote, adaptive_issuance_vote_opt) -> - {liquidity_baking_toggle_vote; adaptive_issuance_vote_opt}) - (obj2 - (req - "liquidity_baking_toggle_vote" - Protocol.Alpha_context.Per_block_votes - .liquidity_baking_vote_encoding) - (opt - "adaptive_issuance_vote" - Protocol.Alpha_context.Per_block_votes - .adaptive_issuance_vote_encoding)) - -let check_file_exists file = - let open Lwt_result_syntax in - let*! file_exists = - Lwt.catch (fun () -> Lwt_unix.file_exists file) (fun _ -> Lwt.return_false) - in - if file_exists then return_unit else tzfail (Block_vote_file_not_found file) - -let read_per_block_votes ~per_block_vote_file : 'a tzresult Lwt.t = - let open Lwt_result_syntax in - let*! () = Events.(emit reading_per_block_votes) per_block_vote_file in - let* () = check_file_exists per_block_vote_file in - let* votes_json = - trace - (Block_vote_file_invalid per_block_vote_file) - (Lwt_utils_unix.Json.read_file per_block_vote_file) - in - let* votes = - trace - (Block_vote_file_wrong_content per_block_vote_file) - (protect (fun () -> - return - (Data_encoding.Json.destruct vote_file_content_encoding votes_json))) - in - return votes - -let read_per_block_votes_no_fail ~default ~per_block_vote_file = - let open Lwt_syntax in - let* result = read_per_block_votes ~per_block_vote_file in - match result with - | Error errs -> - let* () = Events.(emit per_block_vote_file_fail) errs in - return default - | Ok - { - liquidity_baking_toggle_vote; - adaptive_issuance_vote_opt = Some adaptive_issuance_vote; - } -> - return - Protocol.Alpha_context.Per_block_votes. - { - liquidity_baking_vote = liquidity_baking_toggle_vote; - adaptive_issuance_vote; - } - | Ok {liquidity_baking_toggle_vote; adaptive_issuance_vote_opt = None} -> - return {default with liquidity_baking_vote = liquidity_baking_toggle_vote} - -let load_per_block_votes_config ~default_liquidity_baking_vote - ~default_adaptive_issuance_vote ~per_block_vote_file : - Baking_configuration.per_block_votes_config tzresult Lwt.t = - let open Lwt_result_syntax in - (* If a vote file is given, it takes priority. Otherwise, we expect - per-block vote arguments to be passed. *) - let default_adaptive_issuance_vote = - (* Unlike the vote for liquidity baking, the vote for adaptive - issuance is not mandatory. *) - match default_adaptive_issuance_vote with - | None -> Protocol.Alpha_context.Per_block_votes.Per_block_vote_pass - | Some default_adaptive_issuance_vote -> default_adaptive_issuance_vote - in - let* config = - match (per_block_vote_file, default_liquidity_baking_vote) with - | None, None -> tzfail Missing_vote_on_startup - | None, Some liquidity_baking_vote -> - return - { - Baking_configuration.vote_file = None; - liquidity_baking_vote; - adaptive_issuance_vote = default_adaptive_issuance_vote; - } - | Some per_block_vote_file, _ -> ( - let*! (res : _ tzresult) = read_per_block_votes ~per_block_vote_file in - match res with - | Ok - { - liquidity_baking_toggle_vote = liquidity_baking_vote; - adaptive_issuance_vote_opt; - } -> - let adaptive_issuance_vote = - Option.value - ~default:default_adaptive_issuance_vote - adaptive_issuance_vote_opt - in - return - { - Baking_configuration.vote_file = Some per_block_vote_file; - liquidity_baking_vote; - adaptive_issuance_vote; - } - | Error errs -> - let*! () = Events.(emit per_block_vote_file_fail) errs in - tzfail Missing_vote_on_startup) - in - let*! () = - Events.(emit liquidity_baking_toggle_vote) config.liquidity_baking_vote - in - let*! () = - Events.(emit adaptive_issuance_vote) config.adaptive_issuance_vote - in - return config diff --git a/src/proto_020_PsParisC/lib_delegate/per_block_vote_file.mli b/src/proto_020_PsParisC/lib_delegate/per_block_vote_file.mli deleted file mode 100644 index 5347f30a6ce8..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/per_block_vote_file.mli +++ /dev/null @@ -1,77 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 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 is used to load the baker's per block votes - configurations. When a file is given as configuration, its content - is expected to be a valid JSON matching the following examples: - - {v {"liquidity_baking_toggle_vote": "on"} v} - - {v {"liquidity_baking_toggle_vote": "off"} v} - - {v {"liquidity_baking_toggle_vote": "pass"} v} - - {v {"adaptive_issuance_vote": "on"} v} - - {v {"adaptive_issuance_vote": "off"} v} - - {v {"adaptive_issuance_vote": "pass"} v} - - {v {"liquidity_baking_toggle_vote": "on","adaptive_issuance_vote": "on"} v} - - {v {"liquidity_baking_toggle_vote": "on","adaptive_issuance_vote": "off"} v} - - {v {"liquidity_baking_toggle_vote": "on","adaptive_issuance_vote": "pass"} v} - - {v {"liquidity_baking_toggle_vote": "off","adaptive_issuance_vote": "on"} v} - - {v {"liquidity_baking_toggle_vote": "off","adaptive_issuance_vote": "off"} v} - - {v {"liquidity_baking_toggle_vote": "off","adaptive_issuance_vote": "pass"} v} - - {v {"liquidity_baking_toggle_vote": "pass","adaptive_issuance_vote": "on"} v} - - {v {"liquidity_baking_toggle_vote": "pass","adaptive_issuance_vote": "off"} v} - - {v {"liquidity_baking_toggle_vote": "pass","adaptive_issuance_vote": "pass"} v} - - Moreover, in order to handle dynamic voting (i.e. change the - baker's vote without having to restart it), each time a block is - being built, the baker will try and read the vote file present in - the config in order to check for updated votes. -*) - -open Protocol.Alpha_context - -(** Default vote file name that should be looked up when the baker - starts. *) -val default_vote_json_filename : string - -(** Reads the content of [per_block_vote_file] and returns the votes. If - any error occurs (e.g. Non-existing file, unparsable content, - etc.), given default values will be used to fill the gaps. *) -val read_per_block_votes_no_fail : - default:Per_block_votes.per_block_votes -> - per_block_vote_file:string -> - Per_block_votes.per_block_votes Lwt.t - -(** Load a configuration of per-block votes. Liquidity baking toggle - vote is mandatory, it has to come from either the per-block vote - file [per_block_vote_file] or from - [default_liquidity_baking_vote]. If a vote cannot be determined - from those values, this function fails. Adaptive issuance feature - vote is optional. Priority is given to the values in the - [per_block_vote_file] file for all votes at the time of the block - (the file is freshly read each time). *) -val load_per_block_votes_config : - default_liquidity_baking_vote:Per_block_votes.per_block_vote option -> - default_adaptive_issuance_vote:Per_block_votes.per_block_vote option -> - per_block_vote_file:string option -> - Baking_configuration.per_block_votes_config tzresult Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/state_transitions.ml b/src/proto_020_PsParisC/lib_delegate/state_transitions.ml deleted file mode 100644 index 3832f64ea7e1..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/state_transitions.ml +++ /dev/null @@ -1,1348 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 Protocol -open Alpha_context -open Baking_state -open Baking_actions -module Events = Baking_events.State_transitions - -module Profiler = (val Profiler.wrap Baking_profiler.baker_profiler) - -let do_nothing state = Lwt.return (state, Do_nothing) - -type proposal_acceptance = Invalid | Outdated_proposal | Valid_proposal - -let is_acceptable_proposal_for_current_level state - (proposal : Baking_state.proposal) = - let open Lwt_syntax in - let current_round = state.round_state.current_round in - if Round.(current_round < proposal.block.round) then - let* () = - Events.( - emit unexpected_proposal_round (current_round, proposal.block.round)) - in - return Invalid - else if Round.(current_round > proposal.block.round) then - return Outdated_proposal - else - (* current_round = proposal.round *) - let previous_proposal = state.level_state.latest_proposal in - if - Round.(proposal.block.round = previous_proposal.block.round) - && Block_hash.(proposal.block.hash <> previous_proposal.block.hash) - && Block_hash.( - proposal.predecessor.hash = previous_proposal.predecessor.hash) - then - (* An existing proposal was found at the same round: the - proposal is bad and should be punished by the accuser *) - let* () = - Events.( - emit - proposal_for_round_already_seen - (proposal.block.hash, current_round, previous_proposal.block.hash)) - in - return Invalid - else - (* current_round = proposal.block.round ∧ - proposal.block.round <> previous_proposal.block.round - => - proposal.block.round > previous_proposal.block.round - - The proposal has the expected round and the previous proposal - is a predecessor therefore the proposal is valid *) - return Valid_proposal - -(* This function retrieves the branch of the predecessor's predecessor (block - finalized) instead of the predecessor. This is done to avoid having consensus - operation branched on block that are not part of the canonical chain - anymore. *) -let get_branch_from_proposal proposal = proposal.predecessor.shell.predecessor - -let make_consensus_vote_batch state proposal kind = - let level = - Raw_level.of_int32 state.level_state.current_level |> function - | Ok l -> l - | _ -> assert false - in - let round = proposal.block.round in - let block_payload_hash = proposal.block.payload_hash in - let batch_content = {level; round; block_payload_hash} in - let delegates_and_slots = - List.map - (fun delegate_slot -> - (delegate_slot.consensus_key_and_delegate, delegate_slot.first_slot)) - (Delegate_slots.own_delegates state.level_state.delegate_slots) - in - (* The branch is the latest finalized block. *) - let batch_branch = - get_branch_from_proposal state.level_state.latest_proposal - in - Baking_state.make_unsigned_consensus_vote_batch - kind - batch_content - ~batch_branch - delegates_and_slots - -(* If we do not have any slots, we won't inject any operation but we - will still participate to determine an elected block *) -let prepare_preattest_action state proposal = - let preattestations : unsigned_consensus_vote_batch = - make_consensus_vote_batch state proposal Baking_state.Preattestation - in - Prepare_preattestations {preattestations} - -let prepare_consensus_votes_action state proposal = - let preattestations : unsigned_consensus_vote_batch = - (make_consensus_vote_batch - state - proposal - Baking_state.Preattestation - [@profiler.record_f {verbosity = Debug} "prepare preattestations"]) - in - let attestations : unsigned_consensus_vote_batch = - (make_consensus_vote_batch - state - proposal - Baking_state.Attestation - [@profiler.record_f {verbosity = Debug} "prepare attestations"]) - in - Prepare_consensus_votes {preattestations; attestations} - -let update_proposal ~is_proposal_applied state proposal = - let open Lwt_syntax in - let* () = Events.(emit updating_latest_proposal proposal.block.hash) in - let prev_proposal = state.level_state.latest_proposal in - let is_latest_proposal_applied = - (* mark as applied if it is indeed applied or if this specific proposal was - already marked as applied *) - is_proposal_applied - || prev_proposal.block.hash = proposal.block.hash - && state.level_state.is_latest_proposal_applied - in - let new_level_state = - { - state.level_state with - is_latest_proposal_applied; - latest_proposal = proposal; - } - in - return {state with level_state = new_level_state} - -let may_update_proposal ~is_proposal_applied state (proposal : proposal) = - assert ( - Compare.Int32.( - state.level_state.latest_proposal.block.shell.level - = proposal.block.shell.level)) ; - if - Round.(state.level_state.latest_proposal.block.round < proposal.block.round) - then update_proposal ~is_proposal_applied state proposal - else Lwt.return state - -let preattest state proposal = - let open Lwt_syntax in - if Baking_state.is_first_block_in_protocol proposal then - (* We do not preattest the first transition block *) - let new_state = update_current_phase state Idle in - return (new_state, Do_nothing) - else - let* () = Events.(emit attempting_preattest_proposal proposal.block.hash) in - let new_state = - (* We have detected a new proposal that needs to be preattested. - We switch to the `Awaiting_preattestations` phase. *) - update_current_phase state Awaiting_preattestations - in - (* Here, we do not cancel pending signatures as it is already done - in [handle_proposal]. *) - return (new_state, prepare_preattest_action state proposal) - -let prepare_consensus_votes state proposal = - let open Lwt_syntax in - if Baking_state.is_first_block_in_protocol proposal then - (* We do not vote for the first transition block *) - let new_state = update_current_phase state Idle in - return (new_state, Do_nothing) - else - let* () = Events.(emit attempting_vote_proposal proposal.block.hash) in - let new_state = - (* We have detected a new proposal that needs to be voted for. - We switch to the `Awaiting_preattestations` phase. *) - update_current_phase state Awaiting_preattestations - in - return (new_state, prepare_consensus_votes_action state proposal) - -let extract_pqc state (new_proposal : proposal) = - match new_proposal.block.prequorum with - | None -> None - | Some pqc -> - let add_voting_power acc (op : Kind.preattestation Operation.t) = - let open Protocol.Alpha_context.Operation in - let { - shell = _; - protocol_data = {contents = Single (Preattestation {slot; _}); _}; - _; - } = - op - in - match - Delegate_slots.voting_power state.level_state.delegate_slots ~slot - with - | None -> - (* cannot happen if the map is correctly populated *) - acc - | Some attesting_power -> acc + attesting_power - in - let voting_power = - List.fold_left add_voting_power 0 pqc.preattestations - in - let consensus_threshold = - state.global_state.constants.parametric.consensus_threshold - in - if Compare.Int.(voting_power >= consensus_threshold) then - Some (pqc.preattestations, pqc.round) - else None - -let may_update_attestable_payload_with_internal_pqc state - (new_proposal : proposal) = - match - (new_proposal.block.prequorum, state.level_state.attestable_payload) - with - | None, _ -> - (* The proposal does not contain a PQC: no need to update *) - state - | Some {round = new_round; _}, Some {prequorum = {round = old_round; _}; _} - when Round.(new_round < old_round) -> - (* The proposal pqc is outdated, do not update *) - state - | Some better_prequorum, _ -> - assert ( - Block_payload_hash.( - better_prequorum.block_payload_hash = new_proposal.block.payload_hash)) ; - assert ( - Compare.Int32.(better_prequorum.level = new_proposal.block.shell.level)) ; - let new_attestable_payload = - Some {proposal = new_proposal; prequorum = better_prequorum} - in - let new_level_state = - {state.level_state with attestable_payload = new_attestable_payload} - in - {state with level_state = new_level_state} - -let has_already_been_handled state new_proposal = - let current_proposal = state.level_state.latest_proposal in - Block_hash.(current_proposal.block.hash = new_proposal.block.hash) - && state.level_state.is_latest_proposal_applied - -let mark_awaiting_pqc state = - let new_round_state = - {state.round_state with awaiting_unlocking_pqc = true} - in - let new_state = {state with round_state = new_round_state} in - new_state - -let rec handle_proposal ~is_proposal_applied state (new_proposal : proposal) = - let open Lwt_syntax in - (* We need to avoid to send votes if we are in phases where consensus - votes are already being forged. This is needed to avoid switching - back from Awaiting_attestations to Awaiting_preattestations. - Hypothesis: a fresh round's initial phase is Idle *) - let may_vote state proposal = - match state.round_state.current_phase with - | Idle -> - (* We prioritize the new and meaningful consensus vote signing - by cancelling all pending forge and signing tasks. In this - current context, preattesting means that it is now too late - to include outdated consensus votes and blocks. However, - active forge requests are still processed until - completion. *) - state.global_state.forge_worker_hooks.cancel_all_pending_tasks () ; - prepare_consensus_votes state proposal - | _ -> do_nothing state - in - let current_level = state.level_state.current_level in - let new_proposal_level = new_proposal.block.shell.level in - let current_proposal = state.level_state.latest_proposal in - if - is_proposal_applied - && Block_hash.(current_proposal.block.hash = new_proposal.block.hash) - then - let new_level_state = - {state.level_state with is_latest_proposal_applied = true} - in - let new_state = {state with level_state = new_level_state} in - do_nothing new_state - else if Compare.Int32.(current_level > new_proposal_level) then - (* The baker is ahead, a reorg may have happened. Do nothing: - wait for the node to send us the branch's head. This new head - should have a fitness that is greater than our current - proposal and thus, its level should be at least the same as - our current proposal's level. *) - let* () = - Events.(emit baker_is_ahead_of_node (current_level, new_proposal_level)) - in - (do_nothing - state [@profiler.record_s {verbosity = Debug} "baker ahead of node"]) - else if Compare.Int32.(current_level = new_proposal_level) then - if - (* The received head is a new proposal for the current level: - let's check if it's a valid one for us. *) - Block_hash.( - current_proposal.predecessor.hash <> new_proposal.predecessor.hash) - then - let* () = - Events.( - emit - new_proposal_is_on_another_branch - (current_proposal.predecessor.hash, new_proposal.predecessor.hash)) - in - (may_switch_branch - ~is_proposal_applied - state - new_proposal - [@profiler.record_s {verbosity = Debug} "may switch branch"]) - else - let* proposal_acceptance = - is_acceptable_proposal_for_current_level state new_proposal - in - match proposal_acceptance with - | Invalid -> - (* The proposal is invalid: we ignore it *) - let* () = Events.(emit skipping_invalid_proposal ()) in - (do_nothing - state - [@profiler.record_s {verbosity = Debug} "skipping invalid proposal"]) - | Outdated_proposal -> - (* Check whether we need to update our attestable payload *) - let state = - may_update_attestable_payload_with_internal_pqc state new_proposal - in - (* The proposal is outdated: we update to be able to extract - its included attestations but we do not attest it *) - let* () = Events.(emit outdated_proposal new_proposal.block.hash) in - let* state = - (may_update_proposal - ~is_proposal_applied - state - new_proposal - [@profiler.record_s - {verbosity = Debug} "outdated proposal : may update proposal"]) - in - do_nothing state - | Valid_proposal -> ( - (* Valid_proposal => proposal.round = current_round *) - (* Check whether we need to update our attestable payload *) - let new_state = - may_update_attestable_payload_with_internal_pqc state new_proposal - in - let* new_state = - (may_update_proposal - ~is_proposal_applied - new_state - new_proposal - [@profiler.record_s - {verbosity = Debug} "valid proposal : may update proposal"]) - in - (* We invalidate early attestations *) - let new_round_state = - {new_state.round_state with early_attestations = []} - in - let new_state = {new_state with round_state = new_round_state} in - (* The proposal is valid but maybe we already locked on a payload *) - match new_state.level_state.locked_round with - | Some locked_round -> ( - if - Block_payload_hash.( - locked_round.payload_hash = new_proposal.block.payload_hash) - then - (* when the new head has the same payload as our - [locked_round], we accept it and vote for it *) - may_vote - new_state - new_proposal - [@profiler.record_s - {verbosity = Debug} "same payload : may vote"] - else - (* The payload is different *) - match new_proposal.block.prequorum with - | Some {round; _} when Round.(locked_round.round < round) -> - (* This PQC is above our locked_round, we can and vote for it *) - may_vote - new_state - new_proposal - [@profiler.record_s - {verbosity = Debug} "different payload : may vote"] - | _ -> - (* We shouldn't vote for proposal, but we - should at least watch (pre)quorums events on it - but only when it is applied otherwise we await - for the proposal to be applied. *) - let new_state = mark_awaiting_pqc new_state in - let new_state = - update_current_phase new_state Awaiting_preattestations - in - return (new_state, Watch_prequorum)) - | None -> - (* Otherwise, we did not lock on any payload, thus we can - vote for it it *) - may_vote - new_state - new_proposal [@profiler.record_s {verbosity = Debug} "may vote"] - ) - else - (* Last case: new_proposal_level > current_level *) - (* Possible scenarios: - - we received a block for a next level - - we received our own block - This is where we update our [level_state] (and our [round_state]) *) - let* () = Events.(emit new_head_with_increasing_level ()) in - let new_level = new_proposal.block.shell.level in - let compute_new_state ~current_round ~delegate_slots - ~next_level_delegate_slots ~dal_attestable_slots - ~next_level_dal_attestable_slots = - let round_state = - { - current_round; - current_phase = Idle; - delayed_quorum = None; - early_attestations = []; - awaiting_unlocking_pqc = false; - } - in - let level_state = - { - current_level = new_level; - latest_proposal = new_proposal; - is_latest_proposal_applied = is_proposal_applied; - (* Unlock values *) - locked_round = None; - attestable_payload = None; - elected_block = None; - delegate_slots; - next_level_delegate_slots; - next_level_proposed_round = None; - dal_attestable_slots; - next_level_dal_attestable_slots; - } - in - (* recursive call with the up-to-date state to handle the new - level proposals *) - (handle_proposal - ~is_proposal_applied - {state with level_state; round_state} - new_proposal [@profiler.record_s {verbosity = Debug} "handle proposal"]) - in - let action = - Update_to_level {new_level_proposal = new_proposal; compute_new_state} - in - return (state, action) - -and may_switch_branch ~is_proposal_applied state new_proposal = - let open Lwt_syntax in - let switch_branch state = - let* () = Events.(emit switching_branch ()) in - (* If we are on a different branch, we also need to update our - [round_state] accordingly. - The recursive call to [handle_proposal] cannot end up - with an invalid proposal as it's on a different branch, thus - there is no need to backtrack to the former state as the new - proposal must end up being the new [latest_proposal]. That's - why we update it here. *) - let round_update = - { - Baking_actions.new_round_proposal = new_proposal; - handle_proposal = - (fun state -> handle_proposal ~is_proposal_applied state new_proposal); - } - in - let* new_state = update_proposal ~is_proposal_applied state new_proposal in - (* TODO if the branch proposal is outdated, we should - trigger an [End_of_round] to participate *) - return (new_state, Synchronize_round round_update) - in - let current_attestable_payload = state.level_state.attestable_payload in - match (current_attestable_payload, new_proposal.block.prequorum) with - | None, Some _ | None, None -> - let* () = Events.(emit branch_proposal_has_better_fitness ()) in - (* The new branch contains a PQC (and we do not) or a better - fitness, we switch. *) - switch_branch state - | Some _, None -> - (* We have a better PQC, we don't switch as we are able to - propose a better chain if we stay on our current one. *) - let* () = Events.(emit branch_proposal_has_no_prequorum ()) in - do_nothing state - | Some {prequorum = current_pqc; _}, Some new_pqc -> - if Round.(current_pqc.round > new_pqc.round) then - let* () = Events.(emit branch_proposal_has_lower_prequorum ()) in - (* The other's branch PQC is lower than ours, do not - switch *) - do_nothing state - else if Round.(current_pqc.round < new_pqc.round) then - let* () = Events.(emit branch_proposal_has_better_prequorum ()) in - (* Their PQC is better than ours: we switch *) - switch_branch state - else - (* current_pqc.round = new_pqc *) - (* There is a PQC on two branches with the same round and - the same level but not the same predecessor : it's - impossible unless if there was some double-baking. This - shouldn't happen but do nothing anyway. *) - let* () = Events.(emit branch_proposal_has_same_prequorum ()) in - do_nothing state - -(* Create a fresh block proposal containing the current operations of the - mempool in [state] and the additional [attestations] for [delegate] at round - [round]. *) -let prepare_block_to_bake ~attestations ?last_proposal - ~(predecessor : block_info) state delegate round = - (* The block to bake embeds the operations gathered by the - worker. However, consensus operations that are not relevant for - this block are filtered out. In the case of proposing a new fresh - block, the block is supposed to carry only attestations for the - previous level. *) - let open Lwt_syntax in - let operation_pool = - (* 1. Fetch operations from the mempool. *) - let current_mempool = - let pool = - Operation_worker.get_current_operations - state.global_state.operation_worker - in - (* Considered the operations in the previous proposal as well *) - match last_proposal with - | Some proposal -> - let { - Operation_pool.votes_payload; - anonymous_payload; - managers_payload; - } = - proposal.payload - in - List.fold_left - Operation_pool.add_operations - pool - [votes_payload; anonymous_payload; managers_payload] - | None -> pool - in - (* 2. Filter and only retain relevant attestations. *) - let relevant_consensus_operations = - let attestation_filter = - { - Operation_pool.level = predecessor.shell.level; - round = predecessor.round; - payload_hash = predecessor.payload_hash; - } - in - (Operation_pool.filter_with_relevant_consensus_ops - ~attestation_filter - ~preattestation_filter:None - current_mempool.consensus - [@profiler.record_f {verbosity = Debug} "filter consensus operations"]) - in - let filtered_mempool = - {current_mempool with consensus = relevant_consensus_operations} - in - (* 3. Add the additional given [attestations]. - N.b. this is a set: there won't be duplicates *) - Operation_pool.add_operations - filtered_mempool - (List.map Operation.pack attestations) - in - let kind = Fresh operation_pool in - let* () = Events.(emit preparing_fresh_block (delegate, round)) in - let force_apply = - state.global_state.config.force_apply || Round.(round <> zero) - (* This is used as a safety net by applying blocks on round > 0, in case - validation-only did not produce a correct round-0 block. *) - in - let block_to_bake : block_to_bake = - {predecessor; round; delegate; kind; force_apply} - in - return (Prepare_block {block_to_bake}) - -(** Create an inject action that will inject either a fresh block or the pre-emptively - forged block if it exists. *) -let propose_fresh_block_action ~attestations ?last_proposal - ~(predecessor : block_info) state delegate round = - (* TODO check if there is a trace where we could not have updated the level *) - prepare_block_to_bake - ~attestations - ?last_proposal - ~predecessor - state - delegate - round - -let propose_block_action state delegate round ~last_proposal = - let open Lwt_syntax in - (* Possible cases: - 1. There was a proposal but the PQC was not reached. - 2. There was a proposal and the PQC was reached. We repropose the - [attestable_payload] if it exists, not the [locked_round] as it - may be older. *) - match state.level_state.attestable_payload with - | None -> - let* () = Events.(emit no_attestable_payload_fresh_block ()) in - (* For case 1, we may re-inject with the same payload or a fresh - one. We make the choice of baking a fresh one: the previous - proposal may have been rejected because the block may have been - valid but may be considered "bad" (censored operations, empty - block, etc.) by the other validators. *) - (* Invariant: there is no locked round if there is no attestable - payload *) - assert (state.level_state.locked_round = None) ; - let attestations_in_last_proposal = last_proposal.block.quorum in - propose_fresh_block_action - ~attestations:attestations_in_last_proposal - state - ~last_proposal:last_proposal.block - ~predecessor:last_proposal.predecessor - delegate - round - | Some {proposal; prequorum} -> - let* () = Events.(emit repropose_block proposal.block.payload_hash) in - (* For case 2, we re-inject the same block as [attestable_round] - but we may add some left-overs attestations. Therefore, the - operations we need to include are: - - the proposal's included attestations - - the potential missing new attestations for the - previous block - - the PQC of the attestable payload *) - let consensus_operations = - (* Fetch preattestations and attestations from the mempool - (that could be missing from the proposal), filter, then add - consensus operations of the proposal itself, and convert - into [packed_operation trace]. *) - let mempool_consensus_operations = - (Operation_worker.get_current_operations - state.global_state.operation_worker) - .consensus - in - let all_consensus_operations = - (* Add the proposal and pqc consensus operations to the - mempool *) - List.fold_left - (fun set op -> Operation_pool.Operation_set.add op set) - mempool_consensus_operations - (List.map Operation.pack proposal.block.quorum - @ List.map Operation.pack prequorum.preattestations) - in - let attestation_filter = - { - Operation_pool.level = proposal.predecessor.shell.level; - round = proposal.predecessor.round; - payload_hash = proposal.predecessor.payload_hash; - } - in - let preattestation_filter = - Some - { - Operation_pool.level = prequorum.level; - round = prequorum.round; - payload_hash = prequorum.block_payload_hash; - } - in - Operation_pool.( - filter_with_relevant_consensus_ops - ~attestation_filter - ~preattestation_filter - all_consensus_operations - |> Operation_set.elements) - in - let payload_hash = proposal.block.payload_hash in - let payload_round = proposal.block.payload_round in - let payload = proposal.block.payload in - let kind = - Reproposal {consensus_operations; payload_hash; payload_round; payload} - in - let force_apply = - true - (* This is used as a safety net by applying blocks on round > 0, in case - validation-only did not produce a correct round-0 block. *) - in - let block_to_bake = - {predecessor = proposal.predecessor; round; delegate; kind; force_apply} - in - return (Prepare_block {block_to_bake}) - -let end_of_round state current_round = - let open Lwt_syntax in - let new_round = Round.succ current_round in - (* We initialize the round's phase to Idle for the [handle_proposal] - transition to trigger the preattestation action. *) - let new_round_state = - { - current_round = new_round; - current_phase = Idle; - delayed_quorum = None; - early_attestations = []; - awaiting_unlocking_pqc = false; - } - in - let new_state = {state with round_state = new_round_state} in - (* we need to check if we need to bake for this round or not *) - let round_proposer_opt = - (round_proposer - new_state - ~level:`Current - new_state.round_state.current_round - [@profiler.record_f {verbosity = Debug} "round proposer"]) - in - match round_proposer_opt with - | None -> - let* () = - Events.( - emit - no_proposal_slot - (current_round, state.level_state.current_level, new_round)) - in - (* We don't have any delegate that may propose a new block for - this round -- We will wait for preattestations when the next - level block arrive. Meanwhile, we are idle *) - let new_state = update_current_phase new_state Idle in - do_nothing new_state - | Some {consensus_key_and_delegate; _} -> - let latest_proposal = state.level_state.latest_proposal in - if Baking_state.is_first_block_in_protocol latest_proposal then - (* Do not inject a block for the previous protocol! (Let the - baker of the previous protocol do it.) *) - do_nothing new_state - else - let* () = - Events.( - emit - proposal_slot - ( current_round, - state.level_state.current_level, - new_round, - consensus_key_and_delegate )) - in - (* We have a delegate, we need to determine what to inject *) - let* action = - (propose_block_action - new_state - consensus_key_and_delegate - new_round - ~last_proposal:state.level_state.latest_proposal - [@profiler.record_s - {verbosity = Debug} "create propose block action"]) - in - return (new_state, action) - -let time_to_prepare_next_level_block state at_round = - let open Lwt_syntax in - (* It is now time to update the state level *) - (* We need to keep track for which block we have 2f+1 *attestations*, that is, - which will become the new predecessor_block *) - (* Invariant: attestable_round >= round(elected block) >= locked_round *) - let round_proposer_opt = - (round_proposer - state - ~level:`Next - at_round [@profiler.record_f {verbosity = Debug} "round proposer"]) - in - match (state.level_state.elected_block, round_proposer_opt) with - | None, _ | _, None -> - (* Unreachable: the [Time_to_prepare_next_level_block] event can only be - triggered when we have a slot and an elected block *) - assert false - | Some elected_block, Some {consensus_key_and_delegate; _} -> - let attestations = elected_block.attestation_qc in - let new_level_state = - {state.level_state with next_level_proposed_round = Some at_round} - in - let new_state = {state with level_state = new_level_state} in - let* action = - (propose_fresh_block_action - ~attestations - ~predecessor:elected_block.proposal.block - new_state - consensus_key_and_delegate - at_round - [@profiler.record_s - {verbosity = Debug} "create propose fresh block action"]) - in - return (new_state, action) - -let update_locked_round state round payload_hash = - let locked_round = Some {payload_hash; round} in - let new_level_state = {state.level_state with locked_round} in - {state with level_state = new_level_state} - -let prepare_attest_action state proposal = - let attestations : unsigned_consensus_vote_batch = - make_consensus_vote_batch state proposal Baking_state.Attestation - in - Prepare_attestations {attestations} - -(* This function is called once a prequorum has been reached. *) -let may_inject_attestations state ~first_signed_attestation - ~other_signed_attestations = - let open Lwt_syntax in - let emit_discarding_unexpected_attestation_event - ?(payload : attestable_payload option) attestation = - let { - vote_consensus_content = {level; round = att_round; block_payload_hash; _}; - delegate; - _; - } = - attestation.unsigned_consensus_vote - in - let att_level = Raw_level.to_int32 level in - match payload with - | None -> - Events.( - emit - discarding_unexpected_attestation_without_prequorum_payload - (delegate, att_level, att_round)) - | Some payload -> - Events.( - emit - discarding_unexpected_attestation_with_different_prequorum_payload - ( delegate, - block_payload_hash, - att_level, - att_round, - payload.proposal.block.payload_hash )) - in - let check_payload state attestation do_action = - match state.level_state.attestable_payload with - | None -> - (* No attestable payload, either the prequorum has not been reached yet, - or an other issue occurred, we cannot inject the attestations. *) - let* () = emit_discarding_unexpected_attestation_event attestation in - do_nothing state - | Some payload -> - if - not - Block_payload_hash.( - payload.proposal.block.payload_hash - = attestation.unsigned_consensus_vote.vote_consensus_content - .block_payload_hash) - then - (* Attestable payload found in the state but it is different from the - one in the attestation operation, we cannot inject the - attestation. *) - let* () = - emit_discarding_unexpected_attestation_event ~payload attestation - in - do_nothing state - else do_action - in - match other_signed_attestations with - | [] -> - check_payload state first_signed_attestation - @@ - let signed_attestations = - make_singleton_consensus_vote_batch first_signed_attestation - in - Lwt.return (state, Inject_attestations {signed_attestations}) - | _ :: _ -> ( - check_payload state first_signed_attestation - @@ - let batch_branch = - get_branch_from_proposal state.level_state.latest_proposal - in - let batch_content = - let vote_consensus_content = - first_signed_attestation.unsigned_consensus_vote - .vote_consensus_content - in - { - level = vote_consensus_content.level; - round = vote_consensus_content.round; - block_payload_hash = vote_consensus_content.block_payload_hash; - } - in - make_signed_consensus_vote_batch - Attestation - batch_content - ~batch_branch - (first_signed_attestation :: other_signed_attestations) - |> function - | Ok signed_attestations -> - Lwt.return (state, Inject_attestations {signed_attestations}) - | Error _err -> (* Unreachable *) do_nothing state) - -(* This function tries to inject attestations already prepared if the - prequorum is reached. *) -let may_inject_early_forged_attestations state = - let early_attestations = state.round_state.early_attestations in - match early_attestations with - | [] -> Lwt.return (state, Watch_quorum) - | first_signed_attestation :: other_signed_attestations -> - let new_round_state = {state.round_state with early_attestations = []} in - let new_state = {state with round_state = new_round_state} in - may_inject_attestations - new_state - ~first_signed_attestation - ~other_signed_attestations - -let prequorum_reached_when_awaiting_preattestations state candidate - preattestations = - let open Lwt_syntax in - let latest_proposal = state.level_state.latest_proposal in - if Block_hash.(candidate.Operation_worker.hash <> latest_proposal.block.hash) - then - let* () = - Events.( - emit - unexpected_prequorum_received - (candidate.hash, latest_proposal.block.hash)) - in - do_nothing state - else - let prequorum = - { - level = latest_proposal.block.shell.level; - round = latest_proposal.block.round; - block_payload_hash = latest_proposal.block.payload_hash; - preattestations - (* preattestations may be nil when [consensus_threshold] is 0 *); - } - in - let new_attestable_payload = {proposal = latest_proposal; prequorum} in - let new_level_state = - let level_state_with_new_payload = - { - state.level_state with - attestable_payload = Some new_attestable_payload; - } - in - match state.level_state.attestable_payload with - | None -> level_state_with_new_payload - | Some attestable_payload -> - if - Round.( - attestable_payload.prequorum.round - < new_attestable_payload.prequorum.round) - then level_state_with_new_payload - else state.level_state - in - let new_state = {state with level_state = new_level_state} in - let new_state = - (update_locked_round - new_state - latest_proposal.block.round - latest_proposal.block.payload_hash - [@profiler.record_f {verbosity = Debug} "update locked round"]) - in - let new_state = - (update_current_phase - new_state - Awaiting_attestations - [@profiler.record_f - {verbosity = Debug} "update current phase: Awaiting attestations"]) - in - if new_state.round_state.awaiting_unlocking_pqc then - (* We were locked and did not trigger preemptive - consensus votes: we need to start attesting now. *) - return - (new_state, prepare_attest_action new_state latest_proposal) - [@profiler.record_s {verbosity = Debug} "prepare attest action"] - else - (* We already triggered preemptive attestation forging, we - either have those already or we are waiting for them. *) - may_inject_early_forged_attestations - new_state - [@profiler.record_s - {verbosity = Debug} "may inject early forged attestations"] - -let quorum_reached_when_waiting_attestations state candidate attestation_qc = - let open Lwt_syntax in - let latest_proposal = state.level_state.latest_proposal in - let is_latest_proposal_applied = - state.level_state.is_latest_proposal_applied - in - if Block_hash.(candidate.Operation_worker.hash <> latest_proposal.block.hash) - then - let* () = - Events.( - emit - unexpected_quorum_received - (candidate.hash, latest_proposal.block.hash)) - in - do_nothing state - else - let new_round_state, new_level_state = - match state.level_state.elected_block with - | None when is_latest_proposal_applied -> - (* The elected proposal has been applied. Record the elected block - and transition to the Idle phase, as there is nothing left to do. - *) - let elected_block = - Some {proposal = latest_proposal; attestation_qc} - in - let new_level_state = {state.level_state with elected_block} in - let new_round_state = {state.round_state with current_phase = Idle} in - (new_round_state, new_level_state) - | None -> - (* A quorum has been reached, but the elected proposal has not been - applied yet by the node. Transition in the `Awaiting_application` - phase, and do not save the elected block in the state. Instead, - keep track that an early quorum has been reached at this round. - This avoids the proposer of a block at the next level to inject a - proposal before the node has been applied the proposal elected at - the current level. *) - let new_round_state = - { - state.round_state with - current_phase = Awaiting_application; - delayed_quorum = Some attestation_qc; - } - in - (new_round_state, state.level_state) - | Some _ -> - (* If we already have an elected block, do not update it: the - earlier, the better. We do not need to record the quorum either, - as this won't be used to elect a new block. *) - (state.round_state, state.level_state) - in - let new_state = - {state with round_state = new_round_state; level_state = new_level_state} - in - do_nothing new_state - -let handle_expected_applied_proposal (state : Baking_state.t) = - let new_level_state = - {state.level_state with is_latest_proposal_applied = true} - in - (* This code is triggered only when in the `Awaiting_application`phase, which - in turn is reached only if a quorum has been met but the - block has not been applied by the node. As a consequence, the only - thing that is left to do at this stage is to update the elected block - and transition to the Idle phase, as there is nothing left to do. *) - let new_state = {state with level_state = new_level_state} in - let new_state = - match new_state.level_state.elected_block with - | None -> - (* We do not have an elected block for this level. We need to update it. *) - let latest_proposal = state.level_state.latest_proposal in - let attestation_qc = - match state.round_state.delayed_quorum with - | None -> assert false - | Some attestation_qc -> attestation_qc - in - let elected_block = Some {proposal = latest_proposal; attestation_qc} in - let new_level_state = {state.level_state with elected_block} in - {state with level_state = new_level_state} - | Some _ -> - (* We already have an elected block at this level. We do not need to update - it. The earlier, the better. *) - new_state - in - let new_state = - (update_current_phase - new_state - Idle - [@profiler.record_f {verbosity = Debug} "update current phase: Idle"]) - in - do_nothing new_state - -let handle_forged_preattestation state signed_preattestation = - let open Lwt_syntax in - let { - vote_consensus_content = - { - level; - round = att_round; - block_payload_hash = att_payload_hash; - slot = _; - }; - delegate; - _; - } = - signed_preattestation.unsigned_consensus_vote - in - let att_level = Raw_level.to_int32 level in - let check_payload state preattestation do_action = - match state.level_state.attestable_payload with - | None -> - (* No attestable payload set, we are free to inject the - preattestations *) - do_action - | Some payload -> - if - not - Block_payload_hash.( - payload.proposal.block.payload_hash - = preattestation.unsigned_consensus_vote.vote_consensus_content - .block_payload_hash) - then - (* The preattestation payload does not match the one set in the - state, we cannot inject the preattestation. *) - let* () = - Events.( - emit - discarding_unexpected_preattestation_with_different_payload - ( delegate, - att_payload_hash, - att_level, - att_round, - payload.proposal.block.payload_hash )) - in - do_nothing state - else do_action - in - (check_payload state signed_preattestation - @@ Lwt.return (state, Inject_preattestation {signed_preattestation})) - [@profiler.record_s {verbosity = Debug} "check payload"] - -let handle_forged_attestation state signed_attestation = - let open Lwt_syntax in - let { - vote_consensus_content = - { - level; - round = att_round; - block_payload_hash = att_payload_hash; - slot = _; - }; - delegate; - _; - } = - signed_attestation.unsigned_consensus_vote - in - let att_level = Raw_level.to_int32 level in - let attestation_matches_proposal = - let {payload_hash; round = block_round; shell; _} = - state.level_state.latest_proposal.block - in - Block_payload_hash.(att_payload_hash = payload_hash) - && Round.(att_round = block_round) - && Compare.Int32.(shell.level = att_level) - in - if not attestation_matches_proposal then - let* () = - Events.(emit discarding_attestation (delegate, att_level, att_round)) - in - (do_nothing - state [@profiler.record_s {verbosity = Debug} "discarding attestation"]) - else - match state.round_state.current_phase with - | Awaiting_preattestations -> - (* An attestation is ready for injection but the prequorum has - not been reached yet: we save them until then. *) - let new_round_state = - { - state.round_state with - early_attestations = - signed_attestation :: state.round_state.early_attestations; - } - in - let new_state = {state with round_state = new_round_state} in - (do_nothing - new_state - [@profiler.record_s {verbosity = Debug} "prequorum not yet reached"]) - | Idle | Awaiting_attestations | Awaiting_application -> - (* For these three phases, we should have already reached the prequorum. - If this is not the case, the attestations will not be injected. *) - may_inject_attestations - state - ~first_signed_attestation:signed_attestation - ~other_signed_attestations:[] - [@profiler.record_s {verbosity = Debug} "may inject attestations"] - -let handle_forge_event state forge_event = - match forge_event with - | Block_ready prepared_block -> - Lwt.return - ( state, - Inject_block - {prepared_block; force_injection = false; asynchronous = true} ) - | Preattestation_ready signed_preattestation -> - handle_forged_preattestation state signed_preattestation - | Attestation_ready signed_attestation -> - handle_forged_attestation state signed_attestation - -(* Hypothesis: - - The state is not to be modified outside this module - (NB: there are exceptions in Baking_actions: the corner cases - [update_to_level] and [synchronize_round] and - the hack used by [inject_block]) - - - new_proposal's received blocks are expected to belong to our current - round - - - [Prequorum_reached] can only be received when we've seen a new head - - - [Quorum_reached] can only be received when we've seen a - [Prequorum_reached] *) -let step (state : Baking_state.t) (event : Baking_state.event) : - (Baking_state.t * Baking_actions.t) Lwt.t = - let open Lwt_syntax in - let phase = state.round_state.current_phase in - let* () = Events.(emit step_current_phase (phase, event)) in - match (phase, event) with - (* Handle timeouts *) - | _, Timeout (End_of_round {ending_round}) -> - (* If the round is ending, stop everything currently going on and - increment the round. *) - end_of_round - state - ending_round [@profiler.record_s {verbosity = Info} "end of round"] - | _, Timeout (Time_to_prepare_next_level_block {at_round}) -> - (* If it is time to bake the next level, stop everything currently - going on and propose the next level block *) - time_to_prepare_next_level_block - state - at_round - [@profiler.record_s {verbosity = Info} "prepare next level block"] - | Idle, New_head_proposal proposal -> - let* () = - Events.( - emit - new_head - ( proposal.block.hash, - proposal.block.shell.level, - proposal.block.round )) - in - (handle_proposal - ~is_proposal_applied:true - state - proposal - [@profiler.record_s {verbosity = Info} "handle new head proposal"]) - | Awaiting_application, New_head_proposal proposal -> - if - Block_hash.( - state.level_state.latest_proposal.block.hash <> proposal.block.hash) - then - let* () = - Events.( - emit - new_head - ( proposal.block.hash, - proposal.block.shell.level, - proposal.block.round )) - in - let* () = - Events.(emit unexpected_new_head_while_waiting_for_application ()) - in - (handle_proposal - ~is_proposal_applied:true - state - proposal - [@profiler.record_s {verbosity = Info} "handle new head proposal"]) - else - let* () = - Events.(emit applied_expected_proposal_received proposal.block.hash) - in - (handle_expected_applied_proposal - state - [@profiler.record_s - {verbosity = Info} "handle expected applied proposal"]) - | Awaiting_attestations, New_head_proposal proposal - | Awaiting_preattestations, New_head_proposal proposal -> - let* () = - Events.( - emit - new_head - ( proposal.block.hash, - proposal.block.shell.level, - proposal.block.round )) - in - let* () = Events.(emit new_head_while_waiting_for_qc ()) in - (handle_proposal - ~is_proposal_applied:true - state - proposal - [@profiler.record_s {verbosity = Info} "handle new head proposal"]) - | Idle, New_valid_proposal proposal -> - let* () = - Events.( - emit - new_valid_proposal - ( proposal.block.hash, - proposal.block.shell.level, - proposal.block.round )) - in - (handle_proposal - ~is_proposal_applied:false - state - proposal - [@profiler.record_s {verbosity = Info} "handle new valid proposal"]) - | _, New_forge_event (forge_event : forge_event) -> - let* () = Events.(emit new_forge_event forge_event) in - (handle_forge_event - state - forge_event - [@profiler.record_s {verbosity = Info} "handle forge event"]) - | Awaiting_application, New_valid_proposal proposal - | Awaiting_attestations, New_valid_proposal proposal - | Awaiting_preattestations, New_valid_proposal proposal -> - let* () = - Events.( - emit - new_valid_proposal - ( proposal.block.hash, - proposal.block.shell.level, - proposal.block.round )) - in - if has_already_been_handled state proposal then - let* () = Events.(emit valid_proposal_received_after_application ()) in - (do_nothing state [@profiler.record_s {verbosity = Info} "do nothing"]) - else - let* () = Events.(emit new_valid_proposal_while_waiting_for_qc ()) in - (handle_proposal - ~is_proposal_applied:false - state - proposal - [@profiler.record_s {verbosity = Info} "handle new valid proposal"]) - | Awaiting_preattestations, Prequorum_reached (candidate, preattestation_qc) - -> - prequorum_reached_when_awaiting_preattestations - state - candidate - preattestation_qc - [@profiler.record_s - {verbosity = Info} "prequorum reached when awaiting preattestations"] - | Awaiting_attestations, Quorum_reached (candidate, attestation_qc) -> - quorum_reached_when_waiting_attestations - state - candidate - attestation_qc - [@profiler.record_s - {verbosity = Info} "quorum reached when awaiting attestations"] - (* Unreachable cases modulo concurrency. *) - | ( (Idle | Awaiting_application | Awaiting_attestations), - Prequorum_reached (candidate, _operations_pqc) ) -> - (* Unexpected prequorum reached, we do not lock on it and discard it. *) - let* () = - Events.( - emit discarding_unexpected_prequorum_reached (candidate.hash, phase)) - in - (do_nothing - state - [@profiler.record_s {verbosity = Info} "unexpected quorum reached"]) - | ( (Idle | Awaiting_preattestations | Awaiting_application), - Quorum_reached (candidate, _operations_qc) ) -> - (* Unexpected quorum reached, we discard it. *) - let* () = - Events.( - emit discarding_unexpected_quorum_reached (candidate.hash, phase)) - in - (do_nothing - state - [@profiler.record_s {verbosity = Info} "unexpected quorum reached"]) diff --git a/src/proto_020_PsParisC/lib_delegate/state_transitions.mli b/src/proto_020_PsParisC/lib_delegate/state_transitions.mli deleted file mode 100644 index bb2cf360fd02..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/state_transitions.mli +++ /dev/null @@ -1,90 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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, and in particular the {!step} function, modifies the automaton - state, while {!Baking_actions} performs potentially failing side-effects. *) - -open Protocol -open Alpha_context -open Baking_state -open Baking_actions - -val do_nothing : state -> (state * action) Lwt.t - -type proposal_acceptance = Invalid | Outdated_proposal | Valid_proposal - -val is_acceptable_proposal_for_current_level : - state -> proposal -> proposal_acceptance Lwt.t - -val make_consensus_vote_batch : - state -> proposal -> consensus_vote_kind -> unsigned_consensus_vote_batch - -val may_update_proposal : - is_proposal_applied:bool -> state -> proposal -> state Lwt.t - -val preattest : state -> proposal -> (state * action) Lwt.t - -val extract_pqc : - state -> proposal -> (Kind.preattestation operation list * Round.t) option - -val handle_proposal : - is_proposal_applied:bool -> state -> proposal -> (state * action) Lwt.t - -(** Propose a block at the start of the given round for the given delegate, - given that there was already a proposal at the current level, the last one - being [last_proposal]. *) -val propose_block_action : - state -> - consensus_key_and_delegate -> - Round.t -> - last_proposal:proposal -> - action Lwt.t - -(** Increase the current round and propose at the new round (same - level), if the baker has a proposer slot. *) -val end_of_round : state -> Round.t -> (state * action) Lwt.t - -(** Propose for the first time at a level at the given round. There was no - previous proposal at the current level. *) -val time_to_prepare_next_level_block : - state -> Round.t -> (state * action) Lwt.t - -val update_locked_round : state -> Round.t -> Block_payload_hash.t -> state - -val prepare_attest_action : state -> proposal -> action - -val prequorum_reached_when_awaiting_preattestations : - state -> - Operation_worker.candidate -> - Kind.preattestation operation list -> - (state * action) Lwt.t - -val quorum_reached_when_waiting_attestations : - state -> - Operation_worker.candidate -> - Kind.attestation operation list -> - (state * action) Lwt.t - -val step : state -> event -> (state * action) Lwt.t diff --git a/src/proto_020_PsParisC/lib_delegate/vdf_helpers.ml b/src/proto_020_PsParisC/lib_delegate/vdf_helpers.ml deleted file mode 100644 index b3fe451bc1d5..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/vdf_helpers.ml +++ /dev/null @@ -1,31 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 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 Protocol.Alpha_context - -let is_in_nonce_revelation_stage ~nonce_revelation_threshold ~(level : Level.t) - = - let cycle_position = level.cycle_position in - Int32.compare cycle_position nonce_revelation_threshold < 0 diff --git a/src/proto_020_PsParisC/lib_delegate/vdf_helpers.mli b/src/proto_020_PsParisC/lib_delegate/vdf_helpers.mli deleted file mode 100644 index 1000c59bece0..000000000000 --- a/src/proto_020_PsParisC/lib_delegate/vdf_helpers.mli +++ /dev/null @@ -1,35 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 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 Protocol.Alpha_context - -(** [is_in_nonce_revelation_stage ~nonce_revelation_threshold ~level] checks - whether [level] is part of the nonce revelation stage of its cycle, which - is defined as the first [nonce_revelation_threshold] blocks of every cycle. - It is used to avoid calling the [Seed_computation] RPC on blocks which are - part of the nonce revelation stage. - *) -val is_in_nonce_revelation_stage : - nonce_revelation_threshold:int32 -> level:Level.t -> bool diff --git a/src/proto_020_PsParisC/lib_injector/dune b/src/proto_020_PsParisC/lib_injector/dune deleted file mode 100644 index c63ee0d2028e..000000000000 --- a/src/proto_020_PsParisC/lib_injector/dune +++ /dev/null @@ -1,23 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name octez_injector_PsParisC) - (package tezos-injector-020-PsParisC) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - tezos-protocol-020-PsParisC.protocol - octez-injector - octez-protocol-020-PsParisC-libs.client - octez-shell-libs.client-base - octez-protocol-020-PsParisC-libs.plugin) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_protocol_020_PsParisC - -open Octez_injector - -open Tezos_client_020_PsParisC - -open Tezos_client_base - -open Tezos_protocol_plugin_020_PsParisC)) diff --git a/src/proto_020_PsParisC/lib_injector/injector_plugin.ml b/src/proto_020_PsParisC/lib_injector/injector_plugin.ml deleted file mode 100644 index 90b6306390f5..000000000000 --- a/src/proto_020_PsParisC/lib_injector/injector_plugin.ml +++ /dev/null @@ -1,457 +0,0 @@ -(*****************************************************************************) -(* *) -(* SPDX-License-Identifier: MIT *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 Functori, *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context -open Protocol_client_context -open Injector_common -open Injector_sigs -open Injector_server -open Injector_server_operation -module Block_cache = - Aches_lwt.Lache.Make_result - (Aches.Rache.Transfer (Aches.Rache.LRU) (Block_hash)) - -module Proto_client = struct - open Tezos_micheline - - type operation = Injector_server_operation.t - - type state = Injector_server.state - - type unsigned_operation = - Tezos_base.Operation.shell_header * packed_contents_list - - let max_operation_data_length = Constants.max_operation_data_length - - let manager_pass = Operation_repr.manager_pass - - let to_manager_operation : t -> packed_manager_operation = function - | Transaction {amount; destination; parameters} -> - let destination = - Contract.of_b58check destination - |> WithExceptions.Result.to_exn_f ~error:(fun _trace -> - Stdlib.failwith - "Injector_plugin.to_manager_operation: invalid destination") - in - let entrypoint, parameters = - match parameters with - | Some {entrypoint; value} -> - let entrypoint = - Entrypoint.of_string_lax entrypoint - |> WithExceptions.Result.to_exn_f ~error:(fun _trace -> - Stdlib.failwith - "Injector_plugin.to_manager_operation: invalid \ - entrypoint") - in - let expr = - Michelson_v1_parser.parse_expression value - |> Micheline_parser.no_parsing_error - |> WithExceptions.Result.to_exn_f ~error:(fun _trace -> - Stdlib.failwith - "Injector_plugin.to_manager_operation: invalid \ - parameters") - in - (entrypoint, Script.lazy_expr expr.expanded) - | None -> (Entrypoint.default, Script.unit_parameter) - in - Manager - (Transaction - { - amount = Tez.of_mutez_exn amount; - destination; - parameters; - entrypoint; - }) - - let of_manager_operation : type kind. kind manager_operation -> t option = - function - | Transaction {amount; parameters; entrypoint; destination} -> - Option.bind (Data_encoding.force_decode parameters) (fun parameters -> - Some - (Transaction - { - amount = Tez.to_mutez amount; - destination = Contract.to_b58check destination; - parameters = - Some - { - value = - Michelson_v1_printer.micheline_string_of_expression - ~zero_loc:true - parameters; - entrypoint = Entrypoint.to_string entrypoint; - }; - })) - | _ -> None - - let manager_operation_size (Manager operation) = - let contents = - Manager_operation - { - source = Signature.Public_key_hash.zero; - operation; - fee = Tez.zero; - counter = Manager_counter.Internal_for_tests.of_int 0; - gas_limit = Gas.Arith.zero; - storage_limit = Z.zero; - } - in - Data_encoding.Binary.length Operation.contents_encoding (Contents contents) - - let operation_size op = manager_operation_size (to_manager_operation op) - - (* The operation size overhead is an upper bound (in practice) of the overhead - that will be added to a manager operation. To compute it we can use any - manager operation (here a revelation), add an overhead with upper bounds as - values (for the fees, limits, counters, etc.) and compare the encoded - operations with respect to their size. - NOTE: This information is only used to pre-select operations from the - injector queue as a candidate batch. *) - let operation_size_overhead = - let dummy_operation = - Reveal - (Signature.Public_key.of_b58check_exn - "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav") - in - let dummy_contents = - Manager_operation - { - source = Signature.Public_key_hash.zero; - operation = dummy_operation; - fee = Tez.of_mutez_exn 3_000_000L; - counter = Manager_counter.Internal_for_tests.of_int 500_000; - gas_limit = Gas.Arith.integral_of_int_exn 500_000; - storage_limit = Z.of_int 500_000; - } - in - let dummy_size = - Data_encoding.Binary.length - Operation.contents_encoding - (Contents dummy_contents) - in - dummy_size - manager_operation_size (Manager dummy_operation) - - let manager_operation_result_status (type kind) - (op_result : kind Apply_results.manager_operation_result) : - operation_status = - match op_result with - | Applied _ -> Successful - | Backtracked (_, None) -> Unsuccessful Backtracked - | Skipped _ -> Unsuccessful Skipped - | Backtracked (_, Some err) - (* Backtracked because internal operation failed *) - | Failed (_, err) -> - Unsuccessful (Failed (Environment.wrap_tztrace err)) - - let operation_result_status (type kind) - (op_result : kind Apply_results.contents_result) : operation_status = - match op_result with - | Preattestation_result _ -> Successful - | Attestation_result _ -> Successful - | Seed_nonce_revelation_result _ -> Successful - | Vdf_revelation_result _ -> Successful - | Double_attestation_evidence_result _ -> Successful - | Double_preattestation_evidence_result _ -> Successful - | Double_baking_evidence_result _ -> Successful - | Activate_account_result _ -> Successful - | Proposals_result -> Successful - | Ballot_result -> Successful - | Drain_delegate_result _ -> Successful - | Manager_operation_result {operation_result; _} -> - manager_operation_result_status operation_result - - let operation_contents_status (type kind) - (contents : kind Apply_results.contents_result_list) ~index : - operation_status tzresult = - let rec rec_status : - type kind. int -> kind Apply_results.contents_result_list -> _ = - fun n -> function - | Apply_results.Single_result _ when n <> 0 -> - error_with "No operation with index %d" index - | Single_result result -> Ok (operation_result_status result) - | Cons_result (result, _rest) when n = 0 -> - Ok (operation_result_status result) - | Cons_result (_result, rest) -> rec_status (n - 1) rest - in - rec_status index contents - - let operation_status_of_receipt (operation : Protocol.operation_receipt) - ~index : operation_status tzresult = - match (operation : _) with - | No_operation_metadata -> - error_with "Cannot find operation status because metadata is missing" - | Operation_metadata {contents} -> operation_contents_status contents ~index - - (* TODO: https://gitlab.com/tezos/tezos/-/issues/6339 *) - (* Don't make multiple calls to [operations_in_pass] RPC *) - let get_block_operations = - let ops_cache = Block_cache.create 32 in - fun cctxt block_hash -> - Block_cache.bind_or_put - ops_cache - block_hash - (fun block_hash -> - let open Lwt_result_syntax in - let+ operations = - Alpha_block_services.Operations.operations_in_pass - cctxt - ~chain:cctxt#chain - ~block:(`Hash (block_hash, 0)) - ~metadata:`Always - manager_pass - in - List.fold_left - (fun acc (op : Alpha_block_services.operation) -> - Operation_hash.Map.add op.hash op acc) - Operation_hash.Map.empty - operations) - Lwt.return - - let operation_status (node_ctxt : state) block_hash operation_hash ~index = - let open Lwt_result_syntax in - let* operations = get_block_operations node_ctxt.cctxt block_hash in - match Operation_hash.Map.find_opt operation_hash operations with - | None -> return_none - | Some operation -> ( - match operation.receipt with - | Empty -> - failwith "Cannot find operation status because metadata is empty" - | Too_large -> - failwith - "Cannot find operation status because metadata is too large" - | Receipt receipt -> - let*? status = operation_status_of_receipt receipt ~index in - return_some status) - - let dummy_sk_uri = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Tezos_signer_backends.Unencrypted.make_sk - @@ Signature.Secret_key.of_b58check_exn - "edsk3UqeiQWXX7NFEY1wUs6J1t2ez5aQ3hEWdqX5Jr5edZiGLW8nZr" - - let simulate_operations cctxt ~force ~source ~src_pk ~successor_level - ~fee_parameter ?safety_guard operations = - let open Lwt_result_syntax in - let fee_parameter : Injection.fee_parameter = - { - minimal_fees = Tez.of_mutez_exn fee_parameter.minimal_fees.mutez; - minimal_nanotez_per_byte = fee_parameter.minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit = - fee_parameter.minimal_nanotez_per_gas_unit; - force_low_fee = fee_parameter.force_low_fee; - fee_cap = Tez.of_mutez_exn fee_parameter.fee_cap.mutez; - burn_cap = Tez.of_mutez_exn fee_parameter.burn_cap.mutez; - } - in - let open Annotated_manager_operation in - let annotated_operations = - List.map - (fun operation -> - let (Manager operation) = to_manager_operation operation in - Annotated_manager_operation - (Injection.prepare_manager_operation - ~fee:Limit.unknown - ~gas_limit:Limit.unknown - ~storage_limit:Limit.unknown - operation)) - operations - in - let (Manager_list annot_op) = - Annotated_manager_operation.manager_of_list annotated_operations - in - let cctxt = - new Protocol_client_context.wrap_full (cctxt :> Client_context.full) - in - let safety_guard = Option.map Gas.Arith.integral_of_int_exn safety_guard in - let*! simulation_result = - Injection.inject_manager_operation - cctxt - ~simulation:true (* Only simulation here *) - ~force - ~chain:cctxt#chain - ~block:(`Head 0) - ~source - ~src_pk - ~src_sk:dummy_sk_uri - (* Use dummy secret key as it is not used by simulation *) - ~successor_level - ~fee:Limit.unknown - ~gas_limit:Limit.unknown - ~storage_limit:Limit.unknown - ?safety_guard - ~fee_parameter - annot_op - in - match simulation_result with - | Error trace -> - let exceeds_quota = - TzTrace.fold - (fun exceeds -> function - | Environment.Ecoproto_error - (Gas.Block_quota_exceeded | Gas.Operation_quota_exceeded) -> - true - | _ -> exceeds) - false - trace - in - fail (if exceeds_quota then `Exceeds_quotas trace else `TzError trace) - | Ok (_oph, packed_op, _contents, results) -> - let nb_ops = List.length operations in - let results = Apply_results.to_list (Contents_result_list results) in - (* packed_op can have reveal operations added automatically. *) - let start_index = List.length results - nb_ops in - (* remove extra reveal operations *) - let operations_statuses = - List.fold_left_i - (fun index_in_batch acc (Apply_results.Contents_result result) -> - if index_in_batch < start_index then acc - else - {index_in_batch; status = operation_result_status result} :: acc) - [] - results - |> List.rev - in - let unsigned_operation = - let {shell; protocol_data = Operation_data {contents; signature = _}} - = - packed_op - in - (shell, Contents_list contents) - in - return {operations_statuses; unsigned_operation} - - let sign_operation cctxt src_sk - ((shell, Contents_list contents) as unsigned_op) = - let open Lwt_result_syntax in - let unsigned_bytes = - Data_encoding.Binary.to_bytes_exn Operation.unsigned_encoding unsigned_op - in - let cctxt = - new Protocol_client_context.wrap_full (cctxt :> Client_context.full) - in - let+ signature = - Client_keys.sign - cctxt - ~watermark:Signature.Generic_operation - src_sk - unsigned_bytes - in - let op : packed_operation = - { - shell; - protocol_data = Operation_data {contents; signature = Some signature}; - } - in - Data_encoding.Binary.to_bytes_exn Operation.encoding op - - let time_until_next_block {minimal_block_delay; delay_increment_per_round; _} - (header : Tezos_base.Block_header.shell_header option) = - let open Result_syntax in - match header with - | None -> minimal_block_delay |> Int64.to_int |> Ptime.Span.of_int_s - | Some header -> - let minimal_block_delay = Period.of_seconds_exn minimal_block_delay in - let delay_increment_per_round = - Period.of_seconds_exn delay_increment_per_round - in - let next_level_timestamp = - let* durations = - Round.Durations.create - ~first_round_duration:minimal_block_delay - ~delay_increment_per_round - in - let* predecessor_round = Fitness.round_from_raw header.fitness in - Round.timestamp_of_round - durations - ~predecessor_timestamp:header.timestamp - ~predecessor_round - ~round:Round.zero - in - let next_level_timestamp = - Result.value - next_level_timestamp - ~default: - (WithExceptions.Result.get_ok - ~loc:__LOC__ - Timestamp.(header.timestamp +? minimal_block_delay)) - in - Ptime.diff - (Time.System.of_protocol_exn next_level_timestamp) - (Time.System.now ()) - - let check_fee_parameters {fee_parameters; _} = - let check_value purpose name compare to_string mempool_default value = - if compare mempool_default value > 0 then - error_with - "Bad configuration fee_parameter.%s for %s. It must be at least %s \ - for operations of the injector to be propagated." - name - (Configuration.string_of_purpose purpose) - (to_string mempool_default) - else Ok () - in - let check purpose - { - minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee = _; - fee_cap = _; - burn_cap = _; - } = - let open Result_syntax in - let+ () = - check_value - purpose - "minimal_fees" - Int64.compare - Int64.to_string - (Protocol.Alpha_context.Tez.to_mutez - Plugin.Mempool.default_minimal_fees) - minimal_fees.mutez - and+ () = - check_value - purpose - "minimal_nanotez_per_byte" - Q.compare - Q.to_string - Plugin.Mempool.default_minimal_nanotez_per_byte - minimal_nanotez_per_byte - and+ () = - check_value - purpose - "minimal_nanotez_per_gas_unit" - Q.compare - Q.to_string - Plugin.Mempool.default_minimal_nanotez_per_gas_unit - minimal_nanotez_per_gas_unit - in - () - in - check Transaction fee_parameters - - let checks state = check_fee_parameters state - - let get_balance_mutez cctxt ?block pkh = - let open Lwt_result_syntax in - let block = match block with Some b -> `Hash (b, 0) | None -> `Head 0 in - let cctxt = - new Protocol_client_context.wrap_full (cctxt :> Client_context.full) - in - - let+ balance = - Protocol.Alpha_services.Contract.balance - cctxt - (cctxt#chain, block) - (Implicit pkh) - in - Protocol.Alpha_context.Tez.to_mutez balance -end - -let () = register_proto_client Protocol.hash (module Proto_client) diff --git a/src/proto_020_PsParisC/lib_plugin/index.mld b/src/proto_020_PsParisC/lib_plugin/index.mld index d538be62be2e..347270167708 100644 --- a/src/proto_020_PsParisC/lib_plugin/index.mld +++ b/src/proto_020_PsParisC/lib_plugin/index.mld @@ -4,10 +4,7 @@ This is a package containing some libraries related to the Tezos 020-PsParisC pr It contains the following libraries: -- {{!module-Tezos_baking_020_PsParisC}Tezos_baking_020_PsParisC}: Base library for `tezos-baker/accuser` -- {{!module-Tezos_baking_020_PsParisC_commands}Tezos_baking_020_PsParisC_commands}: Protocol-specific commands for baking - {{!module-Tezos_client_020_PsParisC}Tezos_client_020_PsParisC}: Protocol specific library for `octez-client` -- {{!module-Tezos_dal_020_PsParisC}Tezos_dal_020_PsParisC}: Protocol specific library for the Data availability Layer - {{!module-Tezos_layer2_utils_020_PsParisC}Tezos_layer2_utils_020_PsParisC}: Protocol specific library for Layer 2 utils - {{!module-Tezos_protocol_plugin_020_PsParisC}Tezos_protocol_plugin_020_PsParisC}: Protocol plugin - {{!module-Tezos_protocol_plugin_020_PsParisC_registerer}Tezos_protocol_plugin_020_PsParisC_registerer}: Protocol plugin registerer diff --git a/src/proto_020_PsParisC/lib_sc_rollup_node/dune b/src/proto_020_PsParisC/lib_sc_rollup_node/dune index bd2ec4bb34f7..483bd42a7bd8 100644 --- a/src/proto_020_PsParisC/lib_sc_rollup_node/dune +++ b/src/proto_020_PsParisC/lib_sc_rollup_node/dune @@ -11,7 +11,6 @@ octez-shell-libs.client-base octez-shell-libs.client-base-unix octez-protocol-020-PsParisC-libs.client - octez-protocol-020-PsParisC-libs.dal octez-libs.tezos-context.encoding octez-libs.tezos-context.helpers tezos-protocol-020-PsParisC.protocol @@ -54,7 +53,6 @@ -open Tezos_client_base -open Tezos_client_base_unix -open Tezos_client_020_PsParisC - -open Tezos_dal_020_PsParisC -open Tezos_protocol_020_PsParisC -open Tezos_protocol_plugin_020_PsParisC -open Tezos_protocol_020_PsParisC_parameters diff --git a/src/proto_020_PsParisC/lib_sc_rollup_node/test/dune b/src/proto_020_PsParisC/lib_sc_rollup_node/test/dune deleted file mode 100644 index fb91e6fd75ff..000000000000 --- a/src/proto_020_PsParisC/lib_sc_rollup_node/test/dune +++ /dev/null @@ -1,49 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_020_PsParisC_lib_sc_rollup_node_test_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - bls12-381.archive - octez-rust-deps - octez-libs.base - tezos-protocol-020-PsParisC.protocol - octez-libs.test-helpers - octez-protocol-020-PsParisC-libs.smart-rollup-layer2 - octez_smart_rollup_node_PsParisC - octez-alcotezt) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Tezos_base.TzPervasives - -open Tezos_protocol_020_PsParisC - -open Tezos_test_helpers - -open Tezos_smart_rollup_layer2_020_PsParisC - -open Octez_smart_rollup_node_PsParisC - -open Octez_alcotezt) - (modules serialized_proofs test_octez_conversions)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_020_PsParisC_lib_sc_rollup_node_test_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package tezos-sc-rollup-node-test) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe} /flaky /ci_disabled))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_020_PsParisC/lib_sc_rollup_node/test/serialized_proofs.ml b/src/proto_020_PsParisC/lib_sc_rollup_node/test/serialized_proofs.ml deleted file mode 100644 index 8ca3226daeb1..000000000000 --- a/src/proto_020_PsParisC/lib_sc_rollup_node/test/serialized_proofs.ml +++ /dev/null @@ -1,121 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 proofs : string list ref = ref [] - -(* Each serialized proof is added to the list with a side effect, so that it is - easy to generate (or augment) this file by instrumenting the rollup node. *) - -let () = - proofs := - "0000007b030002db10db4d3b595f59e0b53740f164bf951bcfae9e0873fd23fbce82fac4f404e1126f1b6c5546a5aeff4f59893ab63211a80e6f88e11b67339186109bf569d74a820b626f6f745f736563746f72c8baff5f78423676a25d9cd27a412dd932327b9b3e1cc26e754a36410a5efbf7b406737461747573c0010000" - :: !proofs - -let () = - proofs := - "000001e2030002dff7b99fc09bd426898107f2a430633c61dde3863a0e29a795826f064d838b4a344b4f2d13d32e6bf10caf9a59ed667666d644bff87fb5ce85243fe46a62d0d400110007c094fb4ab02d1eaeebb21ddb7da4996ab4663db3e1d7b227f2c501aa13ced50e300004c003c40612363f2296a21ab5f72bd8106d16f1189d2512533c14fe023fe2a9505b8204636f6465d04e8c2629e50b60cab76e6c91232e771d142ebcb0467889de40e2a27c168a5591086d65746164617461c01901073e4cb15d82dc12ed63e0f86679a085a8bb3d9400000002000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00176820b626f6f745f736563746f72c8baff5f78423676a25d9cd27a412dd932327b9b3e1cc26e754a36410a5efbf7b418696e7465726e616c5f6d6573736167655f636f756e746572c00106810d63757272656e745f6c6576656cc0040000000400050003810f6d6573736167655f636f756e746572c00201078206737461747573c001010476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765edc04203ac25917e1d6ded20b0a57bab57da15ba6edfaa63b5c885c2c9985ddc2265ff0000000004070000027b0000020d11e1cf8d8d6637edc27e04a3b6861fbc06336c950314d2f0be3a19bebdd873f47400000012000000607e9df5467aa1c14b8482c20a3e29168879697801892fbb1e896a89904ec1705fc999d259dc5ef030f190d45cfd7e4e503b2b2cad3bbd87b7f481dedbb3bf077fc999d259dc5ef030f190d45cfd7e4e503b2b2cad3bbd87b7f481dedbb3bf077f0f868a1d495f0e46265daaf4edfcc451fdd0e4d178c96807f775b68686e4b6c3ad0000001000000040c8e206c6092f3b50cef178a5ca373722684bf1d4bc4e6a3cf6f18ec8977c4f9ff7f922f475e8ee6eec9078395a379a2a1b905caefc92c75e9d474b8ff7f421440b0bd6c62766cfb2a314d827cead108848c389a9f7d824f5b6baa6920d74757b590000000c0000004020911b9f0a604aa0a669c82cca6015a73e06da67790efc1622e905d3cc7deb0441be5bf60ef04d6806f946483d16974c847e13696b97a5c57679e77bb43ebd520750eb5f108b13387d9bf493d38655d4e49e92958b296b50e11c91ecc37338f0240000000800000040f624258bca6f66863aa5dc00d781a68d01617a4e57c7eeb571586cfd5d4fa42feceb7013cb9a3709f1fabd85eeb1d29f94f01fae86ea1bd48b96d9dc5f2c6e06037aea153e62097eb669959c79ba91e715db84e411ffffee26ee17415e14f9adaf000000040000002033a66cd216417b22be5ff5b40a2884efd21b41ba30710151c8c8b631f78d872900000065078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f5312890000000406aa2f7281c84f94013408e9be51c00f0c269a9e0168bc4e1487f8bd158712b2a0223eb4ac4e1f8d91f67b451f8368483543437958eb47c656650b141eff001d300" - :: !proofs - -let () = - proofs := - "000001e2030002dff7b99fc09bd426898107f2a430633c61dde3863a0e29a795826f064d838b4a344b4f2d13d32e6bf10caf9a59ed667666d644bff87fb5ce85243fe46a62d0d400110007c094fb4ab02d1eaeebb21ddb7da4996ab4663db3e1d7b227f2c501aa13ced50e300004c003c40612363f2296a21ab5f72bd8106d16f1189d2512533c14fe023fe2a9505b8204636f6465d04e8c2629e50b60cab76e6c91232e771d142ebcb0467889de40e2a27c168a5591086d65746164617461c01901073e4cb15d82dc12ed63e0f86679a085a8bb3d9400000002000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00176820b626f6f745f736563746f72c8baff5f78423676a25d9cd27a412dd932327b9b3e1cc26e754a36410a5efbf7b418696e7465726e616c5f6d6573736167655f636f756e746572c00106810d63757272656e745f6c6576656cc0040000000400050003810f6d6573736167655f636f756e746572c00201078206737461747573c001010476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765edc04203ac25917e1d6ded20b0a57bab57da15ba6edfaa63b5c885c2c9985ddc2265ff0000000004070000027b0000020d118c4447d72cefb932b0ca79afe7e83680a3f5f940af12e510130890de093704e600000012000000608dfebf6bc80d3a6576db8bc05fdca115f1792bc708889f6c1e426a8fba62e41aec379b342e355104630c030f9fcdb2b45c8c1095ab4009aca365bceadabdcfb3ec379b342e355104630c030f9fcdb2b45c8c1095ab4009aca365bceadabdcfb30fbb838b70dafcb73c9fa937401a6b33dd4da8bfb1cc13518986029bd37814e280000000100000004069ef7e20a1f91d679504ab5a48899eec79e079a45f91939f0221a7a508358ef290e46fb7603c1723c2f698460a79f1e9642c1169fa2958961a87a74b9ff9e6430b480a065cd7198a5dc043acedef20e46dc7920c8592cca659cd961f5ea1dd90f00000000c000000406d802c5daf40c7215b73280efba85f67f0cc5747fcd2a0fe2328b5fdc252fd646920e1ffdb78b41f97546e80ad8a7287a1ba422057cad6f65c86c62a472aacfd0787e2b620f5c09d654e85e713d546450d660fc4988c658ddd3914d4bfc699d5cf000000080000004081b3c6ca730810be90b2f5ae9c4886e511f31933be84c0ac30af3b49b61fcdbfca6edbc188119ab8cf16b9e116af5f5a1de725fbaff2804f2508262b8d5dbc5a0347b79ca5ad4b09f9d7e9ead9854c082b664e51fba5558f2830fde4a5762367410000000400000020a17b14300c882553060d2694e5189fb3d86a998504248a47f4d359a29d2d6d6d00000065078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f53128900000004086f216dfb0131becbcc6a7a7e901db744c5030d09830fa3bbd5d0690eb5e2ec36877e8620a9491faa4d1a7c14b9fa50c394d69f699d239c1dce145d86566b49c00" - :: !proofs - -let () = - proofs := - "000001e2030002d83a6fcbfa317ba868d42fae27ddce20ad903cbb357a1b16823a14bce0631d733bdcad893d1ec690f5e7f44b73cc9e7a9119eda7942d6776b70b02b8276cdfcb00110007c0f16246649211503c309f0679ac228a4c510e90cf699d0dd1c71123465e3b1f340004c003c40612363f2296a21ab5f72bd8106d16f1189d2512533c14fe023fe2a9505b8204636f6465d04e8c2629e50b60cab76e6c91232e771d142ebcb0467889de40e2a27c168a5591086d65746164617461c01901073e4cb15d82dc12ed63e0f86679a085a8bb3d9400000002000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00179820b626f6f745f736563746f72c8baff5f78423676a25d9cd27a412dd932327b9b3e1cc26e754a36410a5efbf7b418696e7465726e616c5f6d6573736167655f636f756e746572c00109810d63757272656e745f6c6576656cc0040000000500050003810f6d6573736167655f636f756e746572c00201078206737461747573c001010476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765edc04203ac25917e1d6ded20b0a57bab57da15ba6edfaa63b5c885c2c9985ddc2265ff0000000005070000036d000002ff11fc6cf0426308d2bffb18bf2b478124887feabcb245cd6b0b9e129588192a54c40000001200000060b12f07c7d9af455f96ddc30c0006cae6a47d4012a1d9ee52381a6ac466b90282a6d0f8cd48d167078b8277d8ea52a7a2b289c1cd57253953d8152987bf527508a6d0f8cd48d167078b8277d8ea52a7a2b289c1cd57253953d8152987bf5275080f064a0994f5eb055ea8e9611989f2af420bbfd91b1114f92f2bc12fe6b7a0cf0e00000010000000406036dc7a4a6e3dd4d7c53e1d31f3ca11949539681aef75c98a1a6e99e5c8023389e71f2788c0928cf48c78e78f4262386d05c26b7afd22a9e8b825bb2641d8140b687657f959d8f4d09d4a5d0dc02a92fad1d4c0c1834cfa52de824c68b71e82220000000c0000004099e839e62f772ca0b40026794b9e375dc254545aa597b3ac92f5769b64be931b59946ddfb2e26dd43fb1b183e13a0676055bdc96c9afec634562f967c16b17a3078d3709187faab160b53420e44f31bf89247940d19c42e0ffb8f741c31eedf49f0000000800000040d02e518af31bb716c6c2b217d488f919a9c358985585a9bc36764e49b1a06d83787ada119155f533cfd8ae0dcf26eee797ad414c4a9cfd77e5bfb25ad9db49180646d0cfe6a53bd991515525f0b69234f6bd255e13f2268b0e7056cc9749fe96a80000000700000040641a59b4d74772af88bd26b01930fdc833e4da32a6a8b134a83eefd5a891c67f787ada119155f533cfd8ae0dcf26eee797ad414c4a9cfd77e5bfb25ad9db491805e3292cfbce3f99c456c357448caf12dbb8d94ae727713e76204070ee7f93ec6f000000060000004025cc6a901f1677467a5effacdbea5918e4fe1db847ca23aa2d32a6009f4e49c3787ada119155f533cfd8ae0dcf26eee797ad414c4a9cfd77e5bfb25ad9db491804440a917893d879e6d120791d6f3686ef0e138f1aafa4218b9f2986f3e6fa83c20000000500000040787ada119155f533cfd8ae0dcf26eee797ad414c4a9cfd77e5bfb25ad9db4918787ada119155f533cfd8ae0dcf26eee797ad414c4a9cfd77e5bfb25ad9db491800000065078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f531289000000040d5177419909a1fbbf44e4d765d6fb055eade688bab86c66f22464dc90d9646a9136cb726c83432b2cf178eb3b1a1c32245d8b30adcc01468dfdd84665824dbb900" - :: !proofs - -let () = - proofs := - "000001e3030002dcfa6603288699daee959046196b807c6802422775a28aefa8955743b22be772b65ed549e8fc86fd1b0e4bfc2fe2e3562fa78bca93b48a46450d259daead220400110007c001fdc52ab8835ab29356f398abd306ece6190f2832649449a075fa02873be7870004c073b11921186a3ad9f169f3ce0b2f80b767ad931ff6e7828e8992ba73b3e72b918204636f6465d04e8c2629e50b60cab76e6c91232e771d142ebcb0467889de40e2a27c168a5591086d65746164617461c01901073e4cb15d82dc12ed63e0f86679a085a8bb3d9400000002000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc002b901820b626f6f745f736563746f72c8baff5f78423676a25d9cd27a412dd932327b9b3e1cc26e754a36410a5efbf7b418696e7465726e616c5f6d6573736167655f636f756e746572c00112810d63757272656e745f6c6576656cc0040000000800050003810f6d6573736167655f636f756e746572c00201078206737461747573c001010476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765edc04203ac25917e1d6ded20b0a57bab57da15ba6edfaa63b5c885c2c9985ddc2265ff00000000080700000232000001c411de172a5abce9a9a316b4d55bddb1f6208bd58546a42224aae7afe87e75103fbe00000012000000600babc274ae5da75f613af0b96c064841dc055fb086c7aee7c5cf59afc7a3c5eadda87e4df1828b9f40e4b3ddcb69903f1eceed5b45f796d5793a2406fc77a1e8dda87e4df1828b9f40e4b3ddcb69903f1eceed5b45f796d5793a2406fc77a1e80f96b234fd8fb7e2b70e9a773d91932d11a8cd2f58c5cff42f7756b4ae5982d2b00000001000000040a21c42cf974f22f9eeddc1cca859cee5e7e74a1d98571b4a48e78a70c867d1e99ae8cd149c8d4389f819cd04167e27b5339537f99a0ec1821b6fff92a92659130b29a8d6c8b6b112bb72dd52f8d68224a240340ebc707053997e1d140cc1625b090000000c00000040b982ce951ef7e4ddca7c1b9371d3dfc7840c1a5b661cdf28d0a727d3a34055fc2ddf903372525d24bca2cb46409f65960a1bb7dec7d4d3cf6107e6bed52c5a62079e4bad092eecab56a6945c7223ec0c7622d91724b7a26106b9bf3efbb0285e960000000800000040803d9fb1c0a3d81cc4806db2b519321bc7873a5e44dcc10f5948b47fc05ff827b0a464db5c39fe5809e2509465b36c17e24c18458175551c746256f129c6882000000065078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f5312890000000402f0b8c5524863a7d8b851a05f51888de954fd75bdb39638fba73bee6cd9f848238b7acf195d72a42ce6594d54911c2d544f581288c71502550916a1a32088f4100" - :: !proofs - -let () = - proofs := - "00000214030002e077bef17af38499b44807fabde3837e2355f4988146b065236bac172087929e24bc4324adefe61ff70a912adfce146400586b408d46b371c287b5df9fcdba4000100006d0030170000382066f7574707574d033ba419fa9cc8b769d0a76f2839bdaee68f7e12566131d1edbebaaa1e12169900c7061727365725f7374617465c00102c0fca618d8cfb53c29e8b61bcf584028571b6b1f563e164df093810f07a93265060003820c6e6578745f6d657373616765c0060100000001310e6f75747075745f636f756e746572c00102c0322d95cbadd30a23603872646abd7b0d341c5f3eca8f39da9da74bd3264d9775000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00179c03b85b8bcac7168100efeb43114a4679d17808ab9309d16a22be916283fbde863c0d22ceeb53dad5d5a36f1caca13fb2cce988bed6679f7370d0d2e5aa042c6556c00050003c0cb0d5024ea71731c4142bd8b8ce738c9d44298b45ccc3d4fc2717db8d4eb78068206737461747573c001040476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c00800000000000000000e70617273696e675f726573756c74c87a31b1c8e3af61756b336bcfc3b0c292c89b40cc8a5080ba99c45463d110ce8b00" - :: !proofs - -let () = - proofs := - "000002a7030002d918c66aa95d5080874df90faea75962fc4a4443996f8a6be3996739f9a2008804940e7d9453c3a83f99858741988f1b5056f21295ae698df95731c1ca00d70a00110007d0030170000382066f7574707574d0772e6802b1bb0a8f0553b122347b071e426307db4a54ca247a479f51d20c91170c7061727365725f7374617465c00101c0bf2d23e703638502856d46d16407070d7c47a5af5f5e33daa4d46a2d311eba870004820c6e6578745f6d657373616765c8794bebd4366203e527989fc7421c01bfc2976975f118a341ac007b5e0f53a1180e6f75747075745f636f756e746572c88a7ae305885619a2566d1c7fd87e3d67444fb5ce517a8fca5bee68a4061997ed8204636f6465d04e8c2629e50b60cab76e6c91232e771d142ebcb0467889de40e2a27c168a5591086d65746164617461c81bd59bb6258d782bad96d2164548403ee6b50359b81a885f3e11b988dfafe3ae000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc002ec01820b626f6f745f736563746f72c0040000000018696e7465726e616c5f6d6573736167655f636f756e746572c896f1f45bb65c0c32557f9a65d161156b248f2a1e62e1678892300949bd0589a2810d63757272656e745f6c6576656cc0040000000700050003810f6d6573736167655f636f756e746572c00201018206737461747573c001010476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c8a8b484dd0c8b746c1a15618f6fb51a7b37f8c275afc6499d9c524fa0fbb743cc0e70617273696e675f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905ff0000000007010000032b0000022d112216fa511da8cf0ef50a29f5990dc65135aa9a72d1a686b2f1aba0bbdc1710f100000012000000608e03cd7fd0e4aafdb620093525a182431bc198b0ef56218f6e4d1253787df95c4f152285b05c88d8cbd414385df68dc0038a0949a6a2150a5835b64f620225404f152285b05c88d8cbd414385df68dc0038a0949a6a2150a5835b64f620225400f7c5d2e20abd394499b89ff0f01f8ca785cd4b83ac033a2b72bf6fc3ff6f72b76000000100000004030548b2d65eed411aab93a1050898da8b6560560efdeb6f5352ce25edf8990a1033e7e19ba33f12cc42a917f19767d2b0e9517855f905ce9f9b03edc4716511a0be7bc438063c29553e43fc7e0ad8672f2e47bac5622849003df6b29b11a01d4250000000c0000004003ad25557b67a5b5b0d5f484d69b5639d49290e57edbbcfab845a44c6d3caccaccc0ac98c43158ffc5dc55d3370c6a0d95e6f282b3f5c6c9bf924803f603636207797fef9633643ebdee8710d2481f2fe58af4201ef62570c79c1370f48108b5940000000800000040b69cf6e3364934b1d8e2f45152c899f1f787713d362b2d0962e5d2ed603b56f1722208556ce9c4cdffc91825b29d757bd81ef39b074b03b0afb5f9dd6f5601ee06c14c15749c2323c5571de585825120b0fcd8eaeffdbb3f38908581308d0312170000000700000040eabbe433d155ea8739a38e9c24bcfc7e23f4f3d69bdc9bdcb75ed722a605aa8a722208556ce9c4cdffc91825b29d757bd81ef39b074b03b0afb5f9dd6f5601ee000000ef078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f5312890000000401fb49ce2d7b7e3be61d2b4ca1774aa4740a1e1d12413f4a2a7597a9374645d422c20099c6029bbaa5a7cdeec1e3ddddbc5e4630af0ba11554535f657c27e38de035efc3165465aff68d3e5bd549d711f9e0e06e786bc1d6873f2e7e4faa43bbe130000002030cc84dad07aa536dbaaaccba95d4dabd7c5d6c6ca411372ca9326afeae3eed30228a91be1e75d0b3a4f6634ffbe25947d0bd042d41d1ab2f2a2a7d81b564312c000000020b384576e8dfeacafe447c7555442ed6057ec637adc6d72a1863b5e6a8094adf8ff000000020131" - :: !proofs - -let () = - proofs := - "0000021503000204940e7d9453c3a83f99858741988f1b5056f21295ae698df95731c1ca00d70aeb9288624e864a8aeecbb882b30fa04c28830cd6331d1697fd6d78570a47f43e00100006d0030170000382066f7574707574d0772e6802b1bb0a8f0553b122347b071e426307db4a54ca247a479f51d20c91170c7061727365725f7374617465c00102c0bf2d23e703638502856d46d16407070d7c47a5af5f5e33daa4d46a2d311eba870003820c6e6578745f6d657373616765c0060100000001310e6f75747075745f636f756e746572c00104c0322d95cbadd30a23603872646abd7b0d341c5f3eca8f39da9da74bd3264d9775000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc002ed01c052c196fbe4546e163fd1d777dfb388cece157a88fe10cc0e1ae48aa053fac3fec0e0590ca6ea22f7dabe3889c02d87873535203b5a450ef9e5ce102d2f99d8c0b800050003c0cb0d5024ea71731c4142bd8b8ce738c9d44298b45ccc3d4fc2717db8d4eb78068206737461747573c001040476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c00800000000000000000e70617273696e675f726573756c74c87a31b1c8e3af61756b336bcfc3b0c292c89b40cc8a5080ba99c45463d110ce8b00" - :: !proofs - -let () = - proofs := - "00000215030002f677d054c8e623d1b22ecc8aea74f5074bf0c9529f898cac90db26a3992831d77b74a66258cc09c792da869b9b3bc683e35d9583c4206adc20d3b0296245408a00100006d0030170000382066f7574707574d0d5983c50395ec6533657eccf10ccf8d9c4062ff6501c2074868953ffee9073830c7061727365725f7374617465c00102c0bf2d23e703638502856d46d16407070d7c47a5af5f5e33daa4d46a2d311eba870003820c6e6578745f6d657373616765c0060100000001310e6f75747075745f636f756e746572c00104c0322d95cbadd30a23603872646abd7b0d341c5f3eca8f39da9da74bd3264d9775000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc002f301c01c1fab5de0181afb420733a2d6b0a12ce0b70c494b7dfccff1e2447eee86380fc04607fa9b3ac608330ef58339fb3dc505880bae0b9fae4f3f10ff9f8534a3856a00050003c0cb0d5024ea71731c4142bd8b8ce738c9d44298b45ccc3d4fc2717db8d4eb78068206737461747573c001040476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c00800000000000000000e70617273696e675f726573756c74c87a31b1c8e3af61756b336bcfc3b0c292c89b40cc8a5080ba99c45463d110ce8b00" - :: !proofs - -let () = - proofs := - "00000214030002e077bef17af38499b44807fabde3837e2355f4988146b065236bac172087929e24bc4324adefe61ff70a912adfce146400586b408d46b371c287b5df9fcdba4000100006d0030170000382066f7574707574d033ba419fa9cc8b769d0a76f2839bdaee68f7e12566131d1edbebaaa1e12169900c7061727365725f7374617465c00102c0fca618d8cfb53c29e8b61bcf584028571b6b1f563e164df093810f07a93265060003820c6e6578745f6d657373616765c0060100000001310e6f75747075745f636f756e746572c00102c0322d95cbadd30a23603872646abd7b0d341c5f3eca8f39da9da74bd3264d9775000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00179c03b85b8bcac7168100efeb43114a4679d17808ab9309d16a22be916283fbde863c0d22ceeb53dad5d5a36f1caca13fb2cce988bed6679f7370d0d2e5aa042c6556c00050003c0cb0d5024ea71731c4142bd8b8ce738c9d44298b45ccc3d4fc2717db8d4eb78068206737461747573c001040476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c00800000000000000000e70617273696e675f726573756c74c87a31b1c8e3af61756b336bcfc3b0c292c89b40cc8a5080ba99c45463d110ce8b00" - :: !proofs - -let () = - proofs := - "00000214030002e077bef17af38499b44807fabde3837e2355f4988146b065236bac172087929e24bc4324adefe61ff70a912adfce146400586b408d46b371c287b5df9fcdba4000100006d0030170000382066f7574707574d033ba419fa9cc8b769d0a76f2839bdaee68f7e12566131d1edbebaaa1e12169900c7061727365725f7374617465c00102c0fca618d8cfb53c29e8b61bcf584028571b6b1f563e164df093810f07a93265060003820c6e6578745f6d657373616765c0060100000001310e6f75747075745f636f756e746572c00102c0322d95cbadd30a23603872646abd7b0d341c5f3eca8f39da9da74bd3264d9775000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00179c03b85b8bcac7168100efeb43114a4679d17808ab9309d16a22be916283fbde863c0d22ceeb53dad5d5a36f1caca13fb2cce988bed6679f7370d0d2e5aa042c6556c00050003c0cb0d5024ea71731c4142bd8b8ce738c9d44298b45ccc3d4fc2717db8d4eb78068206737461747573c001040476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c00800000000000000000e70617273696e675f726573756c74c87a31b1c8e3af61756b336bcfc3b0c292c89b40cc8a5080ba99c45463d110ce8b00" - :: !proofs - -let () = - proofs := - "000001af03000203fad519c60ce458d8173d60347a7165a47f94f34bb09563e3f916508a568ae5160daf16732031127d85916da8a2b2ed0b80e2ec6f76aeb5aed05f20e29535aa0005820764757261626c65d0700600b5ba8846f05688abbc84be210e9841df14210b69ecc81768bc2d7fa5be03746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00100196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e707574820468656164c00100066c656e677468c00100066f7574707574820133810f76616c69646974795f706572696f64c00400013b000134810d6d6573736167655f6c696d6974c002a401047761736d00038103746167c00b00000007636f6c6c656374820c63757272656e745f7469636bc001000e7265626f6f745f636f756e746572c002e907ff02" - :: !proofs - -let () = - proofs := - "000004a20300029154c3457e545055d89ece682b7699aa6468646bc118d31183e606af03c8720d8fdb2e43063ba2e4eb6227939439718b119ff743d5c7f1c0cb53efca9290cebd0005820764757261626c65d0700600b5ba8846f05688abbc84be210e9841df14210b69ecc81768bc2d7fa5be03746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00100196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e747300040003c0a06eb14bc76138f3404aa3d1907e8ea56cdcab66fd9774fa42ceb0b5db70f3678101330004810f6d6573736167652d636f756e746572c00103000381066c656e677468c00800000000000000028208636f6e74656e7473810130c102000131000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000097261772d6c6576656cc00400000003810131d02be9203590ff323f40bb2e6123792ea6fe582c3004e90f2f07e341c357bb256f066c656e677468c00104066f75747075740004820132810a6c6173745f6c6576656cc004000000030133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d085c221543585cc73785d90b8205fb70e0ff5fb3ec7cfb237c9de35507cdb04f70134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000030303746167c00b00000007636f6c6c656374820c63757272656e745f7469636bc001040e7265626f6f745f636f756e746572c002e907ff000000000303000003fd00000256119e0f517b258ebaafc3b80f9580736196820e85a89a8b1dbcabc188dffb3c202e00000012000000609d64ecb31e24cbae9bffefb6398aeddbf63848d77a09f8abe6ec870520e52824f5ac4a20922d7f69815f53f2bc1d7e814237f7671dddb9b1da294c2dfc4c71def5ac4a20922d7f69815f53f2bc1d7e814237f7671dddb9b1da294c2dfc4c71de0fb08d67fcd4ee0d497ddf6d75ac8e18dc4828b7eaa24c9bab0d177ef15c0042f100000010000000403918d146062923546523ea77f9f279659b3ef195d3b078438f982c027b1d8917a9d39f2691329b1c8c9f7d42b4ebb7dafd332674e52f8abe2a1ab969e64e2fe50b7a898bab55e92ba1d139db2630c207cf08d698cd0a45b87d4f31ad0f863208db0000000c0000004007f78428e527a26c52b3663fe94540c0dcebc5c06812ac73483dc9e163aba6054734bbd10c6f776cfc899e2ed68c9922c46761ddaef39a7d6ad74f51db9a6ba007c33fc08871ca22ec9f40c437074d7c036c0f7f73847d1c06c9a17e1996b7d9440000000800000040b9229c6473b0774f80374639e5a5d67d9cf2a44a3791e716cd9c344158f95d43d1bd41e8f0d23a94f58094dfdd6138fd1789f68a675fac5315ed813d38fa5b9e0364a4a59f6b439e7e70cc6a3db142f3389ebe3c825c0e6415880ce60e4983db260000000400000020426a3cc0ad6a52091e3d0e0db02ee1fcd56f50c46b7d292502485c175d63c9b9020a5f043148e900d19d02f79abf24b4bd582f6e93abfb9bd8c988eaf75408af3a0000000300000020ed9e0e19c20a3b721dab18672f6970178470220ead77baa226397a08bd7e876b00000194078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f531289000000040157503c39a941b28605440c02809ba0c46e7d2f467898c8fb686ce2f3b2468734dd4e700aae1d5046368abd3874e2381a67183a76ee0c0d4470980a6b26c963006a1d6ed77f0922b69266702ace9a97f218b0b5d575e2bbe6a6b01b9412d8c58a000000040c8f36f8363b363b45329f572116fba1982f4d2d733dc6f8088ff3a0157b931874dd4e700aae1d5046368abd3874e2381a67183a76ee0c0d4470980a6b26c963005474c297bef20ab15fb8d93783d324d6f07fb1a017891890f3b606bac241f144c000000400a5735bc6db3536eba3b549320c870fd51ee99747f79d5702cb3c5982224d3ec4dd4e700aae1d5046368abd3874e2381a67183a76ee0c0d4470980a6b26c9630045efc3165465aff68d3e5bd549d711f9e0e06e786bc1d6873f2e7e4faa43bbe13000000404dd4e700aae1d5046368abd3874e2381a67183a76ee0c0d4470980a6b26c96304dd4e700aae1d5046368abd3874e2381a67183a76ee0c0d4470980a6b26c9630ff00000006013120312078" - :: !proofs - -let () = - proofs := - "000004a2030002833ec3c4a0325b95cebe5505e305cc43ff64e52411b9363fe287f55b2dbd84d5499a79571ba2d9e172052e13d1eac510810ac4eca1d5157a65782d50a84b34690005820764757261626c6582066b65726e656cd07d20c53bdd5b536a6be9c4cdad16e69a9af40b93a6564655fffd88bba050519008726561646f6e6c7982066b65726e656cd0a645771d9d5228a31312b282119c596699ccb6b60b93d759c2072a493ddbb5740c7761736d5f76657273696f6e8101408208636f6e74656e7473810130c10200322e302e302d7231000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000066c656e677468c008000000000000000803746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00680f8e0cde105196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e7473d029ca9b037bc58b2e8795cb5a78a9923e992ecb747d73aea69221f0bbf8862d9c066c656e677468c00108066f75747075740004820132810a6c6173745f6c6576656cc004000000050133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d012db3a74b0a7328b572a034fb36111e11ca8db9beeee251c1b636e62b1a369500134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000050703746167c00b0000000770616464696e67820c63757272656e745f7469636bc00688f8e0cde1050e7265626f6f745f636f756e746572c002e90700" - :: !proofs - -let () = - proofs := - "000004a2030002b45db06e873356846dc9bec6df51256edf0ede76c2c4c1fb856ff62a1dd3a71bb4591da0e6a078af531c232280cb8e68554a1879eb6a9e4308c006395fa45d770005820764757261626c6582066b65726e656cd07d20c53bdd5b536a6be9c4cdad16e69a9af40b93a6564655fffd88bba050519008726561646f6e6c7982066b65726e656cd0a645771d9d5228a31312b282119c596699ccb6b60b93d759c2072a493ddbb5740c7761736d5f76657273696f6e8101408208636f6e74656e7473810130c10200322e302e302d7231000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000066c656e677468c008000000000000000803746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00680f0c19bc30b196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e7473d06a600b954d7302fba4b55875e6025671f6e6364ed0514556b0554107b4c2d245066c656e677468c00108066f75747075740004820132810a6c6173745f6c6576656cc004000000070133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d0652e374ff90771cb8ec84a7106d62b8cf29b46632699c378aec1afc4aceb3d960134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000070703746167c00b0000000770616464696e67820c63757272656e745f7469636bc00688f0c19bc30b0e7265626f6f745f636f756e746572c002e90700" - :: !proofs - -let () = - proofs := - "000004a203000298c8c12aa31ddb519d4848eca5b5faafafb686fc18232a7af3b9738eedbbf18b1b7a054f5dff5ac3a71c5b54d284633aa8390b7bcfcaad9f6cfab30466dc499c0005820764757261626c6582066b65726e656cd07d20c53bdd5b536a6be9c4cdad16e69a9af40b93a6564655fffd88bba050519008726561646f6e6c7982066b65726e656cd0a645771d9d5228a31312b282119c596699ccb6b60b93d759c2072a493ddbb5740c7761736d5f76657273696f6e8101408208636f6e74656e7473810130c10200322e302e302d7231000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000066c656e677468c008000000000000000803746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00680f0c19bc30b196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e7473d095d3888221e81b7ccc795571fe150fca0b0b4f8fa6439bc3ad441f6677aa4238066c656e677468c00108066f75747075740004820132810a6c6173745f6c6576656cc004000000070133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d0652e374ff90771cb8ec84a7106d62b8cf29b46632699c378aec1afc4aceb3d960134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000070703746167c00b0000000770616464696e67820c63757272656e745f7469636bc00688f0c19bc30b0e7265626f6f745f636f756e746572c002e90700" - :: !proofs - -let () = - proofs := - "000004a20300029287c2d0b68cd84c11b0950becf1f954cd26ea6661ce417ee1e871c85d42744a29e1c7e29367c4b40f7d63966bf15195f125a711a800b82f646cd7acc2ef818f0005820764757261626c6582066b65726e656cd07d20c53bdd5b536a6be9c4cdad16e69a9af40b93a6564655fffd88bba050519008726561646f6e6c7982066b65726e656cd0a645771d9d5228a31312b282119c596699ccb6b60b93d759c2072a493ddbb5740c7761736d5f76657273696f6e8101408208636f6e74656e7473810130c10200322e302e302d7231000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000066c656e677468c008000000000000000803746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00680f0c19bc30b196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e7473d09488f46e420b9e6a86886b62f56f5be815250291de20e0bb901503c473029a24066c656e677468c00108066f75747075740004820132810a6c6173745f6c6576656cc004000000070133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d0652e374ff90771cb8ec84a7106d62b8cf29b46632699c378aec1afc4aceb3d960134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000070703746167c00b0000000770616464696e67820c63757272656e745f7469636bc00688f0c19bc30b0e7265626f6f745f636f756e746572c002e90700" - :: !proofs - -let () = - proofs := - "000004a20300026c04959b2eeb9719f2fff009b30b1a3e056b2e303e00f30c6fa25649b2db6b6aa82b2e3cf2f36f0dbf44209528859e2ae36f77fc4cc844c91ec349a64e6f2c4f0005820764757261626c6582066b65726e656cd07d20c53bdd5b536a6be9c4cdad16e69a9af40b93a6564655fffd88bba050519008726561646f6e6c7982066b65726e656cd0a645771d9d5228a31312b282119c596699ccb6b60b93d759c2072a493ddbb5740c7761736d5f76657273696f6e8101408208636f6e74656e7473810130c10200322e302e302d7231000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000066c656e677468c008000000000000000803746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00680f0c19bc30b196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e7473d02a07f402a57a796a07ac3ad8c832391cbf3b09435464e3c181c171a67ccf2dcc066c656e677468c00108066f75747075740004820132810a6c6173745f6c6576656cc004000000070133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d0652e374ff90771cb8ec84a7106d62b8cf29b46632699c378aec1afc4aceb3d960134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000070703746167c00b0000000770616464696e67820c63757272656e745f7469636bc00688f0c19bc30b0e7265626f6f745f636f756e746572c002e90700" - :: !proofs - -let proofs = !proofs diff --git a/src/proto_020_PsParisC/lib_sc_rollup_node/test/serialized_proofs.mli b/src/proto_020_PsParisC/lib_sc_rollup_node/test/serialized_proofs.mli deleted file mode 100644 index 7f39b3313c89..000000000000 --- a/src/proto_020_PsParisC/lib_sc_rollup_node/test/serialized_proofs.mli +++ /dev/null @@ -1,27 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** List of pre-computed serialized refutation proofs. *) -val proofs : string list diff --git a/src/proto_020_PsParisC/lib_sc_rollup_node/test/test_octez_conversions.ml b/src/proto_020_PsParisC/lib_sc_rollup_node/test/test_octez_conversions.ml deleted file mode 100644 index a23162821e75..000000000000 --- a/src/proto_020_PsParisC/lib_sc_rollup_node/test/test_octez_conversions.ml +++ /dev/null @@ -1,490 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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: Smart rollup node library, type conversions - Invocation: dune exec src/proto_020_PsParisC/lib_sc_rollup_node/test/main.exe \ - -- -f test_octez_conversions.ml - Subject: Ensure conversions between octez smart rollup structures and - protocol ones are bijective. -*) - -open Qcheck2_helpers -open Octez_smart_rollup - -let gen_hash ~size of_bytes = - let open QCheck2.Gen in - let gen = - let* x = bytes_size (pure size) in - return @@ of_bytes x - in - (* This is not beautiful, but there is currently no other way to - remove the shrinker. *) - make_primitive - ~gen:(fun rand -> generate1 ~rand gen) - ~shrink:(fun _ -> Seq.empty) - -let gen_address = gen_hash ~size:Address.size Address.of_bytes_exn - -let gen_state_hash = gen_hash ~size:State_hash.size State_hash.of_bytes_exn - -let gen_inbox_hash = gen_hash ~size:Inbox.Hash.size Inbox.Hash.of_bytes_exn - -let gen_commitment_hash = - gen_hash ~size:Commitment.Hash.size Commitment.Hash.of_bytes_exn - -let gen_payload_hash = - gen_hash - ~size:Merkelized_payload_hashes_hash.size - Merkelized_payload_hashes_hash.of_bytes_exn - -let gen_kind = QCheck2.Gen.oneofl Kind.[Example_arith; Wasm_2_0_0] - -let gen_level = int32_range_gen 0l Int32.max_int - -let uint64 = int64_range_gen 0L Int64.max_int - -let gen_tick = - let open QCheck2.Gen in - let+ i = uint64 in - Z.of_int64 i - -let gen_commitment = - let open QCheck2.Gen in - let* compressed_state = gen_state_hash in - let* inbox_level = gen_level in - let* predecessor = gen_commitment_hash in - let+ number_of_ticks = uint64 in - Octez_smart_rollup.Commitment. - {compressed_state; inbox_level; predecessor; number_of_ticks} - -let gen_dissection_chunk = - let open QCheck2.Gen in - let* state_hash = option gen_state_hash in - let+ tick = gen_tick in - Octez_smart_rollup.Game.{state_hash; tick} - -let gen_dissection = QCheck2.Gen.small_list gen_dissection_chunk - -let gen_proof = - let open QCheck2.Gen in - let+ hex = oneofl Serialized_proofs.proofs in - Hex.to_string (`Hex hex) |> WithExceptions.Option.get ~loc:__LOC__ - -let gen_step = - let open QCheck2.Gen in - let* what = option ~ratio:0.1 (pure ()) in - match what with - | None -> - (* shrink there *) - let+ dissection = gen_dissection in - Octez_smart_rollup.Game.Dissection dissection - | Some () -> - let+ proof = gen_proof in - Octez_smart_rollup.Game.Proof proof - -let random_seed ~rng_state = - Bytes.init Tezos_crypto.Hacl.Ed25519.sk_size (fun _i -> - Char.chr (Random.State.int rng_state 256)) - -let random_algo ~rng_state : Signature.algo = - match Random.State.int rng_state 3 with - | 0 -> Ed25519 - | 1 -> Secp256k1 - | 2 -> P256 - | 3 -> Bls - | _ -> assert false - -let gen_algo = QCheck2.Gen.oneofl [Signature.Ed25519; Secp256k1; P256; Bls] - -let gen_pkh = - let open QCheck2.Gen in - let+ algo = gen_algo in - let pkh, _pk, _sk = Signature.generate_key ~algo () in - pkh - -let gen_stakers = - let open QCheck2.Gen in - let* p1 = gen_pkh in - let+ p2 = gen_pkh in - Octez_smart_rollup.Game.make_index p1 p2 - -let gen_refutation = - let open QCheck2.Gen in - let* b = bool in - match b with - | true -> - let* player_commitment_hash = gen_commitment_hash in - let+ opponent_commitment_hash = gen_commitment_hash in - Octez_smart_rollup.Game.Start - {player_commitment_hash; opponent_commitment_hash} - | false -> - let* choice = gen_tick in - let+ step = gen_step in - Octez_smart_rollup.Game.Move {choice; step} - -let gen_inbox = - let open Protocol in - let open Alpha_context in - let open QCheck2.Gen in - let gen_msg = small_string ~gen:printable in - let* hd = gen_msg in - let* tail = small_list gen_msg in - let payloads = hd :: tail in - let* level = gen_level in - let level = Raw_level.of_int32_exn level in - let witness_and_inbox = - let open Result_syntax in - let inbox = - Sc_rollup.Inbox.genesis - ~predecessor_timestamp:Time.Protocol.epoch - ~predecessor:Block_hash.zero - level - in - Environment.wrap_tzresult - @@ - let witness = Sc_rollup.Inbox.init_witness_no_history in - let witness = - Sc_rollup.Inbox.add_info_per_level_no_history - ~predecessor_timestamp:Time.Protocol.epoch - ~predecessor:Block_hash.zero - witness - in - let* input_messages = - List.map_e - (fun msg -> Sc_rollup.Inbox_message.(serialize (External msg))) - payloads - in - let* witness = - Sc_rollup.Inbox.add_messages_no_history input_messages witness - in - return (Sc_rollup.Inbox.finalize_inbox_level_no_history inbox witness) - in - return - @@ (witness_and_inbox |> function - | Ok v -> Sc_rollup_proto_types.Inbox.to_octez v - | Error e -> - Stdlib.failwith (Format.asprintf "%a" Error_monad.pp_print_trace e)) - -let number_of_slots = 256 - -let gen_slot_index = - let open QCheck2.Gen in - let max = number_of_slots - 1 in - graft_corners (int_bound max) [0; 1; 2; max] () - -let gen_page_index = - let open QCheck2.Gen in - let max = 0xfff / 2 in - graft_corners (int_bound max) [0; 1; 2; max] () - -let gen_slot_header_commitment = - let open QCheck2.Gen in - make_primitive - ~gen:(fun state -> - Tezos_crypto_dal.Cryptobox.Internal_for_tests.dummy_commitment ~state ()) - ~shrink:(fun _ -> Seq.empty) - -let gen_slot_header = - let open QCheck2.Gen in - let* published_level = gen_level in - let* index = gen_slot_index in - let+ commitment = gen_slot_header_commitment in - Octez_smart_rollup.Dal.Slot_header.{id = {published_level; index}; commitment} - -let compare_slot_header_id (s1 : Octez_smart_rollup.Dal.Slot_header.id) - (s2 : Octez_smart_rollup.Dal.Slot_header.id) = - let c = Int32.compare s1.published_level s2.published_level in - if c <> 0 then c else Int.compare s1.index s2.index - -let gen_slot_headers = - let open QCheck2.Gen in - let size = int_bound 50 in - let+ l = list_size size gen_slot_header in - List.sort - (fun (h1 : Octez_smart_rollup.Dal.Slot_header.t) - (h2 : Octez_smart_rollup.Dal.Slot_header.t) -> - compare_slot_header_id h1.id h2.id) - l - |> fun l -> - match l with - | [] -> [] - | (h : Octez_smart_rollup.Dal.Slot_header.t) :: _ -> - let min_level = h.id.published_level in - (* smallest level *) - List.mapi - (fun i (h : Octez_smart_rollup.Dal.Slot_header.t) -> - (* patch the published level to comply with the invariants *) - let published_level = Int32.(add min_level (of_int i)) in - let h = {h with id = {h.id with published_level}} in - (published_level, [h])) - l - -let gen_slot_history = - let open Protocol.Alpha_context in - let open QCheck2.Gen in - let+ l = gen_slot_headers in - let l = - List.map - (fun (lvl, h) -> - ( Raw_level.of_int32_exn lvl, - List.map - (Sc_rollup_proto_types.Dal.Slot_header.of_octez ~number_of_slots) - h )) - l - in - List.fold_left_e - (fun hist (published_level, attested_slots) -> - Dal.Slots_history.add_confirmed_slot_headers_no_cache - ~number_of_slots - hist - published_level - attested_slots) - Dal.Slots_history.genesis - l - |> function - | Error e -> - Stdlib.failwith (Format.asprintf "%a" Environment.Error_monad.pp_trace e) - | Ok v -> Sc_rollup_proto_types.Dal.Slot_history.to_octez v - -let gen_slot_history_cache = - let open Protocol.Alpha_context in - let open QCheck2.Gen in - let+ l = gen_slot_headers in - let cache = Dal.Slots_history.History_cache.empty ~capacity:Int64.max_int in - let l = - List.map - (fun (lvl, h) -> - ( Raw_level.of_int32_exn lvl, - List.map - (Sc_rollup_proto_types.Dal.Slot_header.of_octez ~number_of_slots) - h )) - l - in - List.fold_left_e - (fun (hist, cache) (published_level, attested_slots) -> - Dal.Slots_history.add_confirmed_slot_headers - ~number_of_slots - hist - cache - published_level - attested_slots) - (Dal.Slots_history.genesis, cache) - l - |> function - | Error e -> - Stdlib.failwith (Format.asprintf "%a" Environment.Error_monad.pp_trace e) - | Ok (_, c) -> Sc_rollup_proto_types.Dal.Slot_history_cache.to_octez c - -let test_roundtrip ~count name gen to_octez from_octez octez_encoding - proto_encoding = - let test octez1 = - try - let proto1 = from_octez octez1 in - let octez2 = to_octez proto1 in - let proto2 = from_octez octez2 in - let check version enc v1 v2 = - let b1 = Data_encoding.Binary.to_bytes_exn enc v1 in - let b2 = Data_encoding.Binary.to_bytes_exn enc v2 in - if not (Bytes.equal b1 b2) then - QCheck2.Test.fail_reportf - "%s-%s not identical after roundtrip conversion" - name - version - in - check "protocol" proto_encoding proto1 proto2 ; - check "octez" octez_encoding octez1 octez2 ; - true - with exn -> - QCheck2.Test.fail_reportf - "%s roundtrip conversion error: %s" - name - (Printexc.to_string exn) - in - let print v = - Data_encoding.Json.construct octez_encoding v - |> Data_encoding.Json.to_string ~minify:false - in - QCheck2.Test.make - ~count - ~print - ~name:(Format.asprintf "roundtrip %s" name) - gen - test - -let test_address = - test_roundtrip - ~count:1000 - "address" - gen_address - Sc_rollup_proto_types.Address.to_octez - Sc_rollup_proto_types.Address.of_octez - Octez_smart_rollup.Address.encoding - Protocol.Alpha_context.Sc_rollup.Address.encoding - -let test_state_hash = - test_roundtrip - ~count:1000 - "state_hash" - gen_state_hash - Sc_rollup_proto_types.State_hash.to_octez - Sc_rollup_proto_types.State_hash.of_octez - Octez_smart_rollup.State_hash.encoding - Protocol.Alpha_context.Sc_rollup.State_hash.encoding - -let test_payload_hash = - test_roundtrip - ~count:1000 - "payload_hash" - gen_payload_hash - Sc_rollup_proto_types.Merkelized_payload_hashes_hash.to_octez - Sc_rollup_proto_types.Merkelized_payload_hashes_hash.of_octez - Octez_smart_rollup.Merkelized_payload_hashes_hash.encoding - Protocol.Alpha_context.Sc_rollup.Inbox_merkelized_payload_hashes.Hash - .encoding - -let test_commitment_hash = - test_roundtrip - ~count:1000 - "commitment_hash" - gen_commitment_hash - Sc_rollup_proto_types.Commitment_hash.to_octez - Sc_rollup_proto_types.Commitment_hash.of_octez - Octez_smart_rollup.Commitment.Hash.encoding - Protocol.Alpha_context.Sc_rollup.Commitment.Hash.encoding - -let test_commitment = - test_roundtrip - ~count:1000 - "commitment" - gen_commitment - Sc_rollup_proto_types.Commitment.to_octez - Sc_rollup_proto_types.Commitment.of_octez - Octez_smart_rollup.Commitment.encoding - Protocol.Alpha_context.Sc_rollup.Commitment.encoding - -let test_stakers = - test_roundtrip - ~count:1000 - "stakers" - gen_stakers - Sc_rollup_proto_types.Game.index_to_octez - Sc_rollup_proto_types.Game.index_of_octez - Octez_smart_rollup.Game.index_encoding - Protocol.Alpha_context.Sc_rollup.Game.Index.encoding - -let test_refutation = - test_roundtrip - ~count:1000 - "refutation" - gen_refutation - Sc_rollup_proto_types.Game.refutation_to_octez - Sc_rollup_proto_types.Game.refutation_of_octez - Octez_smart_rollup.Game.refutation_encoding - Protocol.Alpha_context.Sc_rollup.Game.refutation_encoding - -let test_inbox = - test_roundtrip - ~count:1000 - "inbox" - gen_inbox - Sc_rollup_proto_types.Inbox.to_octez - Sc_rollup_proto_types.Inbox.of_octez - Octez_smart_rollup.Inbox.encoding - Protocol.Alpha_context.Sc_rollup.Inbox.encoding - -let test_slot_index = - test_roundtrip - ~count:100 - "dal_slot_index" - gen_slot_index - Sc_rollup_proto_types.Dal.Slot_index.to_octez - (Sc_rollup_proto_types.Dal.Slot_index.of_octez ~number_of_slots) - Octez_smart_rollup.Dal.Slot_index.encoding - Protocol.Alpha_context.Dal.Slot_index.encoding - -let test_page_index = - test_roundtrip - ~count:100 - "dal_page_index" - gen_page_index - Sc_rollup_proto_types.Dal.Page_index.to_octez - Sc_rollup_proto_types.Dal.Page_index.of_octez - Octez_smart_rollup.Dal.Page_index.encoding - Protocol.Alpha_context.Dal.Page.Index.encoding - -let test_slot_header = - test_roundtrip - ~count:1000 - "dal_slot_header" - gen_slot_header - Sc_rollup_proto_types.Dal.Slot_header.to_octez - (Sc_rollup_proto_types.Dal.Slot_header.of_octez ~number_of_slots) - Octez_smart_rollup.Dal.Slot_header.encoding - Protocol.Alpha_context.Dal.Slot.Header.encoding - -let test_slot_history = - test_roundtrip - ~count:300 - "dal_slot_history" - gen_slot_history - Sc_rollup_proto_types.Dal.Slot_history.to_octez - Sc_rollup_proto_types.Dal.Slot_history.of_octez - Octez_smart_rollup.Dal.Slot_history.encoding - Protocol.Alpha_context.Dal.Slots_history.encoding - -let test_slot_history_cache = - test_roundtrip - ~count:300 - "dal_slot_history_cache" - gen_slot_history_cache - Sc_rollup_proto_types.Dal.Slot_history_cache.to_octez - Sc_rollup_proto_types.Dal.Slot_history_cache.of_octez - Octez_smart_rollup.Dal.Slot_history_cache.encoding - Protocol.Alpha_context.Dal.Slots_history.History_cache.encoding - -let tests = - [ - test_address; - test_state_hash; - test_payload_hash; - test_commitment_hash; - test_commitment; - test_stakers; - test_refutation; - test_inbox; - test_slot_index; - test_page_index; - test_slot_header; - test_slot_history; - test_slot_history_cache; - ] - -let () = - Alcotest.run - ~__FILE__ - (Protocol.name ^ ": Smart rollup types octez conversions") - [("roundtrip", qcheck_wrap tests)] diff --git a/tezt/tests/dune b/tezt/tests/dune index 199c480dcc8c..c3e7f4838be8 100644 --- a/tezt/tests/dune +++ b/tezt/tests/dune @@ -48,7 +48,6 @@ src_proto_021_PsQuebec_lib_delegate_test_tezt_lib src_proto_021_PsQuebec_lib_dal_test_tezt_lib src_proto_021_PsQuebec_lib_client_test_tezt_lib - src_proto_020_PsParisC_lib_sc_rollup_node_test_tezt_lib src_lib_workers_test_tezt_lib src_lib_webassembly_tests_tezt_lib src_lib_wasmer_test_tezt_lib diff --git a/teztale/bin_teztale_archiver/dune b/teztale/bin_teztale_archiver/dune index def64e04106b..72a21cd69189 100644 --- a/teztale/bin_teztale_archiver/dune +++ b/teztale/bin_teztale_archiver/dune @@ -116,20 +116,6 @@ s/Tezos_protocol_plugin_beta/Tezos_protocol_plugin_PsQuebec/g PsQuebec_machine.real.ml)))) -(rule - (target PsParisC_machine.real.ml) - (mode fallback) - (deps beta_machine.real.ml) - (action - (progn - (copy beta_machine.real.ml PsParisC_machine.real.ml) - (run - sed - -i.bak -e s/Tezos_client_beta/Tezos_client_PsParisC/g -e - s/Tezos_protocol_beta/Tezos_protocol_PsParisC/g -e - s/Tezos_protocol_plugin_beta/Tezos_protocol_plugin_PsParisC/g - PsParisC_machine.real.ml)))) - (rule (target beta_machine.real.ml) (mode fallback) -- GitLab From 6c6da565138b8d74aa870069df275039f8fc19d8 Mon Sep 17 00:00:00 2001 From: Killian Delarue Date: Mon, 27 Jan 2025 14:21:54 +0100 Subject: [PATCH 3/7] Changes: Add an entry for Paris freeze --- CHANGES.rst | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES.rst b/CHANGES.rst index 8e73c0c81efe..f334af796540 100644 --- a/CHANGES.rst +++ b/CHANGES.rst @@ -27,12 +27,15 @@ General - Changed the compiler version to 5.2.1 and added a manual job to compile with ocaml 4.14.2. (MR :gl:`!15404`) + - Logging output on TTYs now adapt to the terminal width. (MR :gl:`!12348`) - Logging output can now advertise the level associated to each events, by enabling the ``advertise-levels`` option in the file-descriptor sink URI. (MR :gl:`!16190`) +- Removed binaries for ParisC. (MR :gl:`!16427`) + Node ---- -- GitLab From db17e65ed3aa5eb52f047a6baa198d03bc8fecce Mon Sep 17 00:00:00 2001 From: Killian Delarue Date: Mon, 27 Jan 2025 14:33:17 +0100 Subject: [PATCH 4/7] Tezt: Remove Paris constants --- tezt/lib_tezos/constant.ml | 8 -------- 1 file changed, 8 deletions(-) diff --git a/tezt/lib_tezos/constant.ml b/tezt/lib_tezos/constant.ml index 4c0c24397b2c..5987f9e98a2b 100644 --- a/tezt/lib_tezos/constant.ml +++ b/tezt/lib_tezos/constant.ml @@ -91,14 +91,6 @@ let yes_wallet = ~path:"./_build/default/devtools/yes_wallet/yes_wallet.exe" () -(* To be removed after Paris is frozen *) -let _octez_accuser_PsParisC = - Uses.make ~tag:"accuser_psparisc" ~path:"./octez-accuser-PsParisC" () - -(* To be removed after Paris is frozen *) -let _octez_baker_PsParisC = - Uses.make ~tag:"baker_psparisc" ~path:"./octez-baker-PsParisC" () - module WASM = struct let dal_echo_kernel = Uses.make ~tag:"dal_echo_kernel" ~path:"dal_echo_kernel.wasm" () -- GitLab From 2eb72a10c1a8b6a26216d985c72f2e3c31ff492f Mon Sep 17 00:00:00 2001 From: Killian Delarue Date: Mon, 27 Jan 2025 15:04:28 +0100 Subject: [PATCH 5/7] CI: Regenerate --- .gitlab/ci/pipelines/before_merging.yml | 26 +++++++++---------- .gitlab/ci/pipelines/merge_train.yml | 26 +++++++++---------- .../ci/pipelines/schedule_extended_test.yml | 26 +++++++++---------- 3 files changed, 36 insertions(+), 42 deletions(-) diff --git a/.gitlab/ci/pipelines/before_merging.yml b/.gitlab/ci/pipelines/before_merging.yml index 425f80f082ca..631359d552df 100644 --- a/.gitlab/ci/pipelines/before_merging.yml +++ b/.gitlab/ci/pipelines/before_merging.yml @@ -1408,8 +1408,6 @@ opam:all_6: matrix: - package: - tezt-tezos - - tezos-protocol-genesis - - tezos-protocol-demo-noops - tezos-openapi - tezos-dal-node-services - tezos-benchmark @@ -1417,9 +1415,11 @@ opam:all_6: - octez-riscv-pvm - octez-proto-libs - octez-performance-metrics + - octez-libs - octez-l2-libs - efunc_core - dal_node_migrations + - bls12-381 opam:exec_6: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -1560,9 +1560,7 @@ opam:all_2: parallel: matrix: - package: - - octez-smart-rollup-wasm-debugger-lib - octez-smart-rollup-node-lib - - octez-smart-rollup-node-alpha - octez-protocol-alpha-libs - octez-protocol-021-PsQuebec-libs - octez-protocol-020-PsParisC-libs @@ -1570,6 +1568,8 @@ opam:all_2: - octez-protocol-018-Proxford-libs - octez-protocol-017-PtNairob-libs - octez-protocol-016-PtMumbai-libs + - octez-protocol-005-PsBabyM1-libs + - octez-protocol-004-Pt24m4xi-libs - octez-protocol-003-PsddFKi3-libs - octez-protocol-002-PsYLVpVv-libs - octez-protocol-001-PtCJ7pwo-libs @@ -1645,6 +1645,8 @@ opam:all_1: parallel: matrix: - package: + - octez-smart-rollup-wasm-debugger-lib + - octez-smart-rollup-node-alpha - octez-smart-rollup-node-PtParisB - octez-smart-rollup-node-PtNairob - octez-smart-rollup-node-PsQuebec @@ -1733,8 +1735,8 @@ opam:all_3: - octez-protocol-008-PtEdo2Zk-libs - octez-protocol-007-PsDELPH1-libs - octez-protocol-006-PsCARTHA-libs - - octez-protocol-005-PsBabyM1-libs - - octez-protocol-004-Pt24m4xi-libs + - octez-node-config + - octez-crawler opam:exec_4: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -1874,6 +1876,8 @@ opam:all_4: parallel: matrix: - package: + - tezos-protocol-010-PtGRANAD + - tezos-protocol-009-PsFLoren - tezos-protocol-008-PtEdoTez - tezos-protocol-008-PtEdo2Zk - tezos-protocol-007-PsDELPH1 @@ -1886,8 +1890,6 @@ opam:all_4: - tezos-protocol-001-PtCJ7pwo - tezos-protocol-000-Ps9mPmXa - tezos-dal-node-lib - - octez-node-config - - octez-crawler opam:exec_1: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -1963,9 +1965,7 @@ opam:exec_1: - octez-codec - octez-client - octez-baker-PsQuebec - - octez-baker-PsParisC - octez-accuser-PsQuebec - - octez-accuser-PsParisC opam:all_5: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -2036,6 +2036,8 @@ opam:all_5: parallel: matrix: - package: + - tezos-protocol-genesis + - tezos-protocol-demo-noops - tezos-protocol-demo-counter - tezos-protocol-alpha - tezos-protocol-021-PsQuebec @@ -2049,8 +2051,6 @@ opam:all_5: - tezos-protocol-013-PtJakart - tezos-protocol-012-Psithaca - tezos-protocol-011-PtHangz2 - - tezos-protocol-010-PtGRANAD - - tezos-protocol-009-PsFLoren opam:all_7: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -2126,12 +2126,10 @@ opam:all_7: - octez-rust-deps - octez-riscv-api - octez-protocol-compiler-compat - - octez-libs - octez-internal-libs - octez-distributed-lwt-internal - octez-distributed-internal - octez-alcotezt - - bls12-381 trigger:debian_repository_partial_auto: stage: test diff --git a/.gitlab/ci/pipelines/merge_train.yml b/.gitlab/ci/pipelines/merge_train.yml index 0d46658e7349..7ca745ef5754 100644 --- a/.gitlab/ci/pipelines/merge_train.yml +++ b/.gitlab/ci/pipelines/merge_train.yml @@ -1407,8 +1407,6 @@ opam:all_6: matrix: - package: - tezt-tezos - - tezos-protocol-genesis - - tezos-protocol-demo-noops - tezos-openapi - tezos-dal-node-services - tezos-benchmark @@ -1416,9 +1414,11 @@ opam:all_6: - octez-riscv-pvm - octez-proto-libs - octez-performance-metrics + - octez-libs - octez-l2-libs - efunc_core - dal_node_migrations + - bls12-381 opam:exec_6: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -1559,9 +1559,7 @@ opam:all_2: parallel: matrix: - package: - - octez-smart-rollup-wasm-debugger-lib - octez-smart-rollup-node-lib - - octez-smart-rollup-node-alpha - octez-protocol-alpha-libs - octez-protocol-021-PsQuebec-libs - octez-protocol-020-PsParisC-libs @@ -1569,6 +1567,8 @@ opam:all_2: - octez-protocol-018-Proxford-libs - octez-protocol-017-PtNairob-libs - octez-protocol-016-PtMumbai-libs + - octez-protocol-005-PsBabyM1-libs + - octez-protocol-004-Pt24m4xi-libs - octez-protocol-003-PsddFKi3-libs - octez-protocol-002-PsYLVpVv-libs - octez-protocol-001-PtCJ7pwo-libs @@ -1644,6 +1644,8 @@ opam:all_1: parallel: matrix: - package: + - octez-smart-rollup-wasm-debugger-lib + - octez-smart-rollup-node-alpha - octez-smart-rollup-node-PtParisB - octez-smart-rollup-node-PtNairob - octez-smart-rollup-node-PsQuebec @@ -1732,8 +1734,8 @@ opam:all_3: - octez-protocol-008-PtEdo2Zk-libs - octez-protocol-007-PsDELPH1-libs - octez-protocol-006-PsCARTHA-libs - - octez-protocol-005-PsBabyM1-libs - - octez-protocol-004-Pt24m4xi-libs + - octez-node-config + - octez-crawler opam:exec_4: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -1873,6 +1875,8 @@ opam:all_4: parallel: matrix: - package: + - tezos-protocol-010-PtGRANAD + - tezos-protocol-009-PsFLoren - tezos-protocol-008-PtEdoTez - tezos-protocol-008-PtEdo2Zk - tezos-protocol-007-PsDELPH1 @@ -1885,8 +1889,6 @@ opam:all_4: - tezos-protocol-001-PtCJ7pwo - tezos-protocol-000-Ps9mPmXa - tezos-dal-node-lib - - octez-node-config - - octez-crawler opam:exec_1: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -1962,9 +1964,7 @@ opam:exec_1: - octez-codec - octez-client - octez-baker-PsQuebec - - octez-baker-PsParisC - octez-accuser-PsQuebec - - octez-accuser-PsParisC opam:all_5: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -2035,6 +2035,8 @@ opam:all_5: parallel: matrix: - package: + - tezos-protocol-genesis + - tezos-protocol-demo-noops - tezos-protocol-demo-counter - tezos-protocol-alpha - tezos-protocol-021-PsQuebec @@ -2048,8 +2050,6 @@ opam:all_5: - tezos-protocol-013-PtJakart - tezos-protocol-012-Psithaca - tezos-protocol-011-PtHangz2 - - tezos-protocol-010-PtGRANAD - - tezos-protocol-009-PsFLoren opam:all_7: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -2125,12 +2125,10 @@ opam:all_7: - octez-rust-deps - octez-riscv-api - octez-protocol-compiler-compat - - octez-libs - octez-internal-libs - octez-distributed-lwt-internal - octez-distributed-internal - octez-alcotezt - - bls12-381 trigger:debian_repository_partial_auto: stage: test diff --git a/.gitlab/ci/pipelines/schedule_extended_test.yml b/.gitlab/ci/pipelines/schedule_extended_test.yml index 95741b8ffff8..c96f31bb444f 100644 --- a/.gitlab/ci/pipelines/schedule_extended_test.yml +++ b/.gitlab/ci/pipelines/schedule_extended_test.yml @@ -973,8 +973,6 @@ opam:all_6: matrix: - package: - tezt-tezos - - tezos-protocol-genesis - - tezos-protocol-demo-noops - tezos-openapi - tezos-dal-node-services - tezos-benchmark @@ -982,9 +980,11 @@ opam:all_6: - octez-riscv-pvm - octez-proto-libs - octez-performance-metrics + - octez-libs - octez-l2-libs - efunc_core - dal_node_migrations + - bls12-381 opam:exec_6: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -1095,9 +1095,7 @@ opam:all_2: parallel: matrix: - package: - - octez-smart-rollup-wasm-debugger-lib - octez-smart-rollup-node-lib - - octez-smart-rollup-node-alpha - octez-protocol-alpha-libs - octez-protocol-021-PsQuebec-libs - octez-protocol-020-PsParisC-libs @@ -1105,6 +1103,8 @@ opam:all_2: - octez-protocol-018-Proxford-libs - octez-protocol-017-PtNairob-libs - octez-protocol-016-PtMumbai-libs + - octez-protocol-005-PsBabyM1-libs + - octez-protocol-004-Pt24m4xi-libs - octez-protocol-003-PsddFKi3-libs - octez-protocol-002-PsYLVpVv-libs - octez-protocol-001-PtCJ7pwo-libs @@ -1164,6 +1164,8 @@ opam:all_1: parallel: matrix: - package: + - octez-smart-rollup-wasm-debugger-lib + - octez-smart-rollup-node-alpha - octez-smart-rollup-node-PtParisB - octez-smart-rollup-node-PtNairob - octez-smart-rollup-node-PsQuebec @@ -1236,8 +1238,8 @@ opam:all_3: - octez-protocol-008-PtEdo2Zk-libs - octez-protocol-007-PsDELPH1-libs - octez-protocol-006-PsCARTHA-libs - - octez-protocol-005-PsBabyM1-libs - - octez-protocol-004-Pt24m4xi-libs + - octez-node-config + - octez-crawler opam:exec_4: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -1347,6 +1349,8 @@ opam:all_4: parallel: matrix: - package: + - tezos-protocol-010-PtGRANAD + - tezos-protocol-009-PsFLoren - tezos-protocol-008-PtEdoTez - tezos-protocol-008-PtEdo2Zk - tezos-protocol-007-PsDELPH1 @@ -1359,8 +1363,6 @@ opam:all_4: - tezos-protocol-001-PtCJ7pwo - tezos-protocol-000-Ps9mPmXa - tezos-dal-node-lib - - octez-node-config - - octez-crawler opam:exec_1: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -1422,9 +1424,7 @@ opam:exec_1: - octez-codec - octez-client - octez-baker-PsQuebec - - octez-baker-PsParisC - octez-accuser-PsQuebec - - octez-accuser-PsParisC opam:all_5: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -1479,6 +1479,8 @@ opam:all_5: parallel: matrix: - package: + - tezos-protocol-genesis + - tezos-protocol-demo-noops - tezos-protocol-demo-counter - tezos-protocol-alpha - tezos-protocol-021-PsQuebec @@ -1492,8 +1494,6 @@ opam:all_5: - tezos-protocol-013-PtJakart - tezos-protocol-012-Psithaca - tezos-protocol-011-PtHangz2 - - tezos-protocol-010-PtGRANAD - - tezos-protocol-009-PsFLoren opam:all_7: image: ${ci_image_name}/prebuild:${ci_image_tag} @@ -1553,12 +1553,10 @@ opam:all_7: - octez-rust-deps - octez-riscv-api - octez-protocol-compiler-compat - - octez-libs - octez-internal-libs - octez-distributed-lwt-internal - octez-distributed-internal - octez-alcotezt - - bls12-381 trigger:debian_repository_full: stage: test -- GitLab From 2b4b7b6fe9cb1b059f9811a320fe513fb306f13a Mon Sep 17 00:00:00 2001 From: Killian Delarue Date: Mon, 27 Jan 2025 17:43:04 +0100 Subject: [PATCH 6/7] Tests: Reset regression files --- .../expected/tezt_wrapper.ml/runtime-dependency-tags.out | 2 -- 1 file changed, 2 deletions(-) diff --git a/tezt/lib_wrapper/expected/tezt_wrapper.ml/runtime-dependency-tags.out b/tezt/lib_wrapper/expected/tezt_wrapper.ml/runtime-dependency-tags.out index 4a57da4a1445..dcde6b532858 100644 --- a/tezt/lib_wrapper/expected/tezt_wrapper.ml/runtime-dependency-tags.out +++ b/tezt/lib_wrapper/expected/tezt_wrapper.ml/runtime-dependency-tags.out @@ -7,11 +7,9 @@ failed_migration: etherlink/kernel_evm/kernel/tests/resources/failed_migration.w ghostnet_evm_kernel: etherlink/kernel_evm/kernel/tests/resources/ghostnet_evm_kernel.wasm mainnet_evm_kernel: etherlink/kernel_evm/kernel/tests/resources/mainnet_evm_kernel.wasm evm_kernel: evm_kernel.wasm -accuser_psparisc: octez-accuser-PsParisC accuser_psquebec: octez-accuser-PsQuebec accuser_alpha: octez-accuser-alpha admin_client: octez-admin-client -baker_psparisc: octez-baker-PsParisC baker_psquebec: octez-baker-PsQuebec baker_alpha: octez-baker-alpha client: octez-client -- GitLab From 1f08e28213c82e3090f2d065a7ce3490d9938680 Mon Sep 17 00:00:00 2001 From: Killian Delarue Date: Tue, 28 Jan 2025 14:32:56 +0100 Subject: [PATCH 7/7] Packages, Homebrew: Build all instead of [release] Because Paris is removed, the current protocol becomes Quebec, and the next Alpha. Thus, alpha binaries need to be built. --- scripts/packaging/octez/homebrew/Formula/octez.rb.template | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/packaging/octez/homebrew/Formula/octez.rb.template b/scripts/packaging/octez/homebrew/Formula/octez.rb.template index 2280af888e10..909b86e78b75 100644 --- a/scripts/packaging/octez/homebrew/Formula/octez.rb.template +++ b/scripts/packaging/octez/homebrew/Formula/octez.rb.template @@ -49,7 +49,7 @@ class Octez < Formula make build-deps eval $(opam env) - make release + make EOS chmod 0755, buildpath/"script.sh" -- GitLab