From 0d928445ba61cc7f569c01e5ab63ab28329e3a19 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Wed, 18 May 2022 15:01:25 +0200 Subject: [PATCH 1/5] Proto: add parameters to Apply_results.manager_operation_results. So that it can be used for both internal and external successful operations, whose types will be made different later. --- src/proto_alpha/lib_protocol/apply_results.ml | 28 +++++++++++++++---- .../lib_protocol/apply_results.mli | 28 ++++++++++++++----- 2 files changed, 43 insertions(+), 13 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 401d1393c010..0d26dfced4c5 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -289,14 +289,30 @@ let pack_migration_operation_results results = (migration_origination_result_to_successful_manager_operation_result el)) results -type 'kind manager_operation_result = - | Applied of 'kind successful_manager_operation_result - | Backtracked of - 'kind successful_manager_operation_result * error trace option - | Failed : 'kind Kind.manager * error trace -> 'kind manager_operation_result - | Skipped : 'kind Kind.manager -> 'kind manager_operation_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. *) +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, + 'kind successful_manager_operation_result ) + operation_result + type packed_internal_manager_operation_result = | Internal_manager_operation_result : 'kind internal_contents * 'kind manager_operation_result diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index efd00ffc6bd6..1c9477b09b2a 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -131,15 +131,29 @@ and packed_contents_result = | Contents_result : 'kind contents_result -> packed_contents_result (** The result of an operation in the queue. [Skipped] ones should - always be at the tail, and after a single [Failed]. *) -and 'kind manager_operation_result = - | Applied of 'kind successful_manager_operation_result - | Backtracked of - 'kind successful_manager_operation_result * error trace option - | Failed : 'kind Kind.manager * error trace -> 'kind manager_operation_result - | Skipped : 'kind Kind.manager -> 'kind manager_operation_result + 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, + 'kind successful_manager_operation_result ) + operation_result + (** Result of applying a transaction, either internal or external. *) and successful_transaction_result = | Transaction_to_contract_result of { -- GitLab From 657618db8d6ffaf9540739ce16191f3e3a62eec8 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Wed, 18 May 2022 13:32:24 +0200 Subject: [PATCH 2/5] Proto: separate internal and external operation results. --- src/proto_alpha/lib_protocol/apply.ml | 9 ++++++++- src/proto_alpha/lib_protocol/apply_results.ml | 14 ++++++++++---- src/proto_alpha/lib_protocol/apply_results.mli | 10 ++++++++-- .../lib_protocol/test/helpers/incremental.ml | 2 +- 4 files changed, 27 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 8eb714384386..39a762c5db3f 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -2624,13 +2624,20 @@ let mark_backtracked results = and mark_internal_operation_results (Internal_manager_operation_result (kind, result)) = Internal_manager_operation_result - (kind, mark_manager_operation_result result) + (kind, mark_internal_manager_operation_result result) and mark_manager_operation_result : type kind. kind manager_operation_result -> kind manager_operation_result = function | (Failed _ | Skipped _ | Backtracked _) as result -> result | Applied (Reveal_result _) as result -> result | Applied result -> Backtracked (result, None) + and mark_internal_manager_operation_result : + type kind. + kind internal_manager_operation_result -> + kind internal_manager_operation_result = function + | (Failed _ | Skipped _ | Backtracked _) as result -> result + | Applied (Reveal_result _) as result -> result + | Applied result -> Backtracked (result, None) in mark_contents_list results [@@coq_axiom_with_reason "non-top-level mutual recursion"] diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 0d26dfced4c5..568246a77b03 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -313,14 +313,20 @@ type 'kind manager_operation_result = 'kind successful_manager_operation_result ) operation_result +type 'kind internal_manager_operation_result = + ( 'kind, + 'kind Kind.manager, + 'kind successful_manager_operation_result ) + operation_result + type packed_internal_manager_operation_result = | Internal_manager_operation_result : - 'kind internal_contents * 'kind 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 manager_operation_result) = + (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) @@ -1122,7 +1128,7 @@ end type 'kind iselect = packed_internal_manager_operation_result -> - ('kind internal_contents * 'kind manager_operation_result) option + ('kind internal_contents * 'kind internal_manager_operation_result) option module Internal_result = struct open Data_encoding @@ -1279,7 +1285,7 @@ module Internal_manager_result = struct 'kind successful_manager_operation_result option; proj : 'kind successful_manager_operation_result -> 'a; inj : 'a -> 'kind successful_manager_operation_result; - t : 'kind manager_operation_result Data_encoding.t; + t : 'kind internal_manager_operation_result Data_encoding.t; } -> 'kind case diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index 1c9477b09b2a..5f6061a21a61 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -154,6 +154,12 @@ and 'kind manager_operation_result = 'kind successful_manager_operation_result ) operation_result +and 'kind internal_manager_operation_result = + ( 'kind, + 'kind Kind.manager, + 'kind successful_manager_operation_result ) + operation_result + (** Result of applying a transaction, either internal or external. *) and successful_transaction_result = | Transaction_to_contract_result of { @@ -327,7 +333,7 @@ and packed_successful_manager_operation_result = and packed_internal_manager_operation_result = | Internal_manager_operation_result : - 'kind internal_contents * 'kind manager_operation_result + 'kind internal_contents * 'kind internal_manager_operation_result -> packed_internal_manager_operation_result val contents_of_internal_operation : @@ -335,7 +341,7 @@ val contents_of_internal_operation : val pack_internal_manager_operation_result : 'kind Script_typed_ir.internal_operation -> - 'kind manager_operation_result -> + 'kind internal_manager_operation_result -> packed_internal_manager_operation_result val internal_contents_encoding : packed_internal_contents Data_encoding.t diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index e33ad28ded18..5daa83bf2b01 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -130,7 +130,7 @@ let detect_script_failure : {operation_result; internal_operation_results; _} : kind Kind.manager Apply_results.contents_result) = let detect_script_failure (type kind) - (result : kind manager_operation_result) = + (result : (kind, _, _) operation_result) = match result with | Applied _ -> Ok () | Skipped _ -> assert false -- GitLab From 44c494208cae67a288a17e13e13910826aaa8259 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Wed, 18 May 2022 15:37:28 +0200 Subject: [PATCH 3/5] Client: separate internal and external operation results. By copy/pasting code of the corresponding external operation results functions. The internal operation results functions will be restricted to internal operations later, by removing the branches specific to external operations (typechecking will fail if we forget some). --- src/proto_alpha/lib_client/injection.ml | 141 ++++++++++- .../lib_client/operation_result.ml | 238 +++++++++++++++++- 2 files changed, 374 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index 28465244ae55..9f39f520f315 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -348,10 +348,54 @@ let estimated_gas_single (type kind) | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) in + let internal_consumed_gas (type kind) + (result : kind internal_manager_operation_result) = + match result with + | Applied + (Transaction_result (Transaction_to_contract_result {consumed_gas; _})) + | Applied + (Transaction_result (Transaction_to_tx_rollup_result {consumed_gas; _})) + -> + Ok consumed_gas + | Applied (Origination_result {consumed_gas; _}) -> Ok consumed_gas + | Applied (Reveal_result {consumed_gas}) -> Ok consumed_gas + | Applied (Delegation_result {consumed_gas}) -> Ok consumed_gas + | Applied (Register_global_constant_result {consumed_gas; _}) -> + Ok consumed_gas + | Applied (Set_deposits_limit_result {consumed_gas}) -> Ok consumed_gas + | Applied (Tx_rollup_origination_result {consumed_gas; _}) -> + Ok consumed_gas + | Applied (Tx_rollup_submit_batch_result {consumed_gas; _}) -> + Ok consumed_gas + | Applied (Tx_rollup_commit_result {consumed_gas; _}) -> Ok consumed_gas + | Applied (Tx_rollup_return_bond_result {consumed_gas; _}) -> + Ok consumed_gas + | Applied (Tx_rollup_finalize_commitment_result {consumed_gas; _}) -> + Ok consumed_gas + | Applied (Tx_rollup_remove_commitment_result {consumed_gas; _}) -> + Ok consumed_gas + | Applied (Tx_rollup_rejection_result {consumed_gas; _}) -> Ok consumed_gas + | Applied (Tx_rollup_dispatch_tickets_result {consumed_gas; _}) -> + Ok consumed_gas + | Applied (Transfer_ticket_result {consumed_gas; _}) -> Ok consumed_gas + | Applied (Sc_rollup_originate_result {consumed_gas; _}) -> Ok consumed_gas + | Applied (Sc_rollup_add_messages_result {consumed_gas; _}) -> + Ok consumed_gas + | Applied (Sc_rollup_cement_result {consumed_gas; _}) -> Ok consumed_gas + | Applied (Sc_rollup_publish_result {consumed_gas; _}) -> Ok consumed_gas + | Applied (Sc_rollup_refute_result {consumed_gas; _}) -> Ok consumed_gas + | Applied (Sc_rollup_timeout_result {consumed_gas; _}) -> Ok consumed_gas + | Skipped _ -> + Ok Gas.Arith.zero (* there must be another error for this to happen *) + | Backtracked (_, None) -> + Ok Gas.Arith.zero (* there must be another error for this to happen *) + | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) + | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) + in consumed_gas operation_result >>? fun gas -> List.fold_left_e (fun acc (Internal_manager_operation_result (_, r)) -> - consumed_gas r >>? fun gas -> Ok (Gas.Arith.add acc gas)) + internal_consumed_gas r >>? fun gas -> Ok (Gas.Arith.add acc gas)) gas internal_operation_results @@ -414,10 +458,64 @@ let estimated_storage_single (type kind) ~tx_rollup_origination_size | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) in + let internal_storage_size_diff (type kind) + (result : kind internal_manager_operation_result) = + match result with + | Applied + (Transaction_result + (Transaction_to_contract_result + {paid_storage_size_diff; allocated_destination_contract; _})) -> + if allocated_destination_contract then + Ok (Z.add paid_storage_size_diff origination_size) + else Ok paid_storage_size_diff + | Applied (Transaction_result (Transaction_to_tx_rollup_result _)) -> + (* TODO: https://gitlab.com/tezos/tezos/-/issues/2339 + Storage fees for transaction rollup. + We need to charge for newly allocated storage (as we do for + Michelson’s big map). *) + Ok Z.zero + | Applied (Origination_result {paid_storage_size_diff; _}) -> + Ok (Z.add paid_storage_size_diff origination_size) + | Applied (Reveal_result _) -> Ok Z.zero + | Applied (Delegation_result _) -> Ok Z.zero + | Applied (Register_global_constant_result {size_of_constant; _}) -> + Ok size_of_constant + | Applied (Set_deposits_limit_result _) -> Ok Z.zero + | Applied (Tx_rollup_origination_result _) -> Ok tx_rollup_origination_size + | Applied (Tx_rollup_submit_batch_result {paid_storage_size_diff; _}) -> + Ok paid_storage_size_diff + | Applied (Tx_rollup_commit_result _) -> Ok Z.zero + | Applied (Tx_rollup_return_bond_result _) -> Ok Z.zero + | Applied (Tx_rollup_finalize_commitment_result _) -> Ok Z.zero + | Applied (Tx_rollup_remove_commitment_result _) -> Ok Z.zero + | Applied (Tx_rollup_rejection_result _) -> Ok Z.zero + | Applied (Tx_rollup_dispatch_tickets_result {paid_storage_size_diff; _}) -> + Ok paid_storage_size_diff + | Applied (Transfer_ticket_result {paid_storage_size_diff; _}) -> + Ok paid_storage_size_diff + | Applied (Sc_rollup_originate_result {size; _}) -> Ok size + | Applied (Sc_rollup_add_messages_result _) -> Ok Z.zero + (* The following Sc_rollup operations have zero storage cost because we + consider them to be paid in the stake deposit. + + TODO: https://gitlab.com/tezos/tezos/-/issues/2686 + Document why this is safe. + *) + | Applied (Sc_rollup_cement_result _) -> Ok Z.zero + | Applied (Sc_rollup_publish_result _) -> Ok Z.zero + | Applied (Sc_rollup_refute_result _) -> Ok Z.zero + | Applied (Sc_rollup_timeout_result _) -> Ok Z.zero + | Skipped _ -> + Ok Z.zero (* there must be another error for this to happen *) + | Backtracked (_, None) -> + Ok Z.zero (* there must be another error for this to happen *) + | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) + | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) + in storage_size_diff operation_result >>? fun storage -> List.fold_left_e (fun acc (Internal_manager_operation_result (_, r)) -> - storage_size_diff r >>? fun storage -> Ok (Z.add acc storage)) + internal_storage_size_diff r >>? fun storage -> Ok (Z.add acc storage)) storage internal_operation_results @@ -480,11 +578,46 @@ let originated_contracts_single (type kind) | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) in + let internal_originated_contracts (type kind) + (result : kind internal_manager_operation_result) = + match result with + | Applied + (Transaction_result + (Transaction_to_contract_result {originated_contracts; _})) -> + Ok originated_contracts + | Applied (Transaction_result (Transaction_to_tx_rollup_result _)) -> Ok [] + | Applied (Origination_result {originated_contracts; _}) -> + Ok originated_contracts + | Applied (Register_global_constant_result _) -> Ok [] + | Applied (Reveal_result _) -> Ok [] + | Applied (Delegation_result _) -> Ok [] + | Applied (Set_deposits_limit_result _) -> Ok [] + | Applied (Tx_rollup_origination_result _) -> Ok [] + | Applied (Tx_rollup_submit_batch_result _) -> Ok [] + | Applied (Tx_rollup_commit_result _) -> Ok [] + | Applied (Tx_rollup_return_bond_result _) -> Ok [] + | Applied (Tx_rollup_finalize_commitment_result _) -> Ok [] + | Applied (Tx_rollup_remove_commitment_result _) -> Ok [] + | Applied (Tx_rollup_rejection_result _) -> Ok [] + | Applied (Tx_rollup_dispatch_tickets_result _) -> Ok [] + | Applied (Transfer_ticket_result _) -> Ok [] + | Applied (Sc_rollup_originate_result _) -> Ok [] + | Applied (Sc_rollup_add_messages_result _) -> Ok [] + | Applied (Sc_rollup_cement_result _) -> Ok [] + | Applied (Sc_rollup_publish_result _) -> Ok [] + | Applied (Sc_rollup_refute_result _) -> Ok [] + | Applied (Sc_rollup_timeout_result _) -> Ok [] + | Skipped _ -> Ok [] (* there must be another error for this to happen *) + | Backtracked (_, None) -> + Ok [] (* there must be another error for this to happen *) + | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) + | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) + in originated_contracts operation_result >>? fun contracts -> let contracts = List.rev contracts in List.fold_left_e (fun acc (Internal_manager_operation_result (_, r)) -> - originated_contracts r >>? fun contracts -> + internal_originated_contracts r >>? fun contracts -> Ok (List.rev_append contracts acc)) contracts internal_operation_results @@ -530,7 +663,7 @@ let detect_script_failure : type kind. kind operation_metadata -> _ = {operation_result; internal_operation_results; _} : kind Kind.manager contents_result) = let detect_script_failure (type kind) - (result : kind manager_operation_result) = + (result : (kind, _, _) operation_result) = match result with | Applied _ -> Ok () | Skipped _ -> assert false diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index a2bf8f51489d..4e12946dfaef 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -1012,6 +1012,242 @@ let pp_manager_operation_contents_and_result ppf expected effects (as follow) were NOT applied.@]" ; pp_sc_rollup_atomic_batch_result op in + let pp_internal_result (type kind) ppf + (result : kind internal_manager_operation_result) = + Format.fprintf ppf "@," ; + match result with + | Skipped _ -> Format.fprintf ppf "This operation was skipped" + | Failed (_, _errs) -> Format.fprintf ppf "This operation FAILED." + | Applied (Reveal_result {consumed_gas}) -> + Format.fprintf ppf "This revelation was successfully applied" ; + Format.fprintf ppf "@,Consumed gas: %a" Gas.Arith.pp consumed_gas + | Backtracked (Reveal_result _, _) -> + Format.fprintf + ppf + "@[This revelation was BACKTRACKED, its expected effects were \ + NOT applied.@]" + | Applied (Delegation_result {consumed_gas}) -> + Format.fprintf ppf "This delegation was successfully applied" ; + Format.fprintf ppf "@,Consumed gas: %a" Gas.Arith.pp consumed_gas + | Backtracked (Delegation_result _, _) -> + Format.fprintf + ppf + "@[This delegation was BACKTRACKED, its expected effects were \ + NOT applied.@]" + | Applied (Set_deposits_limit_result {consumed_gas}) -> + Format.fprintf ppf "The deposits limit was successfully set" ; + Format.fprintf ppf "@,Consumed gas: %a" Gas.Arith.pp consumed_gas + | Backtracked (Set_deposits_limit_result _, _) -> + Format.fprintf + ppf + "@[This deposits limit modification was BACKTRACKED, its \ + expected effects were NOT applied.@]" + | Applied (Transaction_result tx) -> + Format.fprintf ppf "This transaction was successfully applied" ; + pp_transaction_result tx + | Backtracked (Transaction_result tx, _errs) -> + Format.fprintf + ppf + "@[This transaction was BACKTRACKED, its expected effects (as \ + follow) were NOT applied.@]" ; + pp_transaction_result tx + | Applied (Origination_result op_res) -> + Format.fprintf ppf "This origination was successfully applied" ; + pp_origination_result op_res + | Backtracked (Origination_result op_res, _errs) -> + Format.fprintf + ppf + "@[This origination was BACKTRACKED, its expected effects (as \ + follow) were NOT applied.@]" ; + pp_origination_result op_res + | Applied (Register_global_constant_result _ as op) -> + Format.fprintf + ppf + "This global constant registration was successfully applied" ; + pp_register_global_constant_result op + | Backtracked ((Register_global_constant_result _ as op), _errs) -> + Format.fprintf + ppf + "@[This registration of a global constant was BACKTRACKED, its \ + expected effects (as follow) were NOT applied.@]" ; + pp_register_global_constant_result op + | Applied (Tx_rollup_origination_result _ as op) -> + Format.fprintf + ppf + "This tx rollup origination operation was successfully applied" ; + pp_tx_rollup_result op + | Backtracked ((Tx_rollup_origination_result _ as op), _err) -> + Format.fprintf + ppf + "@[This rollup operation was BACKTRACKED, its expected effects \ + (as follow) were NOT applied.@]" ; + pp_tx_rollup_result op + | Applied (Tx_rollup_submit_batch_result _ as op) -> + Format.fprintf + ppf + "This tx rollup submit operation was successfully applied" ; + pp_tx_rollup_submit_batch_result op + | Backtracked ((Tx_rollup_submit_batch_result _ as op), _err) -> + Format.fprintf + ppf + "@[This rollup submit operation was BACKTRACKED, its expected \ + effects (as follow) were NOT applied.@]" ; + pp_tx_rollup_submit_batch_result op + | Applied (Tx_rollup_commit_result _ as op) -> + Format.fprintf + ppf + "This tx rollup commit operation was successfully applied" ; + pp_tx_rollup_commit_result op + | Backtracked ((Tx_rollup_commit_result _ as op), _err) -> + Format.fprintf + ppf + "@[This tx rollup commit operation was BACKTRACKED, its \ + expected effects (as follow) were NOT applied.@]" ; + pp_tx_rollup_commit_result op + | Applied (Tx_rollup_return_bond_result _ as op) -> + Format.fprintf + ppf + "This tx rollup return commitment bond operation was successfully \ + applied" ; + pp_tx_rollup_return_bond_result op + | Backtracked ((Tx_rollup_return_bond_result _ as op), _err) -> + Format.fprintf + ppf + "@[This tx rollup return commitment bond operation was \ + BACKTRACKED, its expected effects (as follow) were NOT applied.@]" ; + pp_tx_rollup_return_bond_result op + | Applied (Tx_rollup_finalize_commitment_result _ as op) -> + Format.fprintf + ppf + "This tx rollup finalize operation was successfully applied" ; + pp_tx_rollup_finalize_commitment_result op + | Backtracked ((Tx_rollup_finalize_commitment_result _ as op), _err) -> + Format.fprintf + ppf + "@[This tx rollup finalize operation was BACKTRACKED, its \ + expected effects (as follow) were NOT applied.@]" ; + pp_tx_rollup_finalize_commitment_result op + | Applied (Tx_rollup_remove_commitment_result _ as op) -> + Format.fprintf + ppf + "This tx rollup remove operation was successfully applied" ; + pp_tx_rollup_remove_commitment_result op + | Backtracked ((Tx_rollup_remove_commitment_result _ as op), _err) -> + Format.fprintf + ppf + "@[This tx rollup remove operation was BACKTRACKED, its \ + expected effects (as follow) were NOT applied.@]" ; + pp_tx_rollup_remove_commitment_result op + | Applied (Tx_rollup_rejection_result _ as op) -> + Format.fprintf + ppf + "This tx rollup rejection operation was successfully applied" ; + pp_tx_rollup_rejection_result op + | Backtracked ((Tx_rollup_rejection_result _ as op), _err) -> + Format.fprintf + ppf + "@[This tx rollup rejection operation was BACKTRACKED, its \ + expected effects (as follow) were NOT applied.@]" ; + pp_tx_rollup_rejection_result op + | Applied (Tx_rollup_dispatch_tickets_result _ as op) -> + Format.fprintf + ppf + "This tx rollup reveal_withdrawals operation was successfully applied" ; + pp_tx_rollup_dispatch_tickets_result op + | Backtracked ((Tx_rollup_dispatch_tickets_result _ as op), _err) -> + Format.fprintf + ppf + "@[This tx rollup reveal_withdrawals rollup operation was \ + BACKTRACKED, its expected effects (as follow) were NOT applied.@]" ; + pp_tx_rollup_dispatch_tickets_result op + | Applied (Transfer_ticket_result _ as op) -> + Format.fprintf + ppf + "This transfer ticket operation was successfully applied" ; + pp_transfer_ticket_result op + | Backtracked ((Transfer_ticket_result _ as op), _err) -> + Format.fprintf + ppf + "@[This transfer ticket operation was BACKTRACKED, its expected \ + effects (as follow) were NOT applied.@]" ; + pp_transfer_ticket_result op + | Applied (Sc_rollup_originate_result _ as op) -> + Format.fprintf + ppf + "This smart contract rollup origination was successfully applied" ; + pp_sc_rollup_originate_result op + | Backtracked ((Sc_rollup_originate_result _ as op), _errs) -> + Format.fprintf + ppf + "@[This rollup origination was BACKTRACKED, its expected \ + effects (as follow) were NOT applied.@]" ; + pp_sc_rollup_originate_result op + | Applied (Sc_rollup_add_messages_result _ as op) -> + Format.fprintf + ppf + "This operation sending a message to a smart contract rollup was \ + successfully applied" ; + pp_sc_rollup_add_messages_result op + | Backtracked ((Sc_rollup_add_messages_result _ as op), _errs) -> + Format.fprintf + ppf + "@[This operation sending a message to a smart contract rollup \ + was BACKTRACKED, its expected effects (as follow) were NOT \ + applied.@]" ; + pp_sc_rollup_add_messages_result op + | Applied (Sc_rollup_cement_result _ as op) -> + Format.fprintf + ppf + "This operation cementing a commitment on a smart contract rollup \ + was successfully applied" ; + pp_sc_rollup_cement_result op + | Backtracked ((Sc_rollup_cement_result _ as op), _errs) -> + Format.fprintf + ppf + "@[This operation cementing a commitment on a smart contract \ + rollup was BACKTRACKED, its expected effects (as follow) were NOT \ + applied.@]" ; + pp_sc_rollup_cement_result op + | Applied (Sc_rollup_publish_result _ as op) -> + Format.fprintf + ppf + "This operation publishing a commitment on a smart contract rollup \ + was successfully applied" ; + pp_sc_rollup_publish_result op + | Backtracked ((Sc_rollup_publish_result _ as op), _errs) -> + Format.fprintf + ppf + "@[This operation publishing a commitment on a smart contract \ + rollup was BACKTRACKED, its expected effects (as follow) were NOT \ + applied.@]" ; + pp_sc_rollup_publish_result op + | Applied (Sc_rollup_refute_result _ as op) -> + Format.fprintf + ppf + "This operation playing a refutation game step on a smart contract \ + rollup was successfully applied" ; + pp_sc_rollup_refute_result op + | Backtracked ((Sc_rollup_refute_result _ as op), _errs) -> + Format.fprintf + ppf + "@[This operation playing a refutation game step on a smart \ + contract rollup was BACKTRACKED, its expected effects (as follow) \ + were NOT applied.@]" ; + pp_sc_rollup_refute_result op + | Applied (Sc_rollup_timeout_result _ as op) -> + Format.fprintf + ppf + "This operation to end a refutation game on a smart contract rollup \ + by timeout was successfully applied" ; + pp_sc_rollup_timeout_result op + | Backtracked ((Sc_rollup_timeout_result _ as op), _errs) -> + Format.fprintf + ppf + "@[This operation to end a refutation game on a smart contract \ + rollup by timeout was BACKTRACKED, its expected effects (as follow) \ + were NOT applied.@]" ; + pp_sc_rollup_timeout_result op + in Format.fprintf ppf @@ -1047,7 +1283,7 @@ let pp_manager_operation_contents_and_result ppf pp_internal_operation_result ppf (Internal_contents op) - pp_result + pp_internal_result res)) internal_operation_results) ; Format.fprintf ppf "@]" -- GitLab From 70322d522252f8ce3c0878a324a3c0dcbfc3e6c7 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 19 May 2022 15:15:00 +0200 Subject: [PATCH 4/5] Proto: introduce successful_internal_manager_operation_result. Does not compile (unused type and constructor for now). --- src/proto_alpha/lib_protocol/apply_results.ml | 17 +++++++++++++++++ src/proto_alpha/lib_protocol/apply_results.mli | 16 ++++++++++++++-- 2 files changed, 31 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 568246a77b03..80c1c0cd3d0e 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -259,6 +259,23 @@ type _ successful_manager_operation_result = } -> Kind.sc_rollup_atomic_batch 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; diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index 5f6061a21a61..12a2a60d1f4a 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -189,8 +189,7 @@ and successful_origination_result = { paid_storage_size_diff : Z.t; } -(** Result of applying a {!manager_operation_content}, either internal - or external. *) +(** Result of applying an external {!manager_operation_content}. *) and _ successful_manager_operation_result = | Reveal_result : { consumed_gas : Gas.Arith.fp; @@ -326,6 +325,19 @@ and _ successful_manager_operation_result = } -> Kind.sc_rollup_atomic_batch 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 -- GitLab From 8f78150ebb9500c48902892b30a08802a929baf3 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Wed, 18 May 2022 16:39:46 +0200 Subject: [PATCH 5/5] Proto/Client/Rollup: use successful_internal_manager_operation_result where it should be used. --- src/proto_alpha/lib_client/injection.ml | 100 ++------ .../lib_client/operation_result.ml | 215 +----------------- src/proto_alpha/lib_protocol/apply.ml | 98 ++------ src/proto_alpha/lib_protocol/apply_results.ml | 35 +-- .../lib_protocol/apply_results.mli | 2 +- src/proto_alpha/lib_tx_rollup/daemon.ml | 2 +- 6 files changed, 56 insertions(+), 396 deletions(-) diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index 9f39f520f315..2cda4d3094d8 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -2,7 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2018 Nomadic Labs, *) +(* Copyright (c) 2018-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"),*) @@ -352,39 +352,13 @@ let estimated_gas_single (type kind) (result : kind internal_manager_operation_result) = match result with | Applied - (Transaction_result (Transaction_to_contract_result {consumed_gas; _})) + (ITransaction_result (Transaction_to_contract_result {consumed_gas; _})) | Applied - (Transaction_result (Transaction_to_tx_rollup_result {consumed_gas; _})) - -> - Ok consumed_gas - | Applied (Origination_result {consumed_gas; _}) -> Ok consumed_gas - | Applied (Reveal_result {consumed_gas}) -> Ok consumed_gas - | Applied (Delegation_result {consumed_gas}) -> Ok consumed_gas - | Applied (Register_global_constant_result {consumed_gas; _}) -> - Ok consumed_gas - | Applied (Set_deposits_limit_result {consumed_gas}) -> Ok consumed_gas - | Applied (Tx_rollup_origination_result {consumed_gas; _}) -> - Ok consumed_gas - | Applied (Tx_rollup_submit_batch_result {consumed_gas; _}) -> - Ok consumed_gas - | Applied (Tx_rollup_commit_result {consumed_gas; _}) -> Ok consumed_gas - | Applied (Tx_rollup_return_bond_result {consumed_gas; _}) -> - Ok consumed_gas - | Applied (Tx_rollup_finalize_commitment_result {consumed_gas; _}) -> - Ok consumed_gas - | Applied (Tx_rollup_remove_commitment_result {consumed_gas; _}) -> - Ok consumed_gas - | Applied (Tx_rollup_rejection_result {consumed_gas; _}) -> Ok consumed_gas - | Applied (Tx_rollup_dispatch_tickets_result {consumed_gas; _}) -> - Ok consumed_gas - | Applied (Transfer_ticket_result {consumed_gas; _}) -> Ok consumed_gas - | Applied (Sc_rollup_originate_result {consumed_gas; _}) -> Ok consumed_gas - | Applied (Sc_rollup_add_messages_result {consumed_gas; _}) -> + (ITransaction_result + (Transaction_to_tx_rollup_result {consumed_gas; _})) -> Ok consumed_gas - | Applied (Sc_rollup_cement_result {consumed_gas; _}) -> Ok consumed_gas - | Applied (Sc_rollup_publish_result {consumed_gas; _}) -> Ok consumed_gas - | Applied (Sc_rollup_refute_result {consumed_gas; _}) -> Ok consumed_gas - | Applied (Sc_rollup_timeout_result {consumed_gas; _}) -> Ok consumed_gas + | Applied (IOrigination_result {consumed_gas; _}) -> Ok consumed_gas + | Applied (IDelegation_result {consumed_gas}) -> Ok consumed_gas | Skipped _ -> Ok Gas.Arith.zero (* there must be another error for this to happen *) | Backtracked (_, None) -> @@ -462,49 +436,21 @@ let estimated_storage_single (type kind) ~tx_rollup_origination_size (result : kind internal_manager_operation_result) = match result with | Applied - (Transaction_result + (ITransaction_result (Transaction_to_contract_result {paid_storage_size_diff; allocated_destination_contract; _})) -> if allocated_destination_contract then Ok (Z.add paid_storage_size_diff origination_size) else Ok paid_storage_size_diff - | Applied (Transaction_result (Transaction_to_tx_rollup_result _)) -> + | Applied (ITransaction_result (Transaction_to_tx_rollup_result _)) -> (* TODO: https://gitlab.com/tezos/tezos/-/issues/2339 Storage fees for transaction rollup. We need to charge for newly allocated storage (as we do for Michelson’s big map). *) Ok Z.zero - | Applied (Origination_result {paid_storage_size_diff; _}) -> + | Applied (IOrigination_result {paid_storage_size_diff; _}) -> Ok (Z.add paid_storage_size_diff origination_size) - | Applied (Reveal_result _) -> Ok Z.zero - | Applied (Delegation_result _) -> Ok Z.zero - | Applied (Register_global_constant_result {size_of_constant; _}) -> - Ok size_of_constant - | Applied (Set_deposits_limit_result _) -> Ok Z.zero - | Applied (Tx_rollup_origination_result _) -> Ok tx_rollup_origination_size - | Applied (Tx_rollup_submit_batch_result {paid_storage_size_diff; _}) -> - Ok paid_storage_size_diff - | Applied (Tx_rollup_commit_result _) -> Ok Z.zero - | Applied (Tx_rollup_return_bond_result _) -> Ok Z.zero - | Applied (Tx_rollup_finalize_commitment_result _) -> Ok Z.zero - | Applied (Tx_rollup_remove_commitment_result _) -> Ok Z.zero - | Applied (Tx_rollup_rejection_result _) -> Ok Z.zero - | Applied (Tx_rollup_dispatch_tickets_result {paid_storage_size_diff; _}) -> - Ok paid_storage_size_diff - | Applied (Transfer_ticket_result {paid_storage_size_diff; _}) -> - Ok paid_storage_size_diff - | Applied (Sc_rollup_originate_result {size; _}) -> Ok size - | Applied (Sc_rollup_add_messages_result _) -> Ok Z.zero - (* The following Sc_rollup operations have zero storage cost because we - consider them to be paid in the stake deposit. - - TODO: https://gitlab.com/tezos/tezos/-/issues/2686 - Document why this is safe. - *) - | Applied (Sc_rollup_cement_result _) -> Ok Z.zero - | Applied (Sc_rollup_publish_result _) -> Ok Z.zero - | Applied (Sc_rollup_refute_result _) -> Ok Z.zero - | Applied (Sc_rollup_timeout_result _) -> Ok Z.zero + | Applied (IDelegation_result _) -> Ok Z.zero | Skipped _ -> Ok Z.zero (* there must be another error for this to happen *) | Backtracked (_, None) -> @@ -582,31 +528,13 @@ let originated_contracts_single (type kind) (result : kind internal_manager_operation_result) = match result with | Applied - (Transaction_result + (ITransaction_result (Transaction_to_contract_result {originated_contracts; _})) -> Ok originated_contracts - | Applied (Transaction_result (Transaction_to_tx_rollup_result _)) -> Ok [] - | Applied (Origination_result {originated_contracts; _}) -> + | Applied (ITransaction_result (Transaction_to_tx_rollup_result _)) -> Ok [] + | Applied (IOrigination_result {originated_contracts; _}) -> Ok originated_contracts - | Applied (Register_global_constant_result _) -> Ok [] - | Applied (Reveal_result _) -> Ok [] - | Applied (Delegation_result _) -> Ok [] - | Applied (Set_deposits_limit_result _) -> Ok [] - | Applied (Tx_rollup_origination_result _) -> Ok [] - | Applied (Tx_rollup_submit_batch_result _) -> Ok [] - | Applied (Tx_rollup_commit_result _) -> Ok [] - | Applied (Tx_rollup_return_bond_result _) -> Ok [] - | Applied (Tx_rollup_finalize_commitment_result _) -> Ok [] - | Applied (Tx_rollup_remove_commitment_result _) -> Ok [] - | Applied (Tx_rollup_rejection_result _) -> Ok [] - | Applied (Tx_rollup_dispatch_tickets_result _) -> Ok [] - | Applied (Transfer_ticket_result _) -> Ok [] - | Applied (Sc_rollup_originate_result _) -> Ok [] - | Applied (Sc_rollup_add_messages_result _) -> Ok [] - | Applied (Sc_rollup_cement_result _) -> Ok [] - | Applied (Sc_rollup_publish_result _) -> Ok [] - | Applied (Sc_rollup_refute_result _) -> Ok [] - | Applied (Sc_rollup_timeout_result _) -> Ok [] + | Applied (IDelegation_result _) -> Ok [] | Skipped _ -> Ok [] (* there must be another error for this to happen *) | Backtracked (_, None) -> Ok [] (* there must be another error for this to happen *) diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index 4e12946dfaef..7f980b5edc51 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -1018,235 +1018,32 @@ let pp_manager_operation_contents_and_result ppf match result with | Skipped _ -> Format.fprintf ppf "This operation was skipped" | Failed (_, _errs) -> Format.fprintf ppf "This operation FAILED." - | Applied (Reveal_result {consumed_gas}) -> - Format.fprintf ppf "This revelation was successfully applied" ; - Format.fprintf ppf "@,Consumed gas: %a" Gas.Arith.pp consumed_gas - | Backtracked (Reveal_result _, _) -> - Format.fprintf - ppf - "@[This revelation was BACKTRACKED, its expected effects were \ - NOT applied.@]" - | Applied (Delegation_result {consumed_gas}) -> + | Applied (IDelegation_result {consumed_gas}) -> Format.fprintf ppf "This delegation was successfully applied" ; Format.fprintf ppf "@,Consumed gas: %a" Gas.Arith.pp consumed_gas - | Backtracked (Delegation_result _, _) -> + | Backtracked (IDelegation_result _, _) -> Format.fprintf ppf "@[This delegation was BACKTRACKED, its expected effects were \ NOT applied.@]" - | Applied (Set_deposits_limit_result {consumed_gas}) -> - Format.fprintf ppf "The deposits limit was successfully set" ; - Format.fprintf ppf "@,Consumed gas: %a" Gas.Arith.pp consumed_gas - | Backtracked (Set_deposits_limit_result _, _) -> - Format.fprintf - ppf - "@[This deposits limit modification was BACKTRACKED, its \ - expected effects were NOT applied.@]" - | Applied (Transaction_result tx) -> + | Applied (ITransaction_result tx) -> Format.fprintf ppf "This transaction was successfully applied" ; pp_transaction_result tx - | Backtracked (Transaction_result tx, _errs) -> + | Backtracked (ITransaction_result tx, _errs) -> Format.fprintf ppf "@[This transaction was BACKTRACKED, its expected effects (as \ follow) were NOT applied.@]" ; pp_transaction_result tx - | Applied (Origination_result op_res) -> + | Applied (IOrigination_result op_res) -> Format.fprintf ppf "This origination was successfully applied" ; pp_origination_result op_res - | Backtracked (Origination_result op_res, _errs) -> + | Backtracked (IOrigination_result op_res, _errs) -> Format.fprintf ppf "@[This origination was BACKTRACKED, its expected effects (as \ follow) were NOT applied.@]" ; pp_origination_result op_res - | Applied (Register_global_constant_result _ as op) -> - Format.fprintf - ppf - "This global constant registration was successfully applied" ; - pp_register_global_constant_result op - | Backtracked ((Register_global_constant_result _ as op), _errs) -> - Format.fprintf - ppf - "@[This registration of a global constant was BACKTRACKED, its \ - expected effects (as follow) were NOT applied.@]" ; - pp_register_global_constant_result op - | Applied (Tx_rollup_origination_result _ as op) -> - Format.fprintf - ppf - "This tx rollup origination operation was successfully applied" ; - pp_tx_rollup_result op - | Backtracked ((Tx_rollup_origination_result _ as op), _err) -> - Format.fprintf - ppf - "@[This rollup operation was BACKTRACKED, its expected effects \ - (as follow) were NOT applied.@]" ; - pp_tx_rollup_result op - | Applied (Tx_rollup_submit_batch_result _ as op) -> - Format.fprintf - ppf - "This tx rollup submit operation was successfully applied" ; - pp_tx_rollup_submit_batch_result op - | Backtracked ((Tx_rollup_submit_batch_result _ as op), _err) -> - Format.fprintf - ppf - "@[This rollup submit operation was BACKTRACKED, its expected \ - effects (as follow) were NOT applied.@]" ; - pp_tx_rollup_submit_batch_result op - | Applied (Tx_rollup_commit_result _ as op) -> - Format.fprintf - ppf - "This tx rollup commit operation was successfully applied" ; - pp_tx_rollup_commit_result op - | Backtracked ((Tx_rollup_commit_result _ as op), _err) -> - Format.fprintf - ppf - "@[This tx rollup commit operation was BACKTRACKED, its \ - expected effects (as follow) were NOT applied.@]" ; - pp_tx_rollup_commit_result op - | Applied (Tx_rollup_return_bond_result _ as op) -> - Format.fprintf - ppf - "This tx rollup return commitment bond operation was successfully \ - applied" ; - pp_tx_rollup_return_bond_result op - | Backtracked ((Tx_rollup_return_bond_result _ as op), _err) -> - Format.fprintf - ppf - "@[This tx rollup return commitment bond operation was \ - BACKTRACKED, its expected effects (as follow) were NOT applied.@]" ; - pp_tx_rollup_return_bond_result op - | Applied (Tx_rollup_finalize_commitment_result _ as op) -> - Format.fprintf - ppf - "This tx rollup finalize operation was successfully applied" ; - pp_tx_rollup_finalize_commitment_result op - | Backtracked ((Tx_rollup_finalize_commitment_result _ as op), _err) -> - Format.fprintf - ppf - "@[This tx rollup finalize operation was BACKTRACKED, its \ - expected effects (as follow) were NOT applied.@]" ; - pp_tx_rollup_finalize_commitment_result op - | Applied (Tx_rollup_remove_commitment_result _ as op) -> - Format.fprintf - ppf - "This tx rollup remove operation was successfully applied" ; - pp_tx_rollup_remove_commitment_result op - | Backtracked ((Tx_rollup_remove_commitment_result _ as op), _err) -> - Format.fprintf - ppf - "@[This tx rollup remove operation was BACKTRACKED, its \ - expected effects (as follow) were NOT applied.@]" ; - pp_tx_rollup_remove_commitment_result op - | Applied (Tx_rollup_rejection_result _ as op) -> - Format.fprintf - ppf - "This tx rollup rejection operation was successfully applied" ; - pp_tx_rollup_rejection_result op - | Backtracked ((Tx_rollup_rejection_result _ as op), _err) -> - Format.fprintf - ppf - "@[This tx rollup rejection operation was BACKTRACKED, its \ - expected effects (as follow) were NOT applied.@]" ; - pp_tx_rollup_rejection_result op - | Applied (Tx_rollup_dispatch_tickets_result _ as op) -> - Format.fprintf - ppf - "This tx rollup reveal_withdrawals operation was successfully applied" ; - pp_tx_rollup_dispatch_tickets_result op - | Backtracked ((Tx_rollup_dispatch_tickets_result _ as op), _err) -> - Format.fprintf - ppf - "@[This tx rollup reveal_withdrawals rollup operation was \ - BACKTRACKED, its expected effects (as follow) were NOT applied.@]" ; - pp_tx_rollup_dispatch_tickets_result op - | Applied (Transfer_ticket_result _ as op) -> - Format.fprintf - ppf - "This transfer ticket operation was successfully applied" ; - pp_transfer_ticket_result op - | Backtracked ((Transfer_ticket_result _ as op), _err) -> - Format.fprintf - ppf - "@[This transfer ticket operation was BACKTRACKED, its expected \ - effects (as follow) were NOT applied.@]" ; - pp_transfer_ticket_result op - | Applied (Sc_rollup_originate_result _ as op) -> - Format.fprintf - ppf - "This smart contract rollup origination was successfully applied" ; - pp_sc_rollup_originate_result op - | Backtracked ((Sc_rollup_originate_result _ as op), _errs) -> - Format.fprintf - ppf - "@[This rollup origination was BACKTRACKED, its expected \ - effects (as follow) were NOT applied.@]" ; - pp_sc_rollup_originate_result op - | Applied (Sc_rollup_add_messages_result _ as op) -> - Format.fprintf - ppf - "This operation sending a message to a smart contract rollup was \ - successfully applied" ; - pp_sc_rollup_add_messages_result op - | Backtracked ((Sc_rollup_add_messages_result _ as op), _errs) -> - Format.fprintf - ppf - "@[This operation sending a message to a smart contract rollup \ - was BACKTRACKED, its expected effects (as follow) were NOT \ - applied.@]" ; - pp_sc_rollup_add_messages_result op - | Applied (Sc_rollup_cement_result _ as op) -> - Format.fprintf - ppf - "This operation cementing a commitment on a smart contract rollup \ - was successfully applied" ; - pp_sc_rollup_cement_result op - | Backtracked ((Sc_rollup_cement_result _ as op), _errs) -> - Format.fprintf - ppf - "@[This operation cementing a commitment on a smart contract \ - rollup was BACKTRACKED, its expected effects (as follow) were NOT \ - applied.@]" ; - pp_sc_rollup_cement_result op - | Applied (Sc_rollup_publish_result _ as op) -> - Format.fprintf - ppf - "This operation publishing a commitment on a smart contract rollup \ - was successfully applied" ; - pp_sc_rollup_publish_result op - | Backtracked ((Sc_rollup_publish_result _ as op), _errs) -> - Format.fprintf - ppf - "@[This operation publishing a commitment on a smart contract \ - rollup was BACKTRACKED, its expected effects (as follow) were NOT \ - applied.@]" ; - pp_sc_rollup_publish_result op - | Applied (Sc_rollup_refute_result _ as op) -> - Format.fprintf - ppf - "This operation playing a refutation game step on a smart contract \ - rollup was successfully applied" ; - pp_sc_rollup_refute_result op - | Backtracked ((Sc_rollup_refute_result _ as op), _errs) -> - Format.fprintf - ppf - "@[This operation playing a refutation game step on a smart \ - contract rollup was BACKTRACKED, its expected effects (as follow) \ - were NOT applied.@]" ; - pp_sc_rollup_refute_result op - | Applied (Sc_rollup_timeout_result _ as op) -> - Format.fprintf - ppf - "This operation to end a refutation game on a smart contract rollup \ - by timeout was successfully applied" ; - pp_sc_rollup_timeout_result op - | Backtracked ((Sc_rollup_timeout_result _ as op), _errs) -> - Format.fprintf - ppf - "@[This operation to end a refutation game on a smart contract \ - rollup by timeout was BACKTRACKED, its expected effects (as follow) \ - were NOT applied.@]" ; - pp_sc_rollup_timeout_result op in Format.fprintf diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 39a762c5db3f..2c0d94f1b2fe 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1016,7 +1016,7 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~payer >>=? fun (ctxt, state, paid_storage_size_diff) -> Tx_rollup_state.update ctxt dst_rollup state >>=? fun ctxt -> let result = - Transaction_result + ITransaction_result (Transaction_to_tx_rollup_result { balance_updates; @@ -1120,7 +1120,7 @@ let apply_internal_manager_operation_content : chain_id:Chain_id.t -> kind Script_typed_ir.manager_operation -> (context - * kind successful_manager_operation_result + * kind successful_internal_manager_operation_result * Script_typed_ir.packed_internal_operation list) tzresult Lwt.t = @@ -1151,7 +1151,8 @@ let apply_internal_manager_operation_content : ~before_operation >|=? fun (ctxt, res, ops) -> ( ctxt, - (Transaction_result res : kind successful_manager_operation_result), + (ITransaction_result res + : kind successful_internal_manager_operation_result), ops ) | Transaction_to_contract { @@ -1175,7 +1176,7 @@ let apply_internal_manager_operation_content : ~mode ~internal:true ~parameter:(Typed_arg (location, parameters_ty, typed_parameters)) - >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops) + >|=? fun (ctxt, res, ops) -> (ctxt, ITransaction_result res, ops) | Transaction_to_tx_rollup {destination; unparsed_parameters = _; parameters_ty; parameters} -> apply_transaction_to_tx_rollup @@ -1208,11 +1209,11 @@ let apply_internal_manager_operation_content : ~credit ~before_operation >|=? fun (ctxt, origination_result, ops) -> - (ctxt, Origination_result origination_result, ops) + (ctxt, IOrigination_result origination_result, ops) | Delegation delegate -> apply_delegation ~ctxt ~source ~delegate ~before_operation >|=? fun (ctxt, consumed_gas, ops) -> - (ctxt, Delegation_result {consumed_gas}, ops) + (ctxt, IDelegation_result {consumed_gas}, ops) let apply_external_manager_operation_content : type kind. @@ -2209,99 +2210,31 @@ let burn_manager_storage_fees : let burn_internal_storage_fees : type kind. context -> - kind successful_manager_operation_result -> + kind successful_internal_manager_operation_result -> storage_limit:Z.t -> payer:public_key_hash -> - (context * Z.t * kind successful_manager_operation_result) tzresult Lwt.t = + (context * Z.t * kind successful_internal_manager_operation_result) tzresult + Lwt.t = fun ctxt smopr ~storage_limit ~payer -> let payer = `Contract (Contract.Implicit payer) in match smopr with - | Transaction_result transaction_result -> + | ITransaction_result transaction_result -> burn_transaction_storage_fees ctxt transaction_result ~storage_limit ~payer >|=? fun (ctxt, storage_limit, transaction_result) -> - (ctxt, storage_limit, Transaction_result transaction_result) - | Origination_result origination_result -> + (ctxt, storage_limit, ITransaction_result transaction_result) + | IOrigination_result origination_result -> burn_origination_storage_fees ctxt origination_result ~storage_limit ~payer >|=? fun (ctxt, storage_limit, origination_result) -> - (ctxt, storage_limit, Origination_result origination_result) - | Reveal_result _ | Delegation_result _ -> return (ctxt, storage_limit, smopr) - | Register_global_constant_result ({balance_updates; _} as payload) -> - let consumed = payload.size_of_constant in - Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed - >>=? fun (ctxt, storage_limit, storage_bus) -> - let balance_updates = storage_bus @ balance_updates in - return - ( ctxt, - storage_limit, - Register_global_constant_result {payload with balance_updates} ) - | Set_deposits_limit_result _ -> return (ctxt, storage_limit, smopr) - | Tx_rollup_origination_result ({balance_updates; _} as payload) -> - Fees.burn_tx_rollup_origination_fees ctxt ~storage_limit ~payer - >>=? fun (ctxt, storage_limit, origination_bus) -> - let balance_updates = origination_bus @ balance_updates in - return - ( ctxt, - storage_limit, - Tx_rollup_origination_result {payload with balance_updates} ) - | Tx_rollup_return_bond_result _ | Tx_rollup_remove_commitment_result _ - | Tx_rollup_rejection_result _ | Tx_rollup_finalize_commitment_result _ - | Tx_rollup_commit_result _ -> - return (ctxt, storage_limit, smopr) - | Transfer_ticket_result - ({balance_updates; paid_storage_size_diff; _} as payload) -> - Fees.burn_storage_fees ctxt ~storage_limit ~payer paid_storage_size_diff - >>=? fun (ctxt, storage_limit, storage_bus) -> - let balance_updates = balance_updates @ storage_bus in - return - ( ctxt, - storage_limit, - Transfer_ticket_result {payload with balance_updates} ) - | Tx_rollup_submit_batch_result - ({balance_updates; paid_storage_size_diff; _} as payload) -> - Fees.burn_storage_fees ctxt ~storage_limit ~payer paid_storage_size_diff - >>=? fun (ctxt, storage_limit, storage_bus) -> - let balance_updates = storage_bus @ balance_updates in - return - ( ctxt, - storage_limit, - Tx_rollup_submit_batch_result {payload with balance_updates} ) - | Tx_rollup_dispatch_tickets_result - ({balance_updates; paid_storage_size_diff; _} as payload) -> - Fees.burn_storage_fees ctxt ~storage_limit ~payer paid_storage_size_diff - >>=? fun (ctxt, storage_limit, storage_bus) -> - let balance_updates = storage_bus @ balance_updates in - return - ( ctxt, - storage_limit, - Tx_rollup_dispatch_tickets_result {payload with balance_updates} ) - | Dal_publish_slot_header_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_originate_result ({size; _} as payload) -> - Fees.burn_sc_rollup_origination_fees ctxt ~storage_limit ~payer size - >>=? fun (ctxt, storage_limit, balance_updates) -> - let result = Sc_rollup_originate_result {payload with balance_updates} in - return (ctxt, storage_limit, result) - | Sc_rollup_add_messages_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_cement_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_publish_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_refute_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_timeout_result _ -> return (ctxt, storage_limit, smopr) - | Sc_rollup_atomic_batch_result - ({balance_updates; paid_storage_size_diff; _} as payload) -> - Fees.burn_storage_fees ctxt ~storage_limit ~payer paid_storage_size_diff - >>=? fun (ctxt, storage_limit, storage_bus) -> - let balance_updates = storage_bus @ balance_updates in - return - ( ctxt, - storage_limit, - Sc_rollup_atomic_batch_result {payload with balance_updates} ) + (ctxt, storage_limit, IOrigination_result origination_result) + | IDelegation_result _ -> return (ctxt, storage_limit, smopr) let apply_manager_contents (type kind) ctxt mode chain_id ~gas_consumed_in_precheck (op : kind Kind.manager contents) : @@ -2636,7 +2569,6 @@ let mark_backtracked results = kind internal_manager_operation_result -> kind internal_manager_operation_result = function | (Failed _ | Skipped _ | Backtracked _) as result -> result - | Applied (Reveal_result _) as result -> result | Applied result -> Backtracked (result, None) in mark_contents_list results diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 80c1c0cd3d0e..b83e0e45deaa 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -333,7 +333,7 @@ type 'kind manager_operation_result = type 'kind internal_manager_operation_result = ( 'kind, 'kind Kind.manager, - 'kind successful_manager_operation_result ) + 'kind successful_internal_manager_operation_result ) operation_result type packed_internal_manager_operation_result = @@ -1298,10 +1298,10 @@ module Internal_manager_result = struct encoding : 'a Data_encoding.t; kind : 'kind Kind.manager; select : - packed_successful_manager_operation_result -> - 'kind successful_manager_operation_result option; - proj : 'kind successful_manager_operation_result -> 'a; - inj : 'a -> 'kind successful_manager_operation_result; + 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 @@ -1321,7 +1321,7 @@ module Internal_manager_result = struct match o with | Skipped _ | Failed _ | Backtracked _ -> None | Applied o -> ( - match select (Successful_manager_result o) with + match select (Successful_internal_manager_result o) with | None -> None | Some o -> Some ((), proj o))) (fun ((), x) -> Applied (inj x)); @@ -1351,7 +1351,7 @@ module Internal_manager_result = struct match o with | Skipped _ | Failed _ | Applied _ -> None | Backtracked (o, errs) -> ( - match select (Successful_manager_result o) with + match select (Successful_internal_manager_result o) with | None -> None | Some o -> Some (((), errs), proj o))) (fun (((), errs), x) -> Backtracked (inj x, errs)); @@ -1364,11 +1364,12 @@ module Internal_manager_result = struct ~op_case:Internal_result.transaction_case ~encoding:Manager_result.transaction_contract_variant_cases ~select:(function - | Successful_manager_result (Transaction_result _ as op) -> Some op + | Successful_internal_manager_result (ITransaction_result _ as op) -> + Some op | _ -> None) ~kind:Kind.Transaction_manager_kind - ~proj:(function Transaction_result x -> x) - ~inj:(fun x -> Transaction_result x) + ~proj:(function ITransaction_result x -> x) + ~inj:(fun x -> ITransaction_result x) let[@coq_axiom_with_reason "gadt"] origination_case = make @@ -1383,10 +1384,11 @@ module Internal_manager_result = struct (dft "paid_storage_size_diff" z Z.zero) (opt "lazy_storage_diff" Lazy_storage.encoding)) ~select:(function - | Successful_manager_result (Origination_result _ as op) -> Some op + | Successful_internal_manager_result (IOrigination_result _ as op) -> + Some op | _ -> None) ~proj:(function - | Origination_result + | IOrigination_result { lazy_storage_diff; balance_updates; @@ -1417,7 +1419,7 @@ module Internal_manager_result = struct paid_storage_size_diff, lazy_storage_diff ) -> assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; - Origination_result + IOrigination_result { lazy_storage_diff; balance_updates; @@ -1436,15 +1438,16 @@ module Internal_manager_result = struct (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) ~select:(function - | Successful_manager_result (Delegation_result _ as op) -> Some op + | Successful_internal_manager_result (IDelegation_result _ as op) -> + Some op | _ -> None) ~kind:Kind.Delegation_manager_kind ~proj:(function[@coq_match_with_default] - | Delegation_result {consumed_gas} -> + | IDelegation_result {consumed_gas} -> (Gas.Arith.ceil consumed_gas, consumed_gas)) ~inj:(fun (consumed_gas, consumed_milligas) -> assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; - Delegation_result {consumed_gas = consumed_milligas}) + IDelegation_result {consumed_gas = consumed_milligas}) end let internal_manager_operation_result_encoding : diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index 12a2a60d1f4a..b73211b91b74 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -157,7 +157,7 @@ and 'kind manager_operation_result = and 'kind internal_manager_operation_result = ( 'kind, 'kind Kind.manager, - 'kind successful_manager_operation_result ) + 'kind successful_internal_manager_operation_result ) operation_result (** Result of applying a transaction, either internal or external. *) diff --git a/src/proto_alpha/lib_tx_rollup/daemon.ml b/src/proto_alpha/lib_tx_rollup/daemon.ml index 547744c32824..ab1daee67c2d 100644 --- a/src/proto_alpha/lib_tx_rollup/daemon.ml +++ b/src/proto_alpha/lib_tx_rollup/daemon.ml @@ -135,7 +135,7 @@ let extract_messages_from_block block_info rollup_id = | ( Transaction {amount = _; parameters; destination = Tx_rollup dst; entrypoint}, Applied - (Transaction_result + (ITransaction_result (Transaction_to_tx_rollup_result {ticket_hash; _})) ) when Tx_rollup.equal dst rollup_id && Entrypoint.(entrypoint = Tx_rollup.deposit_entrypoint) -> -- GitLab