diff --git a/docs/protocols/alpha.rst b/docs/protocols/alpha.rst index 401e40e25793149b4d6eb3d37bdb78adeda98ecd..889b6585514b5f8f7784922663c2cc107b3e4565 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 --------- diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index f24f4abeaa667a68d45adcc03b0e3913b28db4c3..dd6f3ff3353079e3de0ce70b6995418950c8a0b6 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 397740a8ad71dc2b9307a2a810ac4ed239477ff4..d0a1fd86f59f4395d11a27e73df3ba24fc10a214 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -27,6 +27,8 @@ 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 92363695d7b27c6db7db0c056b7414de717878cd..30404d93707b1685a5f942a95280298fee8d4c03 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -27,6 +27,8 @@ 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 a55ca529bff524d34253d8c4a3140917889dbf2c..d6ed7d353eddfc0160192e2d57a827fadf53f539 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 ec6d063abd5ded1253dce8101fcc1f67cc3287ef..e745abd0afd8fdf901a5a3bfb00d228d50a14584 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_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 40e5775db12f1ba57879084ae64347455ac25704..af56010c0b8e490fc07925f4842bfc3a1edb9f26 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_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 89c04a82a010502b6ff884cae5c237f4343fb266..b0651d5fe63d024333e228460a6ddc9f6146a6a4 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/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 544056b1783ae5ee29a564ccbe759d1f860f06d4..de874245fd88f9fed653ef5321b8dbd86b9abe19 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -182,6 +182,8 @@ "Michelson_v1_gas", "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.ml b/src/proto_alpha/lib_protocol/apply.ml index 4e310742fa33ce6049b748cfe081166867bb6a16..c64a2c6464c209db0506c5dbed503b8527615009 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 @@ -811,6 +811,8 @@ let () = (fun () -> Invalid_transfer_to_sc_rollup_from_implicit_account) 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 @@ -1929,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 f2b8258f2cdb84ed1a22c3bee315143be6e38236..f01e01ece70ad62ddc3ec455e6925059a4f4e886 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/apply_internal_results.ml b/src/proto_alpha/lib_protocol/apply_internal_results.ml new file mode 100644 index 0000000000000000000000000000000000000000..cd2e0d6b182d781436700a581bfe8751a0c15bd2 --- /dev/null +++ b/src/proto_alpha/lib_protocol/apply_internal_results.ml @@ -0,0 +1,618 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open 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 new file mode 100644 index 0000000000000000000000000000000000000000..470a5ce207eaabd3cc17f863bb6df76f0d0554e6 --- /dev/null +++ b/src/proto_alpha/lib_protocol/apply_internal_results.mli @@ -0,0 +1,135 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** 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_operation_result.ml b/src/proto_alpha/lib_protocol/apply_operation_result.ml new file mode 100644 index 0000000000000000000000000000000000000000..d82aec0e522a548de9758e16630b58e58b6442d9 --- /dev/null +++ b/src/proto_alpha/lib_protocol/apply_operation_result.ml @@ -0,0 +1,55 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Data_encoding + +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] + +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 new file mode 100644 index 0000000000000000000000000000000000000000..11704df359d9fcefebbf45e99ed1a82aef6dc0df --- /dev/null +++ b/src/proto_alpha/lib_protocol/apply_operation_result.mli @@ -0,0 +1,44 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** 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] + +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 830fdb3c8636532366005f3e6f7d122fdacf23eb..f69f34ec0868cd62b6eab68435a6a27d78202789 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -26,140 +26,14 @@ open Alpha_context open Data_encoding - -let error_encoding = - def - "error" - ~description: - "The full list of RPC errors would be too long to include.\n\ - It is available at RPC `/errors` (GET).\n\ - Errors specific to protocol Alpha have an id that starts with \ - `proto.alpha`." - @@ splitted - ~json: - (conv - (fun err -> - Data_encoding.Json.construct Error_monad.error_encoding err) - (fun json -> - Data_encoding.Json.destruct Error_monad.error_encoding json) - json) - ~binary:Error_monad.error_encoding - -let trace_encoding = make_trace_encoding error_encoding - -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_operation_result +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 : { @@ -290,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; @@ -337,47 +194,12 @@ 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, '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 : { @@ -1046,343 +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_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_results.alpha.internal_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.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:Manager_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_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 6d18773b3658d227364d4ccf9c06081791b9c184..77f6256352bd09da25be4be5f997640762ed57e4 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -33,40 +33,8 @@ *) 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 +open Apply_operation_result +open Apply_internal_results (** Result of applying a {!Operation.t}. Follows the same structure. *) type 'kind operation_metadata = {contents : 'kind contents_result_list} @@ -133,68 +101,19 @@ 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, '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 = @@ -338,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 diff --git a/src/proto_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index 782f6786eb2a3f7943557559da8859b86d0bd923..ecad17786a316e8544cee4ebe177697f34494629 100644 --- a/src/proto_alpha/lib_protocol/dune +++ b/src/proto_alpha/lib_protocol/dune @@ -198,6 +198,8 @@ Michelson_v1_gas Script_list Script_tc_context + Apply_operation_result + Apply_internal_results Apply_results Script_ir_translator Script_big_map @@ -421,6 +423,8 @@ 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_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 @@ -630,6 +634,8 @@ 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_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 @@ -848,6 +854,8 @@ 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_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 @@ -1070,6 +1078,8 @@ 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_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 diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 4b9b7a3886b6a375a74e06cd35f26290cab39ceb..314297165775ad4f3f3ebed688f0d81477d8a724 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 c93dfd5c1d457e1fcae0e143418fe76f080cf3dd..7c03e9c1d9ba13f55e73ad78ef1a9ecf5a7f91a7 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -125,6 +125,8 @@ 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 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 ab1daee67c2dc8de913617fbe7317e5ec7a3814b..3874d3085fd2b50cba888f257a0ffae1a3594d5d 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