From 044443a7b05c70cfe2126543d74696dc0b21688a Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sat, 21 May 2022 10:57:45 +0200 Subject: [PATCH 01/10] Proto: add the Apply_operation_result module. --- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 1 + .../lib_protocol/apply_operation_result.ml | 24 +++++++++++++++++++ .../lib_protocol/apply_operation_result.mli | 24 +++++++++++++++++++ src/proto_alpha/lib_protocol/dune | 5 ++++ 4 files changed, 54 insertions(+) create mode 100644 src/proto_alpha/lib_protocol/apply_operation_result.ml create mode 100644 src/proto_alpha/lib_protocol/apply_operation_result.mli diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 544056b1783a..2c3e9d6a7942 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -182,6 +182,7 @@ "Michelson_v1_gas", "Script_list", "Script_tc_context", + "Apply_operation_result", "Apply_results", "Script_ir_translator", "Script_big_map", diff --git a/src/proto_alpha/lib_protocol/apply_operation_result.ml b/src/proto_alpha/lib_protocol/apply_operation_result.ml new file mode 100644 index 000000000000..47dd664a1a70 --- /dev/null +++ b/src/proto_alpha/lib_protocol/apply_operation_result.ml @@ -0,0 +1,24 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) diff --git a/src/proto_alpha/lib_protocol/apply_operation_result.mli b/src/proto_alpha/lib_protocol/apply_operation_result.mli new file mode 100644 index 000000000000..47dd664a1a70 --- /dev/null +++ b/src/proto_alpha/lib_protocol/apply_operation_result.mli @@ -0,0 +1,24 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) diff --git a/src/proto_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index 782f6786eb2a..cd47dd516f30 100644 --- a/src/proto_alpha/lib_protocol/dune +++ b/src/proto_alpha/lib_protocol/dune @@ -198,6 +198,7 @@ Michelson_v1_gas Script_list Script_tc_context + Apply_operation_result Apply_results Script_ir_translator Script_big_map @@ -421,6 +422,7 @@ michelson_v1_gas.ml michelson_v1_gas.mli script_list.ml script_list.mli script_tc_context.ml script_tc_context.mli + apply_operation_result.ml apply_operation_result.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli @@ -630,6 +632,7 @@ michelson_v1_gas.ml michelson_v1_gas.mli script_list.ml script_list.mli script_tc_context.ml script_tc_context.mli + apply_operation_result.ml apply_operation_result.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli @@ -848,6 +851,7 @@ michelson_v1_gas.ml michelson_v1_gas.mli script_list.ml script_list.mli script_tc_context.ml script_tc_context.mli + apply_operation_result.ml apply_operation_result.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli @@ -1070,6 +1074,7 @@ michelson_v1_gas.ml michelson_v1_gas.mli script_list.ml script_list.mli script_tc_context.ml script_tc_context.mli + apply_operation_result.ml apply_operation_result.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli -- GitLab From 33c010540de96aef9e42abd3cc308542cdbb5812 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 23 May 2022 09:11:23 +0200 Subject: [PATCH 02/10] Proto: move operation_result to Apply_operation_result. To share it between modules, with one that will be created later. Does not compile (Apply_operation_result needs to be explicitly used in some places). --- .../lib_protocol/apply_operation_result.ml | 9 +++++++++ .../lib_protocol/apply_operation_result.mli | 18 ++++++++++++++++++ src/proto_alpha/lib_protocol/apply_results.ml | 19 +------------------ .../lib_protocol/apply_results.mli | 19 +------------------ 4 files changed, 29 insertions(+), 36 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply_operation_result.ml b/src/proto_alpha/lib_protocol/apply_operation_result.ml index 47dd664a1a70..7f6f18e92953 100644 --- a/src/proto_alpha/lib_protocol/apply_operation_result.ml +++ b/src/proto_alpha/lib_protocol/apply_operation_result.ml @@ -22,3 +22,12 @@ (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) + +type ('kind, 'manager, 'successful) operation_result = + | Applied of 'successful + | Backtracked of 'successful * error trace option + | Failed : + 'manager * error trace + -> ('kind, 'manager, 'successful) operation_result + | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result +[@@coq_force_gadt] diff --git a/src/proto_alpha/lib_protocol/apply_operation_result.mli b/src/proto_alpha/lib_protocol/apply_operation_result.mli index 47dd664a1a70..bee0e1c2cba0 100644 --- a/src/proto_alpha/lib_protocol/apply_operation_result.mli +++ b/src/proto_alpha/lib_protocol/apply_operation_result.mli @@ -22,3 +22,21 @@ (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) + +(** The result of an operation in the queue. [Skipped] ones should + always be at the tail, and after a single [Failed]. + * The ['kind] parameter is the operation kind (a transaction, an + origination, etc.). + * The ['manager] parameter is the type of manager kinds. + * The ['successful] parameter is the type of successful operations. + The ['kind] parameter is used to make the type a GADT, but ['manager] and + ['successful] are used to share [operation_result] between internal and + external operation results, and are instantiated for each case. *) +type ('kind, 'manager, 'successful) operation_result = + | Applied of 'successful + | Backtracked of 'successful * error trace option + | Failed : + 'manager * error trace + -> ('kind, 'manager, 'successful) operation_result + | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result +[@@coq_force_gadt] diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 830fdb3c8636..fb6169ee4508 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -26,6 +26,7 @@ open Alpha_context open Data_encoding +open Apply_operation_result let error_encoding = def @@ -337,24 +338,6 @@ let pack_migration_operation_results results = (migration_origination_result_to_successful_manager_operation_result el)) results -(** The result of an operation in the queue. [Skipped] ones should - always be at the tail, and after a single [Failed]. - * The ['kind] parameter is the operation kind (a transaction, an - origination, etc.). - * The ['manager] parameter is the type of manager kinds. - * The ['successful] parameter is the type of successful operations. - The ['kind] parameter is used to make the type a GADT, but ['manager] and - ['successful] are used to share [operation_result] between internal and - external operation results, and are instantiated for each case. *) -type ('kind, 'manager, 'successful) operation_result = - | Applied of 'successful - | Backtracked of 'successful * error trace option - | Failed : - 'manager * error trace - -> ('kind, 'manager, 'successful) operation_result - | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result -[@@coq_force_gadt] - type 'kind manager_operation_result = ( 'kind, 'kind Kind.manager, diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index 6d18773b3658..875eb9c533ef 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -33,6 +33,7 @@ *) open Alpha_context +open Apply_operation_result type 'kind internal_manager_operation = | Transaction : { @@ -133,24 +134,6 @@ and 'kind contents_result = and packed_contents_result = | Contents_result : 'kind contents_result -> packed_contents_result -(** The result of an operation in the queue. [Skipped] ones should - always be at the tail, and after a single [Failed]. - * The ['kind] parameter is the operation kind (a transaction, an - origination, etc.). - * The ['manager] parameter is the type of manager kinds. - * The ['successful] parameter is the type of successful operations. - The ['kind] parameter is used to make the type a GADT, but ['manager] and - ['successful] are used to share [operation_result] between internal and - external operation results, and are instantiated for each case. *) -and ('kind, 'manager, 'successful) operation_result = - | Applied of 'successful - | Backtracked of 'successful * error trace option - | Failed : - 'manager * error trace - -> ('kind, 'manager, 'successful) operation_result - | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result -[@@coq_force_gadt] - and 'kind manager_operation_result = ( 'kind, 'kind Kind.manager, -- GitLab From a4db9b38f981af0523782084e0c586ca2a3135fc Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sun, 22 May 2022 13:37:06 +0200 Subject: [PATCH 03/10] Proto/Client: use Apply_operation_result. --- src/proto_alpha/lib_client/injection.ml | 1 + src/proto_alpha/lib_client/operation_result.ml | 1 + .../lib_client_commands/client_proto_context_commands.ml | 2 +- src/proto_alpha/lib_protocol/apply.ml | 1 + src/proto_alpha/lib_protocol/test/helpers/incremental.ml | 1 + 5 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index 397740a8ad71..4c32f5911472 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -27,6 +27,7 @@ open Protocol open Alpha_context open Apply_results +open Apply_operation_result open Protocol_client_context let get_branch (rpc_config : #Protocol_client_context.full) ~chain diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index 92363695d7b2..12826a0afc3b 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -27,6 +27,7 @@ open Protocol open Alpha_context open Apply_results +open Apply_operation_result let tez_sym = "\xEA\x9C\xA9" diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 40e5775db12f..af56010c0b8e 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -1892,7 +1892,7 @@ let commands_rw () = Apply_results.Manager_operation_result { operation_result = - Apply_results.Applied + Apply_operation_result.Applied (Apply_results.Tx_rollup_origination_result {originated_tx_rollup; _}); _; diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 4e310742fa33..6c36ca11c20b 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -811,6 +811,7 @@ let () = (fun () -> Invalid_transfer_to_sc_rollup_from_implicit_account) open Apply_results +open Apply_operation_result let assert_tx_rollup_feature_enabled ctxt = let level = (Level.current ctxt).level in diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index c93dfd5c1d45..8f7a9739d040 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -125,6 +125,7 @@ let detect_script_failure : let rec detect_script_failure : type kind. kind Apply_results.contents_result_list -> _ = let open Apply_results in + let open Apply_operation_result in let detect_script_failure_single (type kind) (Manager_operation_result {operation_result; internal_operation_results; _} : -- GitLab From 822cc41a9b4681b9564f3a6bbc9775e161cb467f Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 20 Jun 2022 13:29:56 +0200 Subject: [PATCH 04/10] Proto: move trace_encoding to Apply_operation_result. It will also be shared between modules (external and internal operation results). --- .../lib_protocol/apply_operation_result.ml | 22 +++++++++++++++++++ .../lib_protocol/apply_operation_result.mli | 2 ++ src/proto_alpha/lib_protocol/apply_results.ml | 20 ----------------- 3 files changed, 24 insertions(+), 20 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply_operation_result.ml b/src/proto_alpha/lib_protocol/apply_operation_result.ml index 7f6f18e92953..d82aec0e522a 100644 --- a/src/proto_alpha/lib_protocol/apply_operation_result.ml +++ b/src/proto_alpha/lib_protocol/apply_operation_result.ml @@ -23,6 +23,8 @@ (* *) (*****************************************************************************) +open Data_encoding + type ('kind, 'manager, 'successful) operation_result = | Applied of 'successful | Backtracked of 'successful * error trace option @@ -31,3 +33,23 @@ type ('kind, 'manager, 'successful) operation_result = -> ('kind, 'manager, 'successful) operation_result | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result [@@coq_force_gadt] + +let error_encoding = + def + "error" + ~description: + "The full list of RPC errors would be too long to include.\n\ + It is available at RPC `/errors` (GET).\n\ + Errors specific to protocol Alpha have an id that starts with \ + `proto.alpha`." + @@ splitted + ~json: + (conv + (fun err -> + Data_encoding.Json.construct Error_monad.error_encoding err) + (fun json -> + Data_encoding.Json.destruct Error_monad.error_encoding json) + json) + ~binary:Error_monad.error_encoding + +let trace_encoding = make_trace_encoding error_encoding diff --git a/src/proto_alpha/lib_protocol/apply_operation_result.mli b/src/proto_alpha/lib_protocol/apply_operation_result.mli index bee0e1c2cba0..11704df359d9 100644 --- a/src/proto_alpha/lib_protocol/apply_operation_result.mli +++ b/src/proto_alpha/lib_protocol/apply_operation_result.mli @@ -40,3 +40,5 @@ type ('kind, 'manager, 'successful) operation_result = -> ('kind, 'manager, 'successful) operation_result | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result [@@coq_force_gadt] + +val trace_encoding : error trace Data_encoding.t diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index fb6169ee4508..e41978220db1 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -28,26 +28,6 @@ open Alpha_context open Data_encoding open Apply_operation_result -let error_encoding = - def - "error" - ~description: - "The full list of RPC errors would be too long to include.\n\ - It is available at RPC `/errors` (GET).\n\ - Errors specific to protocol Alpha have an id that starts with \ - `proto.alpha`." - @@ splitted - ~json: - (conv - (fun err -> - Data_encoding.Json.construct Error_monad.error_encoding err) - (fun json -> - Data_encoding.Json.destruct Error_monad.error_encoding json) - json) - ~binary:Error_monad.error_encoding - -let trace_encoding = make_trace_encoding error_encoding - type 'kind internal_manager_operation = | Transaction : { amount : Tez.tez; -- GitLab From 493ef93754f2957dba9277809174fc10e28088af Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 17 Jun 2022 17:42:55 +0200 Subject: [PATCH 05/10] Proto: unique names for internal operation result encodings. --- src/proto_alpha/lib_protocol/apply_results.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index e41978220db1..59941cd79c68 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -1147,7 +1147,7 @@ module Internal_result = struct end let internal_contents_encoding : packed_internal_contents Data_encoding.t = - def "apply_results.alpha.internal_operation_result" + def "apply_internal_results.alpha.operation_result" @@ conv (fun (Internal_contents {source; operation; nonce}) -> ((source, nonce), Manager operation)) @@ -1175,7 +1175,7 @@ module Internal_manager_result = struct let make ~op_case ~encoding ~kind ~select ~proj ~inj = let (Internal_result.MCase {name; _}) = op_case in let t = - def (Format.asprintf "operation.alpha.operation_result.%s" name) + def (Format.asprintf "operation.alpha.internal_operation_result.%s" name) @@ union ~tag_size:`Uint8 [ @@ -1332,7 +1332,7 @@ let internal_manager_operation_result_encoding : let op = {source; operation = ires_case.inj op; nonce} in Internal_manager_operation_result (op, res)) in - def "apply_results.alpha.operation_result" + def "apply_internal_results.alpha.operation_result" @@ union [ make -- GitLab From 4db6ff8ff93a2a96d112d6ef2920e78208baf7e9 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 17 Jun 2022 23:32:40 +0200 Subject: [PATCH 06/10] Proto: copy and use transaction encodings for internal results. Copied from Apply_results.Manager_result.transaction_contract_variant_cases. --- src/proto_alpha/lib_protocol/apply_results.ml | 106 +++++++++++++++++- 1 file changed, 105 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 59941cd79c68..91a05615afa8 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -1031,6 +1031,110 @@ module Internal_result = struct -> 'kind case [@@coq_force_gadt] + let[@coq_axiom_with_reason "gadt"] transaction_contract_variant_cases = + union + [ + case + ~title:"To_contract" + (Tag 0) + (obj8 + (opt "storage" Script.expr_encoding) + (dft "balance_updates" Receipt.balance_updates_encoding []) + (dft "originated_contracts" (list Contract.originated_encoding) []) + (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) + (dft "storage_size" z Z.zero) + (dft "paid_storage_size_diff" z Z.zero) + (dft "allocated_destination_contract" bool false) + (opt "lazy_storage_diff" Lazy_storage.encoding)) + (function + | Transaction_to_contract_result + { + storage; + lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff; + allocated_destination_contract; + } -> + Some + ( storage, + balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff, + allocated_destination_contract, + lazy_storage_diff ) + | _ -> None) + (fun ( storage, + balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff, + allocated_destination_contract, + lazy_storage_diff ) -> + Transaction_to_contract_result + { + storage; + lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff; + allocated_destination_contract; + }); + case + ~title:"To_tx_rollup" + (Tag 1) + (obj4 + (dft "balance_updates" Receipt.balance_updates_encoding []) + (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) + (req "ticket_hash" Ticket_hash.encoding) + (req "paid_storage_size_diff" n)) + (function + | Transaction_to_tx_rollup_result + { + balance_updates; + consumed_gas; + ticket_hash; + paid_storage_size_diff; + } -> + Some + ( balance_updates, + consumed_gas, + ticket_hash, + paid_storage_size_diff ) + | _ -> None) + (fun ( balance_updates, + consumed_gas, + ticket_hash, + paid_storage_size_diff ) -> + Transaction_to_tx_rollup_result + { + balance_updates; + consumed_gas; + ticket_hash; + paid_storage_size_diff; + }); + case + ~title:"To_sc_rollup" + (Tag 2) + (obj2 + (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) + (req "inbox_after" Sc_rollup.Inbox.encoding)) + (function + | Transaction_to_sc_rollup_result {consumed_gas; inbox_after} -> + Some (consumed_gas, inbox_after) + | _ -> None) + (function + | consumed_gas, inbox_after -> + Transaction_to_sc_rollup_result {consumed_gas; inbox_after}); + ] + let[@coq_axiom_with_reason "gadt"] transaction_case = MCase { @@ -1228,7 +1332,7 @@ module Internal_manager_result = struct let[@coq_axiom_with_reason "gadt"] transaction_case = make ~op_case:Internal_result.transaction_case - ~encoding:Manager_result.transaction_contract_variant_cases + ~encoding:Internal_result.transaction_contract_variant_cases ~select:(function | Successful_internal_manager_result (ITransaction_result _ as op) -> Some op -- GitLab From 2e5c5afca5d5668e2da07b506f60853a0ebecd34 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 23 May 2022 09:34:35 +0200 Subject: [PATCH 07/10] Proto: add the Apply_internal_results module. --- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 1 + .../lib_protocol/apply_internal_results.ml | 24 +++++++++++++++++++ .../lib_protocol/apply_internal_results.mli | 24 +++++++++++++++++++ src/proto_alpha/lib_protocol/dune | 5 ++++ 4 files changed, 54 insertions(+) create mode 100644 src/proto_alpha/lib_protocol/apply_internal_results.ml create mode 100644 src/proto_alpha/lib_protocol/apply_internal_results.mli diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 2c3e9d6a7942..de874245fd88 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -183,6 +183,7 @@ "Script_list", "Script_tc_context", "Apply_operation_result", + "Apply_internal_results", "Apply_results", "Script_ir_translator", "Script_big_map", diff --git a/src/proto_alpha/lib_protocol/apply_internal_results.ml b/src/proto_alpha/lib_protocol/apply_internal_results.ml new file mode 100644 index 000000000000..47dd664a1a70 --- /dev/null +++ b/src/proto_alpha/lib_protocol/apply_internal_results.ml @@ -0,0 +1,24 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) diff --git a/src/proto_alpha/lib_protocol/apply_internal_results.mli b/src/proto_alpha/lib_protocol/apply_internal_results.mli new file mode 100644 index 000000000000..47dd664a1a70 --- /dev/null +++ b/src/proto_alpha/lib_protocol/apply_internal_results.mli @@ -0,0 +1,24 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) diff --git a/src/proto_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index cd47dd516f30..ecad17786a31 100644 --- a/src/proto_alpha/lib_protocol/dune +++ b/src/proto_alpha/lib_protocol/dune @@ -199,6 +199,7 @@ Script_list Script_tc_context Apply_operation_result + Apply_internal_results Apply_results Script_ir_translator Script_big_map @@ -423,6 +424,7 @@ script_list.ml script_list.mli script_tc_context.ml script_tc_context.mli apply_operation_result.ml apply_operation_result.mli + apply_internal_results.ml apply_internal_results.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli @@ -633,6 +635,7 @@ script_list.ml script_list.mli script_tc_context.ml script_tc_context.mli apply_operation_result.ml apply_operation_result.mli + apply_internal_results.ml apply_internal_results.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli @@ -852,6 +855,7 @@ script_list.ml script_list.mli script_tc_context.ml script_tc_context.mli apply_operation_result.ml apply_operation_result.mli + apply_internal_results.ml apply_internal_results.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli @@ -1075,6 +1079,7 @@ script_list.ml script_list.mli script_tc_context.ml script_tc_context.mli apply_operation_result.ml apply_operation_result.mli + apply_internal_results.ml apply_internal_results.mli apply_results.ml apply_results.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli -- GitLab From 198b7eb3bea651672e50d26afd023a2ffe634a2f Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 23 May 2022 09:42:54 +0200 Subject: [PATCH 08/10] Proto: move things to Apply_internal_results. Note that successful_transaction_result and successful_origination_result are now differentiated between external ones (in Apply_results) and internal ones (in Apply_internal_results). Does not compile (Apply_internal_results needs to be explicitly used in some places.) --- .../lib_protocol/apply_internal_results.ml | 594 ++++++++++++++++++ .../lib_protocol/apply_internal_results.mli | 111 ++++ src/proto_alpha/lib_protocol/apply_results.ml | 590 +---------------- .../lib_protocol/apply_results.mli | 104 +-- 4 files changed, 715 insertions(+), 684 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply_internal_results.ml b/src/proto_alpha/lib_protocol/apply_internal_results.ml index 47dd664a1a70..cd2e0d6b182d 100644 --- a/src/proto_alpha/lib_protocol/apply_internal_results.ml +++ b/src/proto_alpha/lib_protocol/apply_internal_results.ml @@ -22,3 +22,597 @@ (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) + +open Alpha_context +open Data_encoding +open Apply_operation_result + +type 'kind internal_manager_operation = + | Transaction : { + amount : Tez.tez; + parameters : Script.lazy_expr; + entrypoint : Entrypoint.t; + destination : Destination.t; + } + -> Kind.transaction internal_manager_operation + | Origination : { + delegate : Signature.Public_key_hash.t option; + script : Script.t; + credit : Tez.tez; + } + -> Kind.origination internal_manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation internal_manager_operation + +type packed_internal_manager_operation = + | Manager : + 'kind internal_manager_operation + -> packed_internal_manager_operation + +type 'kind internal_contents = { + source : Contract.t; + operation : 'kind internal_manager_operation; + nonce : int; +} + +type packed_internal_contents = + | Internal_contents : 'kind internal_contents -> packed_internal_contents + +let contents_of_internal_operation (type kind) + ({source; operation; nonce} : kind Script_typed_ir.internal_operation) : + kind internal_contents = + let operation : kind internal_manager_operation = + match operation with + | Transaction_to_contract + {destination; amount; entrypoint; unparsed_parameters; _} -> + Transaction + { + destination = Contract destination; + amount; + entrypoint; + parameters = Script.lazy_expr unparsed_parameters; + } + | Transaction_to_tx_rollup {destination; unparsed_parameters; _} -> + Transaction + { + destination = Tx_rollup destination; + (* Dummy amount used for the external untyped view of internal transactions *) + amount = Tez.zero; + entrypoint = Tx_rollup.deposit_entrypoint; + parameters = Script.lazy_expr unparsed_parameters; + } + | Transaction_to_sc_rollup {destination; entrypoint; unparsed_parameters; _} + -> + Transaction + { + destination = Sc_rollup destination; + amount = Tez.zero; + entrypoint; + parameters = Script.lazy_expr unparsed_parameters; + } + | Origination {delegate; code; unparsed_storage; credit; _} -> + let script = + { + Script.code = Script.lazy_expr code; + storage = Script.lazy_expr unparsed_storage; + } + in + Origination {delegate; script; credit} + | Delegation delegate -> Delegation delegate + in + {source; operation; nonce} + +let contents_of_packed_internal_operation + (Script_typed_ir.Internal_operation op) = + Internal_contents (contents_of_internal_operation op) + +let contents_of_packed_internal_operations = + List.map contents_of_packed_internal_operation + +type successful_transaction_result = + | Transaction_to_contract_result of { + storage : Script.expr option; + lazy_storage_diff : Lazy_storage.diffs option; + balance_updates : Receipt.balance_updates; + originated_contracts : Contract_hash.t list; + consumed_gas : Gas.Arith.fp; + storage_size : Z.t; + paid_storage_size_diff : Z.t; + allocated_destination_contract : bool; + } + | Transaction_to_tx_rollup_result of { + ticket_hash : Ticket_hash.t; + balance_updates : Receipt.balance_updates; + consumed_gas : Gas.Arith.fp; + paid_storage_size_diff : Z.t; + } + | Transaction_to_sc_rollup_result of { + consumed_gas : Gas.Arith.fp; + inbox_after : Sc_rollup.Inbox.t; + } + +type successful_origination_result = { + lazy_storage_diff : Lazy_storage.diffs option; + balance_updates : Receipt.balance_updates; + originated_contracts : Contract_hash.t list; + consumed_gas : Gas.Arith.fp; + storage_size : Z.t; + paid_storage_size_diff : Z.t; +} + +(** Result of applying an internal {!manager_operation}. *) +type _ successful_internal_manager_operation_result = + | ITransaction_result : + successful_transaction_result + -> Kind.transaction successful_internal_manager_operation_result + | IOrigination_result : + successful_origination_result + -> Kind.origination successful_internal_manager_operation_result + | IDelegation_result : { + consumed_gas : Gas.Arith.fp; + } + -> Kind.delegation successful_internal_manager_operation_result + +type packed_successful_internal_manager_operation_result = + | Successful_internal_manager_result : + 'kind successful_internal_manager_operation_result + -> packed_successful_internal_manager_operation_result + +type 'kind internal_manager_operation_result = + ( 'kind, + 'kind Kind.manager, + 'kind successful_internal_manager_operation_result ) + operation_result + +type packed_internal_manager_operation_result = + | Internal_manager_operation_result : + 'kind internal_contents * 'kind internal_manager_operation_result + -> packed_internal_manager_operation_result + +let pack_internal_manager_operation_result (type kind) + (internal_op : kind Script_typed_ir.internal_operation) + (manager_op : kind internal_manager_operation_result) = + let internal_op = contents_of_internal_operation internal_op in + Internal_manager_operation_result (internal_op, manager_op) + +type 'kind iselect = + packed_internal_manager_operation_result -> + ('kind internal_contents * 'kind internal_manager_operation_result) option + +module Internal_result = struct + open Data_encoding + + type 'kind case = + | MCase : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + iselect : 'kind iselect; + select : + packed_internal_manager_operation -> + 'kind internal_manager_operation option; + proj : 'kind internal_manager_operation -> 'a; + inj : 'a -> 'kind internal_manager_operation; + } + -> 'kind case + [@@coq_force_gadt] + + let[@coq_axiom_with_reason "gadt"] transaction_contract_variant_cases = + union + [ + case + ~title:"To_contract" + (Tag 0) + (obj8 + (opt "storage" Script.expr_encoding) + (dft "balance_updates" Receipt.balance_updates_encoding []) + (dft "originated_contracts" (list Contract.originated_encoding) []) + (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) + (dft "storage_size" z Z.zero) + (dft "paid_storage_size_diff" z Z.zero) + (dft "allocated_destination_contract" bool false) + (opt "lazy_storage_diff" Lazy_storage.encoding)) + (function + | Transaction_to_contract_result + { + storage; + lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff; + allocated_destination_contract; + } -> + Some + ( storage, + balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff, + allocated_destination_contract, + lazy_storage_diff ) + | _ -> None) + (fun ( storage, + balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff, + allocated_destination_contract, + lazy_storage_diff ) -> + Transaction_to_contract_result + { + storage; + lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff; + allocated_destination_contract; + }); + case + ~title:"To_tx_rollup" + (Tag 1) + (obj4 + (dft "balance_updates" Receipt.balance_updates_encoding []) + (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) + (req "ticket_hash" Ticket_hash.encoding) + (req "paid_storage_size_diff" n)) + (function + | Transaction_to_tx_rollup_result + { + balance_updates; + consumed_gas; + ticket_hash; + paid_storage_size_diff; + } -> + Some + ( balance_updates, + consumed_gas, + ticket_hash, + paid_storage_size_diff ) + | _ -> None) + (fun ( balance_updates, + consumed_gas, + ticket_hash, + paid_storage_size_diff ) -> + Transaction_to_tx_rollup_result + { + balance_updates; + consumed_gas; + ticket_hash; + paid_storage_size_diff; + }); + case + ~title:"To_sc_rollup" + (Tag 2) + (obj2 + (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) + (req "inbox_after" Sc_rollup.Inbox.encoding)) + (function + | Transaction_to_sc_rollup_result {consumed_gas; inbox_after} -> + Some (consumed_gas, inbox_after) + | _ -> None) + (function + | consumed_gas, inbox_after -> + Transaction_to_sc_rollup_result {consumed_gas; inbox_after}); + ] + + let[@coq_axiom_with_reason "gadt"] transaction_case = + MCase + { + (* This value should be changed with care: maybe receipts are read by + external tools such as indexers. *) + tag = 1; + name = "transaction"; + encoding = + obj3 + (req "amount" Tez.encoding) + (req "destination" Destination.encoding) + (opt + "parameters" + (obj2 + (req "entrypoint" Entrypoint.smart_encoding) + (req "value" Script.lazy_expr_encoding))); + iselect : Kind.transaction iselect = + (function + | Internal_manager_operation_result + (({operation = Transaction _; _} as op), res) -> + Some (op, res) + | _ -> None); + select = + (function Manager (Transaction _ as op) -> Some op | _ -> None); + proj = + (function + | Transaction {amount; destination; parameters; entrypoint} -> + let parameters = + if + Script_repr.is_unit_parameter parameters + && Entrypoint.is_default entrypoint + then None + else Some (entrypoint, parameters) + in + (amount, destination, parameters)); + inj = + (fun (amount, destination, parameters) -> + let entrypoint, parameters = + match parameters with + | None -> (Entrypoint.default, Script.unit_parameter) + | Some (entrypoint, value) -> (entrypoint, value) + in + Transaction {amount; destination; parameters; entrypoint}); + } + + let[@coq_axiom_with_reason "gadt"] origination_case = + MCase + { + (* This value should be changed with care: maybe receipts are read by + external tools such as indexers. *) + tag = 2; + name = "origination"; + encoding = + obj3 + (req "balance" Tez.encoding) + (opt "delegate" Signature.Public_key_hash.encoding) + (req "script" Script.encoding); + iselect : Kind.origination iselect = + (function + | Internal_manager_operation_result + (({operation = Origination _; _} as op), res) -> + Some (op, res) + | _ -> None); + select = + (function Manager (Origination _ as op) -> Some op | _ -> None); + proj = + (function + | Origination {credit; delegate; script} -> (credit, delegate, script)); + inj = + (fun (credit, delegate, script) -> + Origination {credit; delegate; script}); + } + + let[@coq_axiom_with_reason "gadt"] delegation_case = + MCase + { + (* This value should be changed with care: maybe receipts are read by + external tools such as indexers. *) + tag = 3; + name = "delegation"; + encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding); + iselect : Kind.delegation iselect = + (function + | Internal_manager_operation_result + (({operation = Delegation _; _} as op), res) -> + Some (op, res) + | _ -> None); + select = + (function Manager (Delegation _ as op) -> Some op | _ -> None); + proj = (function Delegation key -> key); + inj = (fun key -> Delegation key); + } + + let case tag name args proj inj = + case + tag + ~title:(String.capitalize_ascii name) + (merge_objs (obj1 (req "kind" (constant name))) args) + (fun x -> match proj x with None -> None | Some x -> Some ((), x)) + (fun ((), x) -> inj x) + + let encoding = + let make (MCase {tag; name; encoding; iselect = _; select; proj; inj}) = + case + (Tag tag) + name + encoding + (fun o -> match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Manager (inj x)) + in + union + ~tag_size:`Uint8 + [make transaction_case; make origination_case; make delegation_case] +end + +let internal_contents_encoding : packed_internal_contents Data_encoding.t = + def "apply_internal_results.alpha.operation_result" + @@ conv + (fun (Internal_contents {source; operation; nonce}) -> + ((source, nonce), Manager operation)) + (fun ((source, nonce), Manager operation) -> + Internal_contents {source; operation; nonce}) + (merge_objs + (obj2 (req "source" Contract.encoding) (req "nonce" uint16)) + Internal_result.encoding) + +module Internal_manager_result = struct + type 'kind case = + | MCase : { + op_case : 'kind Internal_result.case; + encoding : 'a Data_encoding.t; + kind : 'kind Kind.manager; + select : + packed_successful_internal_manager_operation_result -> + 'kind successful_internal_manager_operation_result option; + proj : 'kind successful_internal_manager_operation_result -> 'a; + inj : 'a -> 'kind successful_internal_manager_operation_result; + t : 'kind internal_manager_operation_result Data_encoding.t; + } + -> 'kind case + + let make ~op_case ~encoding ~kind ~select ~proj ~inj = + let (Internal_result.MCase {name; _}) = op_case in + let t = + def (Format.asprintf "operation.alpha.internal_operation_result.%s" name) + @@ union + ~tag_size:`Uint8 + [ + case + (Tag 0) + ~title:"Applied" + (merge_objs (obj1 (req "status" (constant "applied"))) encoding) + (fun o -> + match o with + | Skipped _ | Failed _ | Backtracked _ -> None + | Applied o -> ( + match select (Successful_internal_manager_result o) with + | None -> None + | Some o -> Some ((), proj o))) + (fun ((), x) -> Applied (inj x)); + case + (Tag 1) + ~title:"Failed" + (obj2 + (req "status" (constant "failed")) + (req "errors" trace_encoding)) + (function Failed (_, errs) -> Some ((), errs) | _ -> None) + (fun ((), errs) -> Failed (kind, errs)); + case + (Tag 2) + ~title:"Skipped" + (obj1 (req "status" (constant "skipped"))) + (function Skipped _ -> Some () | _ -> None) + (fun () -> Skipped kind); + case + (Tag 3) + ~title:"Backtracked" + (merge_objs + (obj2 + (req "status" (constant "backtracked")) + (opt "errors" trace_encoding)) + encoding) + (fun o -> + match o with + | Skipped _ | Failed _ | Applied _ -> None + | Backtracked (o, errs) -> ( + match select (Successful_internal_manager_result o) with + | None -> None + | Some o -> Some (((), errs), proj o))) + (fun (((), errs), x) -> Backtracked (inj x, errs)); + ] + in + MCase {op_case; encoding; kind; select; proj; inj; t} + + let[@coq_axiom_with_reason "gadt"] transaction_case = + make + ~op_case:Internal_result.transaction_case + ~encoding:Internal_result.transaction_contract_variant_cases + ~select:(function + | Successful_internal_manager_result (ITransaction_result _ as op) -> + Some op + | _ -> None) + ~kind:Kind.Transaction_manager_kind + ~proj:(function ITransaction_result x -> x) + ~inj:(fun x -> ITransaction_result x) + + let[@coq_axiom_with_reason "gadt"] origination_case = + make + ~op_case:Internal_result.origination_case + ~encoding: + (obj6 + (dft "balance_updates" Receipt.balance_updates_encoding []) + (dft "originated_contracts" (list Contract.originated_encoding) []) + (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) + (dft "storage_size" z Z.zero) + (dft "paid_storage_size_diff" z Z.zero) + (opt "lazy_storage_diff" Lazy_storage.encoding)) + ~select:(function + | Successful_internal_manager_result (IOrigination_result _ as op) -> + Some op + | _ -> None) + ~proj:(function + | IOrigination_result + { + lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff; + } -> + (* There used to be a [legacy_lazy_storage_diff] returned as the + first component of the tuple below, and the non-legacy one + returned as the last component. The legacy one has been removed, + but it was chosen to keep the non-legacy one at its position, + hence the order difference with regards to the record above. *) + ( balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff, + lazy_storage_diff )) + ~kind:Kind.Origination_manager_kind + ~inj: + (fun ( balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff, + lazy_storage_diff ) -> + IOrigination_result + { + lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff; + }) + + let delegation_case = + make + ~op_case:Internal_result.delegation_case + ~encoding: + Data_encoding.( + obj1 (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) + ~select:(function + | Successful_internal_manager_result (IDelegation_result _ as op) -> + Some op + | _ -> None) + ~kind:Kind.Delegation_manager_kind + ~proj:(function[@coq_match_with_default] + | IDelegation_result {consumed_gas} -> consumed_gas) + ~inj:(fun consumed_gas -> IDelegation_result {consumed_gas}) +end + +let internal_manager_operation_result_encoding : + packed_internal_manager_operation_result Data_encoding.t = + let make (type kind) + (Internal_manager_result.MCase res_case : + kind Internal_manager_result.case) + (Internal_result.MCase ires_case : kind Internal_result.case) = + let (Internal_result.MCase op_case) = res_case.op_case in + case + (Tag op_case.tag) + ~title:op_case.name + (merge_objs + (obj3 + (req "kind" (constant op_case.name)) + (req "source" Contract.encoding) + (req "nonce" uint16)) + (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) + (fun op -> + match ires_case.iselect op with + | Some (op, res) -> + Some (((), op.source, op.nonce), (ires_case.proj op.operation, res)) + | None -> None) + (fun (((), source, nonce), (op, res)) -> + let op = {source; operation = ires_case.inj op; nonce} in + Internal_manager_operation_result (op, res)) + in + def "apply_internal_results.alpha.operation_result" + @@ union + [ + make + Internal_manager_result.transaction_case + Internal_result.transaction_case; + make + Internal_manager_result.origination_case + Internal_result.origination_case; + make + Internal_manager_result.delegation_case + Internal_result.delegation_case; + ] diff --git a/src/proto_alpha/lib_protocol/apply_internal_results.mli b/src/proto_alpha/lib_protocol/apply_internal_results.mli index 47dd664a1a70..470a5ce207ea 100644 --- a/src/proto_alpha/lib_protocol/apply_internal_results.mli +++ b/src/proto_alpha/lib_protocol/apply_internal_results.mli @@ -22,3 +22,114 @@ (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) + +(** Types representing results of applying an internal operation. + + These are used internally by [Apply]. +*) + +open Alpha_context + +type 'kind internal_manager_operation = + | Transaction : { + amount : Tez.tez; + parameters : Script.lazy_expr; + entrypoint : Entrypoint.t; + destination : Destination.t; + } + -> Kind.transaction internal_manager_operation + | Origination : { + delegate : Signature.Public_key_hash.t option; + script : Script.t; + credit : Tez.tez; + } + -> Kind.origination internal_manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation internal_manager_operation + +type 'kind internal_contents = { + source : Contract.t; + operation : 'kind internal_manager_operation; + nonce : int; +} + +type packed_internal_contents = + | Internal_contents : 'kind internal_contents -> packed_internal_contents + +val contents_of_packed_internal_operation : + Script_typed_ir.packed_internal_operation -> packed_internal_contents + +val contents_of_packed_internal_operations : + Script_typed_ir.packed_internal_operation list -> + packed_internal_contents list + +(** Result of applying an internal transaction. *) +type successful_transaction_result = + | Transaction_to_contract_result of { + storage : Script.expr option; + lazy_storage_diff : Lazy_storage.diffs option; + balance_updates : Receipt.balance_updates; + originated_contracts : Contract_hash.t list; + consumed_gas : Gas.Arith.fp; + storage_size : Z.t; + paid_storage_size_diff : Z.t; + allocated_destination_contract : bool; + } + | Transaction_to_tx_rollup_result of { + ticket_hash : Ticket_hash.t; + balance_updates : Receipt.balance_updates; + consumed_gas : Gas.Arith.fp; + paid_storage_size_diff : Z.t; + } + | Transaction_to_sc_rollup_result of { + consumed_gas : Gas.Arith.fp; + inbox_after : Sc_rollup.Inbox.t; + } + +(** Result of applying an internal origination. *) +type successful_origination_result = { + lazy_storage_diff : Lazy_storage.diffs option; + balance_updates : Receipt.balance_updates; + originated_contracts : Contract_hash.t list; + consumed_gas : Gas.Arith.fp; + storage_size : Z.t; + paid_storage_size_diff : Z.t; +} + +(** Result of applying a {!Script_typed_ir.internal_operation}. *) +type _ successful_internal_manager_operation_result = + | ITransaction_result : + successful_transaction_result + -> Kind.transaction successful_internal_manager_operation_result + | IOrigination_result : + successful_origination_result + -> Kind.origination successful_internal_manager_operation_result + | IDelegation_result : { + consumed_gas : Gas.Arith.fp; + } + -> Kind.delegation successful_internal_manager_operation_result + +type 'kind internal_manager_operation_result = + ( 'kind, + 'kind Kind.manager, + 'kind successful_internal_manager_operation_result ) + Apply_operation_result.operation_result + +type packed_internal_manager_operation_result = + | Internal_manager_operation_result : + 'kind internal_contents * 'kind internal_manager_operation_result + -> packed_internal_manager_operation_result + +val contents_of_internal_operation : + 'kind Script_typed_ir.internal_operation -> 'kind internal_contents + +val pack_internal_manager_operation_result : + 'kind Script_typed_ir.internal_operation -> + 'kind internal_manager_operation_result -> + packed_internal_manager_operation_result + +val internal_contents_encoding : packed_internal_contents Data_encoding.t + +val internal_manager_operation_result_encoding : + packed_internal_manager_operation_result Data_encoding.t diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 91a05615afa8..f69f34ec0868 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -27,120 +27,13 @@ open Alpha_context open Data_encoding open Apply_operation_result - -type 'kind internal_manager_operation = - | Transaction : { - amount : Tez.tez; - parameters : Script.lazy_expr; - entrypoint : Entrypoint.t; - destination : Destination.t; - } - -> Kind.transaction internal_manager_operation - | Origination : { - delegate : Signature.Public_key_hash.t option; - script : Script.t; - credit : Tez.tez; - } - -> Kind.origination internal_manager_operation - | Delegation : - Signature.Public_key_hash.t option - -> Kind.delegation internal_manager_operation - -type packed_internal_manager_operation = - | Manager : - 'kind internal_manager_operation - -> packed_internal_manager_operation - -type 'kind internal_contents = { - source : Contract.t; - operation : 'kind internal_manager_operation; - nonce : int; -} - -type packed_internal_contents = - | Internal_contents : 'kind internal_contents -> packed_internal_contents - -let contents_of_internal_operation (type kind) - ({source; operation; nonce} : kind Script_typed_ir.internal_operation) : - kind internal_contents = - let operation : kind internal_manager_operation = - match operation with - | Transaction_to_contract - {destination; amount; entrypoint; unparsed_parameters; _} -> - Transaction - { - destination = Contract destination; - amount; - entrypoint; - parameters = Script.lazy_expr unparsed_parameters; - } - | Transaction_to_tx_rollup {destination; unparsed_parameters; _} -> - Transaction - { - destination = Tx_rollup destination; - (* Dummy amount used for the external untyped view of internal transactions *) - amount = Tez.zero; - entrypoint = Tx_rollup.deposit_entrypoint; - parameters = Script.lazy_expr unparsed_parameters; - } - | Transaction_to_sc_rollup {destination; entrypoint; unparsed_parameters; _} - -> - Transaction - { - destination = Sc_rollup destination; - amount = Tez.zero; - entrypoint; - parameters = Script.lazy_expr unparsed_parameters; - } - | Origination {delegate; code; unparsed_storage; credit; _} -> - let script = - { - Script.code = Script.lazy_expr code; - storage = Script.lazy_expr unparsed_storage; - } - in - Origination {delegate; script; credit} - | Delegation delegate -> Delegation delegate - in - {source; operation; nonce} - -let contents_of_packed_internal_operation - (Script_typed_ir.Internal_operation op) = - Internal_contents (contents_of_internal_operation op) - -let contents_of_packed_internal_operations = - List.map contents_of_packed_internal_operation +open Apply_internal_results type successful_transaction_result = - | Transaction_to_contract_result of { - storage : Script.expr option; - lazy_storage_diff : Lazy_storage.diffs option; - balance_updates : Receipt.balance_updates; - originated_contracts : Contract_hash.t list; - consumed_gas : Gas.Arith.fp; - storage_size : Z.t; - paid_storage_size_diff : Z.t; - allocated_destination_contract : bool; - } - | Transaction_to_tx_rollup_result of { - ticket_hash : Ticket_hash.t; - balance_updates : Receipt.balance_updates; - consumed_gas : Gas.Arith.fp; - paid_storage_size_diff : Z.t; - } - | Transaction_to_sc_rollup_result of { - consumed_gas : Gas.Arith.fp; - inbox_after : Sc_rollup.Inbox.t; - } + Apply_internal_results.successful_transaction_result -type successful_origination_result = { - lazy_storage_diff : Lazy_storage.diffs option; - balance_updates : Receipt.balance_updates; - originated_contracts : Contract_hash.t list; - consumed_gas : Gas.Arith.fp; - storage_size : Z.t; - paid_storage_size_diff : Z.t; -} +type successful_origination_result = + Apply_internal_results.successful_origination_result type _ successful_manager_operation_result = | Reveal_result : { @@ -271,23 +164,6 @@ type _ successful_manager_operation_result = } -> Kind.sc_rollup_recover_bond successful_manager_operation_result -type _ successful_internal_manager_operation_result = - | ITransaction_result : - successful_transaction_result - -> Kind.transaction successful_internal_manager_operation_result - | IOrigination_result : - successful_origination_result - -> Kind.origination successful_internal_manager_operation_result - | IDelegation_result : { - consumed_gas : Gas.Arith.fp; - } - -> Kind.delegation successful_internal_manager_operation_result - -type packed_successful_internal_manager_operation_result = - | Successful_internal_manager_result : - 'kind successful_internal_manager_operation_result - -> packed_successful_internal_manager_operation_result - let migration_origination_result_to_successful_manager_operation_result ({ balance_updates; @@ -324,23 +200,6 @@ type 'kind manager_operation_result = 'kind successful_manager_operation_result ) operation_result -type 'kind internal_manager_operation_result = - ( 'kind, - 'kind Kind.manager, - 'kind successful_internal_manager_operation_result ) - operation_result - -type packed_internal_manager_operation_result = - | Internal_manager_operation_result : - 'kind internal_contents * 'kind internal_manager_operation_result - -> packed_internal_manager_operation_result - -let pack_internal_manager_operation_result (type kind) - (internal_op : kind Script_typed_ir.internal_operation) - (manager_op : kind internal_manager_operation_result) = - let internal_op = contents_of_internal_operation internal_op in - Internal_manager_operation_result (internal_op, manager_op) - module Manager_result = struct type 'kind case = | MCase : { @@ -1009,447 +868,6 @@ module Manager_result = struct Sc_rollup_recover_bond_result {balance_updates; consumed_gas}) end -type 'kind iselect = - packed_internal_manager_operation_result -> - ('kind internal_contents * 'kind internal_manager_operation_result) option - -module Internal_result = struct - open Data_encoding - - type 'kind case = - | MCase : { - tag : int; - name : string; - encoding : 'a Data_encoding.t; - iselect : 'kind iselect; - select : - packed_internal_manager_operation -> - 'kind internal_manager_operation option; - proj : 'kind internal_manager_operation -> 'a; - inj : 'a -> 'kind internal_manager_operation; - } - -> 'kind case - [@@coq_force_gadt] - - let[@coq_axiom_with_reason "gadt"] transaction_contract_variant_cases = - union - [ - case - ~title:"To_contract" - (Tag 0) - (obj8 - (opt "storage" Script.expr_encoding) - (dft "balance_updates" Receipt.balance_updates_encoding []) - (dft "originated_contracts" (list Contract.originated_encoding) []) - (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) - (dft "storage_size" z Z.zero) - (dft "paid_storage_size_diff" z Z.zero) - (dft "allocated_destination_contract" bool false) - (opt "lazy_storage_diff" Lazy_storage.encoding)) - (function - | Transaction_to_contract_result - { - storage; - lazy_storage_diff; - balance_updates; - originated_contracts; - consumed_gas; - storage_size; - paid_storage_size_diff; - allocated_destination_contract; - } -> - Some - ( storage, - balance_updates, - originated_contracts, - consumed_gas, - storage_size, - paid_storage_size_diff, - allocated_destination_contract, - lazy_storage_diff ) - | _ -> None) - (fun ( storage, - balance_updates, - originated_contracts, - consumed_gas, - storage_size, - paid_storage_size_diff, - allocated_destination_contract, - lazy_storage_diff ) -> - Transaction_to_contract_result - { - storage; - lazy_storage_diff; - balance_updates; - originated_contracts; - consumed_gas; - storage_size; - paid_storage_size_diff; - allocated_destination_contract; - }); - case - ~title:"To_tx_rollup" - (Tag 1) - (obj4 - (dft "balance_updates" Receipt.balance_updates_encoding []) - (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) - (req "ticket_hash" Ticket_hash.encoding) - (req "paid_storage_size_diff" n)) - (function - | Transaction_to_tx_rollup_result - { - balance_updates; - consumed_gas; - ticket_hash; - paid_storage_size_diff; - } -> - Some - ( balance_updates, - consumed_gas, - ticket_hash, - paid_storage_size_diff ) - | _ -> None) - (fun ( balance_updates, - consumed_gas, - ticket_hash, - paid_storage_size_diff ) -> - Transaction_to_tx_rollup_result - { - balance_updates; - consumed_gas; - ticket_hash; - paid_storage_size_diff; - }); - case - ~title:"To_sc_rollup" - (Tag 2) - (obj2 - (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) - (req "inbox_after" Sc_rollup.Inbox.encoding)) - (function - | Transaction_to_sc_rollup_result {consumed_gas; inbox_after} -> - Some (consumed_gas, inbox_after) - | _ -> None) - (function - | consumed_gas, inbox_after -> - Transaction_to_sc_rollup_result {consumed_gas; inbox_after}); - ] - - let[@coq_axiom_with_reason "gadt"] transaction_case = - MCase - { - (* This value should be changed with care: maybe receipts are read by - external tools such as indexers. *) - tag = 1; - name = "transaction"; - encoding = - obj3 - (req "amount" Tez.encoding) - (req "destination" Destination.encoding) - (opt - "parameters" - (obj2 - (req "entrypoint" Entrypoint.smart_encoding) - (req "value" Script.lazy_expr_encoding))); - iselect : Kind.transaction iselect = - (function - | Internal_manager_operation_result - (({operation = Transaction _; _} as op), res) -> - Some (op, res) - | _ -> None); - select = - (function Manager (Transaction _ as op) -> Some op | _ -> None); - proj = - (function - | Transaction {amount; destination; parameters; entrypoint} -> - let parameters = - if - Script_repr.is_unit_parameter parameters - && Entrypoint.is_default entrypoint - then None - else Some (entrypoint, parameters) - in - (amount, destination, parameters)); - inj = - (fun (amount, destination, parameters) -> - let entrypoint, parameters = - match parameters with - | None -> (Entrypoint.default, Script.unit_parameter) - | Some (entrypoint, value) -> (entrypoint, value) - in - Transaction {amount; destination; parameters; entrypoint}); - } - - let[@coq_axiom_with_reason "gadt"] origination_case = - MCase - { - (* This value should be changed with care: maybe receipts are read by - external tools such as indexers. *) - tag = 2; - name = "origination"; - encoding = - obj3 - (req "balance" Tez.encoding) - (opt "delegate" Signature.Public_key_hash.encoding) - (req "script" Script.encoding); - iselect : Kind.origination iselect = - (function - | Internal_manager_operation_result - (({operation = Origination _; _} as op), res) -> - Some (op, res) - | _ -> None); - select = - (function Manager (Origination _ as op) -> Some op | _ -> None); - proj = - (function - | Origination {credit; delegate; script} -> (credit, delegate, script)); - inj = - (fun (credit, delegate, script) -> - Origination {credit; delegate; script}); - } - - let[@coq_axiom_with_reason "gadt"] delegation_case = - MCase - { - (* This value should be changed with care: maybe receipts are read by - external tools such as indexers. *) - tag = 3; - name = "delegation"; - encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding); - iselect : Kind.delegation iselect = - (function - | Internal_manager_operation_result - (({operation = Delegation _; _} as op), res) -> - Some (op, res) - | _ -> None); - select = - (function Manager (Delegation _ as op) -> Some op | _ -> None); - proj = (function Delegation key -> key); - inj = (fun key -> Delegation key); - } - - let case tag name args proj inj = - case - tag - ~title:(String.capitalize_ascii name) - (merge_objs (obj1 (req "kind" (constant name))) args) - (fun x -> match proj x with None -> None | Some x -> Some ((), x)) - (fun ((), x) -> inj x) - - let encoding = - let make (MCase {tag; name; encoding; iselect = _; select; proj; inj}) = - case - (Tag tag) - name - encoding - (fun o -> match select o with None -> None | Some o -> Some (proj o)) - (fun x -> Manager (inj x)) - in - union - ~tag_size:`Uint8 - [make transaction_case; make origination_case; make delegation_case] -end - -let internal_contents_encoding : packed_internal_contents Data_encoding.t = - def "apply_internal_results.alpha.operation_result" - @@ conv - (fun (Internal_contents {source; operation; nonce}) -> - ((source, nonce), Manager operation)) - (fun ((source, nonce), Manager operation) -> - Internal_contents {source; operation; nonce}) - (merge_objs - (obj2 (req "source" Contract.encoding) (req "nonce" uint16)) - Internal_result.encoding) - -module Internal_manager_result = struct - type 'kind case = - | MCase : { - op_case : 'kind Internal_result.case; - encoding : 'a Data_encoding.t; - kind : 'kind Kind.manager; - select : - packed_successful_internal_manager_operation_result -> - 'kind successful_internal_manager_operation_result option; - proj : 'kind successful_internal_manager_operation_result -> 'a; - inj : 'a -> 'kind successful_internal_manager_operation_result; - t : 'kind internal_manager_operation_result Data_encoding.t; - } - -> 'kind case - - let make ~op_case ~encoding ~kind ~select ~proj ~inj = - let (Internal_result.MCase {name; _}) = op_case in - let t = - def (Format.asprintf "operation.alpha.internal_operation_result.%s" name) - @@ union - ~tag_size:`Uint8 - [ - case - (Tag 0) - ~title:"Applied" - (merge_objs (obj1 (req "status" (constant "applied"))) encoding) - (fun o -> - match o with - | Skipped _ | Failed _ | Backtracked _ -> None - | Applied o -> ( - match select (Successful_internal_manager_result o) with - | None -> None - | Some o -> Some ((), proj o))) - (fun ((), x) -> Applied (inj x)); - case - (Tag 1) - ~title:"Failed" - (obj2 - (req "status" (constant "failed")) - (req "errors" trace_encoding)) - (function Failed (_, errs) -> Some ((), errs) | _ -> None) - (fun ((), errs) -> Failed (kind, errs)); - case - (Tag 2) - ~title:"Skipped" - (obj1 (req "status" (constant "skipped"))) - (function Skipped _ -> Some () | _ -> None) - (fun () -> Skipped kind); - case - (Tag 3) - ~title:"Backtracked" - (merge_objs - (obj2 - (req "status" (constant "backtracked")) - (opt "errors" trace_encoding)) - encoding) - (fun o -> - match o with - | Skipped _ | Failed _ | Applied _ -> None - | Backtracked (o, errs) -> ( - match select (Successful_internal_manager_result o) with - | None -> None - | Some o -> Some (((), errs), proj o))) - (fun (((), errs), x) -> Backtracked (inj x, errs)); - ] - in - MCase {op_case; encoding; kind; select; proj; inj; t} - - let[@coq_axiom_with_reason "gadt"] transaction_case = - make - ~op_case:Internal_result.transaction_case - ~encoding:Internal_result.transaction_contract_variant_cases - ~select:(function - | Successful_internal_manager_result (ITransaction_result _ as op) -> - Some op - | _ -> None) - ~kind:Kind.Transaction_manager_kind - ~proj:(function ITransaction_result x -> x) - ~inj:(fun x -> ITransaction_result x) - - let[@coq_axiom_with_reason "gadt"] origination_case = - make - ~op_case:Internal_result.origination_case - ~encoding: - (obj6 - (dft "balance_updates" Receipt.balance_updates_encoding []) - (dft "originated_contracts" (list Contract.originated_encoding) []) - (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) - (dft "storage_size" z Z.zero) - (dft "paid_storage_size_diff" z Z.zero) - (opt "lazy_storage_diff" Lazy_storage.encoding)) - ~select:(function - | Successful_internal_manager_result (IOrigination_result _ as op) -> - Some op - | _ -> None) - ~proj:(function - | IOrigination_result - { - lazy_storage_diff; - balance_updates; - originated_contracts; - consumed_gas; - storage_size; - paid_storage_size_diff; - } -> - (* There used to be a [legacy_lazy_storage_diff] returned as the - first component of the tuple below, and the non-legacy one - returned as the last component. The legacy one has been removed, - but it was chosen to keep the non-legacy one at its position, - hence the order difference with regards to the record above. *) - ( balance_updates, - originated_contracts, - consumed_gas, - storage_size, - paid_storage_size_diff, - lazy_storage_diff )) - ~kind:Kind.Origination_manager_kind - ~inj: - (fun ( balance_updates, - originated_contracts, - consumed_gas, - storage_size, - paid_storage_size_diff, - lazy_storage_diff ) -> - IOrigination_result - { - lazy_storage_diff; - balance_updates; - originated_contracts; - consumed_gas; - storage_size; - paid_storage_size_diff; - }) - - let delegation_case = - make - ~op_case:Internal_result.delegation_case - ~encoding: - Data_encoding.( - obj1 (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) - ~select:(function - | Successful_internal_manager_result (IDelegation_result _ as op) -> - Some op - | _ -> None) - ~kind:Kind.Delegation_manager_kind - ~proj:(function[@coq_match_with_default] - | IDelegation_result {consumed_gas} -> consumed_gas) - ~inj:(fun consumed_gas -> IDelegation_result {consumed_gas}) -end - -let internal_manager_operation_result_encoding : - packed_internal_manager_operation_result Data_encoding.t = - let make (type kind) - (Internal_manager_result.MCase res_case : - kind Internal_manager_result.case) - (Internal_result.MCase ires_case : kind Internal_result.case) = - let (Internal_result.MCase op_case) = res_case.op_case in - case - (Tag op_case.tag) - ~title:op_case.name - (merge_objs - (obj3 - (req "kind" (constant op_case.name)) - (req "source" Contract.encoding) - (req "nonce" uint16)) - (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) - (fun op -> - match ires_case.iselect op with - | Some (op, res) -> - Some (((), op.source, op.nonce), (ires_case.proj op.operation, res)) - | None -> None) - (fun (((), source, nonce), (op, res)) -> - let op = {source; operation = ires_case.inj op; nonce} in - Internal_manager_operation_result (op, res)) - in - def "apply_internal_results.alpha.operation_result" - @@ union - [ - make - Internal_manager_result.transaction_case - Internal_result.transaction_case; - make - Internal_manager_result.origination_case - Internal_result.origination_case; - make - Internal_manager_result.delegation_case - Internal_result.delegation_case; - ] - let successful_manager_operation_result_encoding : packed_successful_manager_operation_result Data_encoding.t = let make (type kind) diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index 875eb9c533ef..77f6256352bd 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -34,40 +34,7 @@ open Alpha_context open Apply_operation_result - -type 'kind internal_manager_operation = - | Transaction : { - amount : Tez.tez; - parameters : Script.lazy_expr; - entrypoint : Entrypoint.t; - destination : Destination.t; - } - -> Kind.transaction internal_manager_operation - | Origination : { - delegate : Signature.Public_key_hash.t option; - script : Script.t; - credit : Tez.tez; - } - -> Kind.origination internal_manager_operation - | Delegation : - Signature.Public_key_hash.t option - -> Kind.delegation internal_manager_operation - -type 'kind internal_contents = { - source : Contract.t; - operation : 'kind internal_manager_operation; - nonce : int; -} - -type packed_internal_contents = - | Internal_contents : 'kind internal_contents -> packed_internal_contents - -val contents_of_packed_internal_operation : - Script_typed_ir.packed_internal_operation -> packed_internal_contents - -val contents_of_packed_internal_operations : - Script_typed_ir.packed_internal_operation list -> - packed_internal_contents list +open Apply_internal_results (** Result of applying a {!Operation.t}. Follows the same structure. *) type 'kind operation_metadata = {contents : 'kind contents_result_list} @@ -140,44 +107,13 @@ and 'kind manager_operation_result = 'kind successful_manager_operation_result ) operation_result -and 'kind internal_manager_operation_result = - ( 'kind, - 'kind Kind.manager, - 'kind successful_internal_manager_operation_result ) - operation_result - -(** Result of applying a transaction, either internal or external. *) +(** Result of applying a transaction. *) and successful_transaction_result = - | Transaction_to_contract_result of { - storage : Script.expr option; - lazy_storage_diff : Lazy_storage.diffs option; - balance_updates : Receipt.balance_updates; - originated_contracts : Contract_hash.t list; - consumed_gas : Gas.Arith.fp; - storage_size : Z.t; - paid_storage_size_diff : Z.t; - allocated_destination_contract : bool; - } - | Transaction_to_tx_rollup_result of { - ticket_hash : Ticket_hash.t; - balance_updates : Receipt.balance_updates; - consumed_gas : Gas.Arith.fp; - paid_storage_size_diff : Z.t; - } - | Transaction_to_sc_rollup_result of { - consumed_gas : Gas.Arith.fp; - inbox_after : Sc_rollup.Inbox.t; - } + Apply_internal_results.successful_transaction_result -(** Result of applying an origination, either internal or external. *) -and successful_origination_result = { - lazy_storage_diff : Lazy_storage.diffs option; - balance_updates : Receipt.balance_updates; - originated_contracts : Contract_hash.t list; - consumed_gas : Gas.Arith.fp; - storage_size : Z.t; - paid_storage_size_diff : Z.t; -} +(** Result of applying an origination. *) +and successful_origination_result = + Apply_internal_results.successful_origination_result (** Result of applying an external {!manager_operation_content}. *) and _ successful_manager_operation_result = @@ -321,39 +257,11 @@ and _ successful_manager_operation_result = } -> Kind.sc_rollup_recover_bond successful_manager_operation_result -(** Result of applying a {!Script_typed_ir.internal_operation}. *) -and _ successful_internal_manager_operation_result = - | ITransaction_result : - successful_transaction_result - -> Kind.transaction successful_internal_manager_operation_result - | IOrigination_result : - successful_origination_result - -> Kind.origination successful_internal_manager_operation_result - | IDelegation_result : { - consumed_gas : Gas.Arith.fp; - } - -> Kind.delegation successful_internal_manager_operation_result - and packed_successful_manager_operation_result = | Successful_manager_result : 'kind successful_manager_operation_result -> packed_successful_manager_operation_result -and packed_internal_manager_operation_result = - | Internal_manager_operation_result : - 'kind internal_contents * 'kind internal_manager_operation_result - -> packed_internal_manager_operation_result - -val contents_of_internal_operation : - 'kind Script_typed_ir.internal_operation -> 'kind internal_contents - -val pack_internal_manager_operation_result : - 'kind Script_typed_ir.internal_operation -> - 'kind internal_manager_operation_result -> - packed_internal_manager_operation_result - -val internal_contents_encoding : packed_internal_contents Data_encoding.t - val pack_migration_operation_results : Migration.origination_result list -> packed_successful_manager_operation_result list -- GitLab From 7029175ef312121a23a99d18fed4141dd9e0c420 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 23 May 2022 11:07:54 +0200 Subject: [PATCH 09/10] Proto/Client: use Apply_internal_results. --- .../lib_client/client_proto_programs.mli | 8 ++++---- src/proto_alpha/lib_client/injection.ml | 1 + src/proto_alpha/lib_client/operation_result.ml | 1 + src/proto_alpha/lib_client/operation_result.mli | 2 +- .../lib_client/protocol_client_context.ml | 2 +- src/proto_alpha/lib_plugin/RPC.ml | 14 ++++++++++---- src/proto_alpha/lib_protocol/apply.ml | 11 +++++++---- src/proto_alpha/lib_protocol/apply.mli | 1 + .../lib_protocol/script_ir_translator.ml | 4 ++-- .../lib_protocol/test/helpers/incremental.ml | 1 + src/proto_alpha/lib_tx_rollup/daemon.ml | 1 + 11 files changed, 30 insertions(+), 16 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index f24f4abeaa66..dd6f3ff33530 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -91,7 +91,7 @@ val run : block:Shell_services.block -> run_params -> (Script.expr - * Apply_results.packed_internal_contents list + * Apply_internal_results.packed_internal_contents list * Lazy_storage.diffs option) tzresult Lwt.t @@ -102,7 +102,7 @@ val trace : block:Shell_services.block -> run_params -> (Script.expr - * Apply_results.packed_internal_contents list + * Apply_internal_results.packed_internal_contents list * Script_typed_ir.execution_trace * Lazy_storage.diffs option) tzresult @@ -118,7 +118,7 @@ val print_run_result : show_source:bool -> parsed:Michelson_v1_parser.parsed -> (Script_repr.expr - * Apply_results.packed_internal_contents list + * Apply_internal_results.packed_internal_contents list * Lazy_storage.diffs option) tzresult -> unit tzresult Lwt.t @@ -128,7 +128,7 @@ val print_trace_result : show_source:bool -> parsed:Michelson_v1_parser.parsed -> (Script_repr.expr - * Apply_results.packed_internal_contents list + * Apply_internal_results.packed_internal_contents list * Script_typed_ir.execution_trace * Lazy_storage.diffs option) tzresult -> diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index 4c32f5911472..d0a1fd86f59f 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -28,6 +28,7 @@ open Protocol open Alpha_context open Apply_results open Apply_operation_result +open Apply_internal_results open Protocol_client_context let get_branch (rpc_config : #Protocol_client_context.full) ~chain diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index 12826a0afc3b..30404d93707b 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -28,6 +28,7 @@ open Protocol open Alpha_context open Apply_results open Apply_operation_result +open Apply_internal_results let tez_sym = "\xEA\x9C\xA9" diff --git a/src/proto_alpha/lib_client/operation_result.mli b/src/proto_alpha/lib_client/operation_result.mli index a55ca529bff5..d6ed7d353edd 100644 --- a/src/proto_alpha/lib_client/operation_result.mli +++ b/src/proto_alpha/lib_client/operation_result.mli @@ -29,7 +29,7 @@ open Alpha_context val tez_sym : string val pp_internal_operation : - Format.formatter -> Apply_results.packed_internal_contents -> unit + Format.formatter -> Apply_internal_results.packed_internal_contents -> unit val pp_operation_result : Format.formatter -> diff --git a/src/proto_alpha/lib_client/protocol_client_context.ml b/src/proto_alpha/lib_client/protocol_client_context.ml index ec6d063abd5d..e745abd0afd8 100644 --- a/src/proto_alpha/lib_client/protocol_client_context.ml +++ b/src/proto_alpha/lib_client/protocol_client_context.ml @@ -206,7 +206,7 @@ let () = @@ def "operation" ["internal"] - Protocol.Apply_results.internal_contents_encoding ; + Protocol.Apply_internal_results.internal_contents_encoding ; register @@ def "operation" diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 89c04a82a010..b0651d5fe63d 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -181,7 +181,9 @@ module Scripts = struct (storage, operations, lazy_storage_diff)) (obj3 (req "storage" Script.expr_encoding) - (req "operations" (list Apply_results.internal_contents_encoding)) + (req + "operations" + (list Apply_internal_results.internal_contents_encoding)) (opt "lazy_storage_diff" Lazy_storage.encoding)) let trace_code_input_encoding = run_code_input_encoding @@ -201,7 +203,9 @@ module Scripts = struct (storage, operations, trace, lazy_storage_diff)) (obj4 (req "storage" Script.expr_encoding) - (req "operations" (list Apply_results.internal_contents_encoding)) + (req + "operations" + (list Apply_internal_results.internal_contents_encoding)) (req "trace" trace_encoding) (opt "lazy_storage_diff" Lazy_storage.encoding)) @@ -1042,7 +1046,8 @@ module Scripts = struct }, _ ) -> ( storage, - Apply_results.contents_of_packed_internal_operations operations, + Apply_internal_results.contents_of_packed_internal_operations + operations, lazy_storage_diff )) ; Registration.register0 ~chunked:true @@ -1114,7 +1119,8 @@ module Scripts = struct _ctxt ), trace ) -> ( storage, - Apply_results.contents_of_packed_internal_operations operations, + Apply_internal_results.contents_of_packed_internal_operations + operations, trace, lazy_storage_diff )) ; Registration.register0 diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 6c36ca11c20b..c64a2c6464c2 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -101,7 +101,7 @@ type error += | Sc_rollup_feature_disabled | Inconsistent_counters | Wrong_voting_period of {expected : int32; provided : int32} - | Internal_operation_replay of Apply_results.packed_internal_contents + | Internal_operation_replay of Apply_internal_results.packed_internal_contents | Invalid_denunciation of denunciation_kind | Inconsistent_denunciation of { kind : denunciation_kind; @@ -571,12 +571,12 @@ let () = ~id:"internal_operation_replay" ~title:"Internal operation replay" ~description:"An internal operation was emitted twice by a script" - ~pp:(fun ppf (Apply_results.Internal_contents {nonce; _}) -> + ~pp:(fun ppf (Apply_internal_results.Internal_contents {nonce; _}) -> Format.fprintf ppf "Internal operation %d was emitted twice by a script" nonce) - Apply_results.internal_contents_encoding + Apply_internal_results.internal_contents_encoding (function Internal_operation_replay op -> Some op | _ -> None) (fun op -> Internal_operation_replay op) ; register_error_kind @@ -812,6 +812,7 @@ let () = open Apply_results open Apply_operation_result +open Apply_internal_results let assert_tx_rollup_feature_enabled ctxt = let level = (Level.current ctxt).level in @@ -1930,7 +1931,9 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = | Script_typed_ir.Internal_operation ({source; operation; nonce} as op) :: rest -> ( (if internal_nonce_already_recorded ctxt nonce then - let op_res = Apply_results.contents_of_internal_operation op in + let op_res = + Apply_internal_results.contents_of_internal_operation op + in fail (Internal_operation_replay (Internal_contents op_res)) else let ctxt = record_internal_nonce ctxt nonce in diff --git a/src/proto_alpha/lib_protocol/apply.mli b/src/proto_alpha/lib_protocol/apply.mli index f2b8258f2cdb..f01e01ece70a 100644 --- a/src/proto_alpha/lib_protocol/apply.mli +++ b/src/proto_alpha/lib_protocol/apply.mli @@ -35,6 +35,7 @@ open Alpha_context open Apply_results +open Apply_internal_results type error += | Internal_operation_replay of packed_internal_contents diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 4b9b7a3886b6..314297165775 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -416,10 +416,10 @@ let unparse_key_hash ~loc ctxt mode k = (* Operations are only unparsed during the production of execution traces of the interpreter. *) let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} = - let iop = Apply_results.contents_of_packed_internal_operation piop in + let iop = Apply_internal_results.contents_of_packed_internal_operation piop in let bytes = Data_encoding.Binary.to_bytes_exn - Apply_results.internal_contents_encoding + Apply_internal_results.internal_contents_encoding iop in Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt -> diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index 8f7a9739d040..7c03e9c1d9ba 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -126,6 +126,7 @@ let detect_script_failure : type kind. kind Apply_results.contents_result_list -> _ = let open Apply_results in let open Apply_operation_result in + let open Apply_internal_results in let detect_script_failure_single (type kind) (Manager_operation_result {operation_result; internal_operation_results; _} : diff --git a/src/proto_alpha/lib_tx_rollup/daemon.ml b/src/proto_alpha/lib_tx_rollup/daemon.ml index ab1daee67c2d..3874d3085fd2 100644 --- a/src/proto_alpha/lib_tx_rollup/daemon.ml +++ b/src/proto_alpha/lib_tx_rollup/daemon.ml @@ -26,6 +26,7 @@ (*****************************************************************************) open Protocol.Apply_results +open Protocol.Apply_internal_results open Tezos_shell_services open Protocol_client_context open Protocol -- GitLab From 00f9d03bfe82bd9f58f5e5f00df7bc7f10efb1a1 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Wed, 15 Jun 2022 10:11:17 +0200 Subject: [PATCH 10/10] Proto: changelog for internal operation result encoding names. --- docs/protocols/alpha.rst | 2 ++ 1 file changed, 2 insertions(+) diff --git a/docs/protocols/alpha.rst b/docs/protocols/alpha.rst index 401e40e25793..889b6585514b 100644 --- a/docs/protocols/alpha.rst +++ b/docs/protocols/alpha.rst @@ -51,6 +51,8 @@ Operation receipts - Remove field ``consumed_gas``, deprecated in Jakarta. Use field ``consumed_milligas`` instead. (:gl:`!5536`) +- Operations that are both manager operations and internal operations returned by Michelson scripts now have different names for receipt encodings. This concerns transations, originations and delegations, where the word "internal" explicitly appears in the case of internal operation receipts. (:gl:`!5149`) + Bug Fixes --------- -- GitLab