From a397dcbb088978f7c2b1f1b6d916658a704fe92e Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 3 Mar 2022 14:39:37 +0100 Subject: [PATCH 1/5] Proto/Michelson: move internal operations to Script_typed_ir. Script_typed_ir.internal_operation will now be the type for operations generated by smart contracts. It is a restriction of the previous internal operation type (Alpha_context.internal_operation) with only transactions, originations and delegations. Does not compile. --- .../lib_benchmark/michelson_samplers.ml | 2 +- .../lib_client/operation_result.ml | 2 +- .../lib_client/operation_result.mli | 2 +- src/proto_alpha/lib_plugin/plugin.ml | 2 +- .../lib_protocol/alpha_context.mli | 11 --- src/proto_alpha/lib_protocol/apply_results.ml | 14 ++-- .../lib_protocol/apply_results.mli | 11 +-- .../lib_protocol/operation_repr.ml | 54 -------------- .../lib_protocol/operation_repr.mli | 11 --- .../lib_protocol/script_ir_translator.ml | 7 +- .../lib_protocol/script_typed_ir.ml | 30 ++++++++ .../lib_protocol/script_typed_ir.mli | 26 +++++++ .../michelson/test_ticket_accounting.ml | 1 + .../michelson/test_ticket_operations_diff.ml | 73 ++----------------- .../lib_protocol/ticket_accounting.mli | 2 +- .../lib_protocol/ticket_operations_diff.ml | 20 +---- .../lib_protocol/ticket_operations_diff.mli | 2 +- 17 files changed, 87 insertions(+), 183 deletions(-) diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index 3aab4bb50c0b..dbbb1f8d7f25 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -701,7 +701,7 @@ end) Script_typed_ir.{piop = transfer; lazy_storage_diff = None} and generate_transfer_tokens : - Alpha_context.packed_internal_operation sampler = + Script_typed_ir.packed_internal_operation sampler = fun _rng_state -> fail_sampling "generate_transfer_tokens: unimplemented" and generate_bls12_381_g1 : Script_bls.G1.t sampler = diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index b4c1633b404b..3782950c27c0 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -997,6 +997,6 @@ let pp_internal_operation_result ppf (Apply_results.Internal_contents op) = ppf (operation, ()) -let pp_internal_operation ppf (Internal_operation op) = +let pp_internal_operation ppf (Script_typed_ir.Internal_operation op) = let op = contents_of_internal_operation op in pp_internal_operation_result ppf (Internal_contents op) diff --git a/src/proto_alpha/lib_client/operation_result.mli b/src/proto_alpha/lib_client/operation_result.mli index 38c62136d893..404f36ef3b49 100644 --- a/src/proto_alpha/lib_client/operation_result.mli +++ b/src/proto_alpha/lib_client/operation_result.mli @@ -27,7 +27,7 @@ open Protocol open Alpha_context val pp_internal_operation : - Format.formatter -> packed_internal_operation -> unit + Format.formatter -> Script_typed_ir.packed_internal_operation -> unit val pp_internal_operation_result : Format.formatter -> Apply_results.packed_internal_contents -> unit diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 5a55b13350f2..c97734653748 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -1464,7 +1464,7 @@ module View_helpers = struct in match operations with | [ - Internal_operation + Script_typed_ir.Internal_operation {operation = Transaction {destination; parameters; _}; _}; ] when Destination.equal destination (Contract callback) -> diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index bc253dd24a0e..c29fc4877539 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2802,12 +2802,6 @@ and _ manager_operation = and counter = Z.t -type 'kind internal_operation = { - source : Contract.contract; - operation : 'kind manager_operation; - nonce : int; -} - type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation @@ -2824,9 +2818,6 @@ type packed_operation = { protocol_data : packed_protocol_data; } -type packed_internal_operation = - | Internal_operation : 'kind internal_operation -> packed_internal_operation - val manager_kind : 'kind manager_operation -> 'kind Kind.manager module Operation : sig @@ -2884,8 +2875,6 @@ module Operation : sig val check_signature : public_key -> Chain_id.t -> _ operation -> unit tzresult - val internal_operation_encoding : packed_internal_operation Data_encoding.t - val pack : 'kind operation -> packed_operation type ('a, 'b) eq = Eq : ('a, 'a) eq diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index a1f97bf313c2..fa162275d20a 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -68,28 +68,26 @@ type packed_internal_contents = | Internal_contents : 'kind internal_contents -> packed_internal_contents let manager_operation_of_internal_operation (type kind) - (operation : kind internal_manager_operation) : kind manager_operation = + (operation : kind internal_manager_operation) : + kind Alpha_context.manager_operation = match operation with | Transaction transaction -> Transaction transaction | Origination origination -> Origination origination | Delegation delegate -> Delegation delegate let contents_of_internal_operation (type kind) - ({source; operation; nonce} : kind internal_operation) : + ({source; operation; nonce} : kind Script_typed_ir.internal_operation) : kind internal_contents = let operation : kind internal_manager_operation = match operation with | Transaction transaction -> Transaction transaction | Origination origination -> Origination origination | Delegation delegate -> Delegation delegate - (* This function will be used on internal operations only. - TODO (MR comment !4291): the branch will be removed when internal - operations are strictly defined. *) - | _ -> assert false in {source; operation; nonce} -let contents_of_packed_internal_operation (Internal_operation op) = +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 = @@ -247,7 +245,7 @@ type packed_internal_manager_operation_result = -> packed_internal_manager_operation_result let pack_internal_manager_operation_result (type kind) - (internal_op : kind internal_operation) + (internal_op : kind Script_typed_ir.internal_operation) (manager_op : kind manager_operation_result) = let internal_op = contents_of_internal_operation internal_op in Internal_manager_operation_result (internal_op, manager_op) diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index cb1837fcbad8..4b5b1da09688 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -45,7 +45,7 @@ type 'kind internal_manager_operation = -> Kind.delegation internal_manager_operation val manager_operation_of_internal_operation : - 'kind internal_manager_operation -> 'kind manager_operation + 'kind internal_manager_operation -> 'kind Alpha_context.manager_operation type 'kind internal_contents = { source : Contract.contract; @@ -57,10 +57,11 @@ type packed_internal_contents = | Internal_contents : 'kind internal_contents -> packed_internal_contents val contents_of_packed_internal_operation : - packed_internal_operation -> packed_internal_contents + Script_typed_ir.packed_internal_operation -> packed_internal_contents val contents_of_packed_internal_operations : - packed_internal_operation list -> packed_internal_contents list + Script_typed_ir.packed_internal_operation list -> + packed_internal_contents list (** Result of applying a {!Operation.t}. Follows the same structure. *) type 'kind operation_metadata = {contents : 'kind contents_result_list} @@ -271,10 +272,10 @@ and packed_internal_manager_operation_result = -> packed_internal_manager_operation_result val contents_of_internal_operation : - 'kind internal_operation -> 'kind internal_contents + 'kind Script_typed_ir.internal_operation -> 'kind internal_contents val pack_internal_manager_operation_result : - 'kind internal_operation -> + 'kind Script_typed_ir.internal_operation -> 'kind manager_operation_result -> packed_internal_manager_operation_result diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 9120e4902698..d94c8170266b 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -378,12 +378,6 @@ let manager_kind : type kind. kind manager_operation -> kind Kind.manager = | Sc_rollup_add_messages _ -> Kind.Sc_rollup_add_messages_manager_kind | Sc_rollup_cement _ -> Kind.Sc_rollup_cement_manager_kind -type 'kind internal_operation = { - source : Contract_repr.contract; - operation : 'kind manager_operation; - nonce : int; -} - type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation @@ -403,9 +397,6 @@ type packed_operation = { let pack ({shell; protocol_data} : _ operation) : packed_operation = {shell; protocol_data = Operation_data protocol_data} -type packed_internal_operation = - | Internal_operation : 'kind internal_operation -> packed_internal_operation - let rec contents_list_to_list : type a. a contents_list -> _ = function | Single o -> [Contents o] | Cons (o, os) -> Contents o :: contents_list_to_list os @@ -883,38 +874,6 @@ module Encoding = struct inj = (fun (rollup, commitment) -> Sc_rollup_cement {rollup; commitment}); } - - let encoding = - let make (MCase {tag; name; encoding; select; proj; inj}) = - case - (Tag tag) - name - encoding - (fun o -> - match select o with None -> None | Some o -> Some (proj o)) - (fun x -> Manager (inj x)) - in - union - ~tag_size:`Uint8 - [ - make reveal_case; - make transaction_case; - make origination_case; - make delegation_case; - make register_global_constant_case; - make set_deposits_limit_case; - make tx_rollup_origination_case; - make tx_rollup_submit_batch_case; - make tx_rollup_commit_case; - make tx_rollup_return_bond_case; - make tx_rollup_finalize_commitment_case; - make tx_rollup_remove_commitment_case; - make tx_rollup_rejection_case; - make tx_rollup_withdraw_case; - make sc_rollup_originate_case; - make sc_rollup_add_messages_case; - make sc_rollup_cement_case; - ] end type 'b case = @@ -1337,17 +1296,6 @@ module Encoding = struct @@ merge_objs Operation.shell_header_encoding (obj1 (req "contents" contents_list_encoding)) - - let internal_operation_encoding = - def "operation.alpha.internal_operation" - @@ conv - (fun (Internal_operation {source; operation; nonce}) -> - ((source, nonce), Manager operation)) - (fun ((source, nonce), Manager operation) -> - Internal_operation {source; operation; nonce}) - (merge_objs - (obj2 (req "source" Contract_repr.encoding) (req "nonce" uint16)) - Manager_operations.encoding) end let encoding = Encoding.operation_encoding @@ -1360,8 +1308,6 @@ let protocol_data_encoding = Encoding.protocol_data_encoding let unsigned_operation_encoding = Encoding.unsigned_operation_encoding -let internal_operation_encoding = Encoding.internal_operation_encoding - let raw ({shell; protocol_data} : _ operation) = let proto = Data_encoding.Binary.to_bytes_exn diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index b6bb9243d77b..9331c1fe7dba 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -431,12 +431,6 @@ and _ manager_operation = its manager is checked and incremented. *) and counter = Z.t -type 'kind internal_operation = { - source : Contract_repr.contract; - operation : 'kind manager_operation; - nonce : int; -} - type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation @@ -459,9 +453,6 @@ type packed_operation = { val pack : 'kind operation -> packed_operation -type packed_internal_operation = - | Internal_operation : 'kind internal_operation -> packed_internal_operation - val manager_kind : 'kind manager_operation -> 'kind Kind.manager val encoding : packed_operation Data_encoding.t @@ -492,8 +483,6 @@ type error += Invalid_signature (* `Permanent *) val check_signature : Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult -val internal_operation_encoding : packed_internal_operation Data_encoding.t - type ('a, 'b) eq = Eq : ('a, 'a) eq val equal : 'a operation -> 'b operation -> ('a, 'b) eq option diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 2c731778992d..38df9c7a993c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -480,9 +480,14 @@ let unparse_key_hash ~loc ctxt mode k = Gas.consume ctxt Unparse_costs.key_hash_readable >|? fun ctxt -> (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) +(* 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 bytes = - Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding piop + Data_encoding.Binary.to_bytes_exn + Apply_results.internal_contents_encoding + iop in Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt -> (Bytes (loc, bytes), ctxt) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 4f15813dcbee..c164587ef43d 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -98,6 +98,36 @@ type ('a, 'b) pair = 'a * 'b type ('a, 'b) union = L of 'a | R of 'b +type 'kind manager_operation = + | Transaction : + Alpha_context.transaction + -> Kind.transaction manager_operation + | Origination : + Alpha_context.origination + -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation + +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation + +let manager_kind : type kind. kind manager_operation -> kind Kind.manager = + function + | Transaction _ -> Kind.Transaction_manager_kind + | Origination _ -> Kind.Origination_manager_kind + | Delegation _ -> Kind.Delegation_manager_kind + +type 'kind internal_operation = { + source : Contract.contract; + operation : 'kind manager_operation; + nonce : int; +} + +type packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation +[@@ocaml.unboxed] + type operation = { piop : packed_internal_operation; lazy_storage_diff : Lazy_storage.diffs option; diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index ee5d27f205a4..01c4b25fd7a0 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -78,6 +78,32 @@ type ('a, 'b) pair = 'a * 'b type ('a, 'b) union = L of 'a | R of 'b +type 'kind manager_operation = + | Transaction : + Alpha_context.transaction + -> Kind.transaction manager_operation + | Origination : + Alpha_context.origination + -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation + +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation + +val manager_kind : 'kind manager_operation -> 'kind Kind.manager + +type 'kind internal_operation = { + source : Contract.contract; + operation : 'kind manager_operation; + nonce : int; +} + +type packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation +[@@ocaml.unboxed] + type operation = { piop : packed_internal_operation; lazy_storage_diff : Lazy_storage.diffs option; diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index fc9c6aaa1b21..a6076037f8eb 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -34,6 +34,7 @@ open Protocol open Alpha_context +open Script_typed_ir let wrap m = m >|= Environment.wrap_tzresult diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index be01f2945f6e..e5745ccabeca 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -230,7 +230,7 @@ let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = Incremental.begin_construction ~policy:Block.(By_account baker) block in let operation = - Internal_operation + Script_typed_ir.Internal_operation { source = src; operation = @@ -246,57 +246,9 @@ let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = in return (orig_contract, operation, incr) -let register_global_constant_operation ~src = - Internal_operation - { - source = src; - operation = - Register_global_constant - {value = Script.lazy_expr @@ Expr.from_string "1"}; - nonce = 1; - } - -let reveal_operation ~src pk = - Internal_operation {source = src; operation = Reveal pk; nonce = 1} - let delegation_operation ~src = - Internal_operation {source = src; operation = Delegation None; nonce = 1} - -let set_deposits_limit_operation ~src = - Internal_operation - {source = src; operation = Set_deposits_limit None; nonce = 1} - -let sc_rollup_origination_operation ~src = - let rollup = Sc_rollup.Address.hash_string ["Dummy"] in - Internal_operation - { - source = src; - operation = Sc_rollup_add_messages {rollup; messages = []}; - nonce = 1; - } - -let sc_rollup_add_message ~src = - Internal_operation - { - source = src; - operation = - Sc_rollup_originate - { - kind = Sc_rollup.Kind.Example_arith; - boot_sector = Sc_rollup.PVM.boot_sector_of_string "Dummy"; - }; - nonce = 1; - } - -let sc_rollup_cement ~src = - let rollup = Sc_rollup.Address.hash_string ["Dummy"] in - let commitment = Sc_rollup.Commitment_hash.hash_string ["Dummy"] in - Internal_operation - {source = src; operation = Sc_rollup_cement {rollup; commitment}; nonce = 1} - -let tx_rollup_originate_operation ~src = - Internal_operation - {source = src; operation = Tx_rollup_origination; nonce = 1} + Script_typed_ir.Internal_operation + {source = src; operation = Delegation None; nonce = 1} let originate block ~src ~baker ~script ~storage ~forges_tickets = let* (orig_contract, _script, block) = @@ -308,7 +260,7 @@ let originate block ~src ~baker ~script ~storage ~forges_tickets = return (orig_contract, incr) let transfer_operation ~src ~destination ~parameters = - Internal_operation + Script_typed_ir.Internal_operation { source = src; operation = @@ -354,22 +306,7 @@ let ticket_big_map_script = let test_non_ticket_operations () = let* (_baker, src, block) = init () in let* incr = Incremental.begin_construction block in - let pub_key = - Signature.Public_key.of_b58check_exn - "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav" - in - let operations = - [ - register_global_constant_operation ~src; - reveal_operation ~src pub_key; - delegation_operation ~src; - set_deposits_limit_operation ~src; - tx_rollup_originate_operation ~src; - sc_rollup_add_message ~src; - sc_rollup_cement ~src; - sc_rollup_origination_operation ~src; - ] - in + let operations = [delegation_operation ~src] in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr operations in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.mli b/src/proto_alpha/lib_protocol/ticket_accounting.mli index fb91eae764f5..946595056479 100644 --- a/src/proto_alpha/lib_protocol/ticket_accounting.mli +++ b/src/proto_alpha/lib_protocol/ticket_accounting.mli @@ -59,5 +59,5 @@ val update_ticket_balances : Alpha_context.context -> self:Alpha_context.Contract.t -> ticket_diffs:Z.t Ticket_token_map.t -> - Alpha_context.packed_internal_operation list -> + Script_typed_ir.packed_internal_operation list -> (Z.t * Alpha_context.t) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index 2654b6c83e2f..061acd015468 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -243,9 +243,8 @@ let tickets_of_origination ctxt ~preorigination script = originations and transactions. We will likely also need to support rollups. *) let tickets_of_operation ctxt - (Internal_operation {source = _; operation; nonce = _}) = + (Script_typed_ir.Internal_operation {source = _; operation; nonce = _}) = match operation with - | Reveal _ -> return (None, ctxt) | Transaction { amount = _; @@ -263,23 +262,6 @@ let tickets_of_operation ctxt | Origination {delegate = _; script; credit = _; preorigination} -> tickets_of_origination ctxt ~preorigination script | Delegation _ -> return (None, ctxt) - | Register_global_constant _ -> return (None, ctxt) - | Set_deposits_limit _ -> return (None, ctxt) - | Tx_rollup_origination -> return (None, ctxt) - | Tx_rollup_submit_batch _ -> return (None, ctxt) - | Tx_rollup_commit _ -> return (None, ctxt) - | Tx_rollup_return_bond _ -> return (None, ctxt) - | Tx_rollup_finalize_commitment _ -> return (None, ctxt) - | Tx_rollup_remove_commitment _ -> return (None, ctxt) - | Tx_rollup_rejection _ -> return (None, ctxt) - (* TODO: #2488 - The ticket accounting for the recipient of rollup transactions - is currently done in the apply function, but should rather be - done in this module. *) - | Tx_rollup_withdraw _ -> return (None, ctxt) - | Sc_rollup_originate _ -> return (None, ctxt) - | Sc_rollup_add_messages _ -> return (None, ctxt) - | Sc_rollup_cement _ -> return (None, ctxt) let add_transfer_to_token_map ctxt token_map {destination; tickets} = List.fold_left_es diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.mli b/src/proto_alpha/lib_protocol/ticket_operations_diff.mli index 1b2e7731f7a9..0c984a7c34b2 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.mli +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.mli @@ -48,5 +48,5 @@ type ticket_token_diff = private { tickets. *) val ticket_diffs_of_operations : Alpha_context.context -> - Alpha_context.packed_internal_operation list -> + Script_typed_ir.packed_internal_operation list -> (ticket_token_diff list * Alpha_context.context) tzresult Lwt.t -- GitLab From 87d4100d67179d9bb8bebe1d31e6403edc701e71 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 3 Mar 2022 15:24:49 +0100 Subject: [PATCH 2/5] Proto/Michelson: applying an operation returns an internal operation. The ones from Script_typed_ir.packed_internal_operation. It's pretty much handled by Apply.apply_manager_operation_content that now accepts an internal *or* external operation as input (with the new any_manager_operation type), and returns internal operations. --- src/proto_alpha/lib_protocol/apply.ml | 142 ++++++++++++++++++-------- 1 file changed, 100 insertions(+), 42 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 5fd9b292b6e2..9baaec7c433e 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1165,6 +1165,10 @@ let apply_origination ~consume_deserialization_gas ~ctxt ~script ~internal in (ctxt, result, []) +type 'kind any_manager_operation = + | Internal of 'kind Script_typed_ir.manager_operation + | External of 'kind Alpha_context.manager_operation + (** Retrieving the source code of a contract from its address is costly @@ -1186,10 +1190,10 @@ let apply_manager_operation_content : chain_id:Chain_id.t -> internal:bool -> gas_consumed_in_precheck:Gas.cost option -> - kind manager_operation -> + kind any_manager_operation -> (context * kind successful_manager_operation_result - * packed_internal_operation list) + * Script_typed_ir.packed_internal_operation list) tzresult Lwt.t = fun ctxt @@ -1215,7 +1219,7 @@ let apply_manager_operation_content : (* [note]: deserialization gas has already been accounted for in the gas consumed by the precheck and the lazy_exprs have been forced. *) match operation with - | Reveal _ -> + | External (Reveal _) -> return (* No-op: action already performed by `precheck_manager_contents`. *) ( ctxt, @@ -1223,8 +1227,9 @@ let apply_manager_operation_content : {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt} : kind successful_manager_operation_result), [] ) - | Transaction - {amount; parameters; destination = Contract contract; entrypoint} -> + | External + (Transaction + {amount; parameters; destination = Contract contract; entrypoint}) -> apply_transaction ~consume_deserialization_gas ~ctxt @@ -1238,7 +1243,25 @@ let apply_manager_operation_content : ~chain_id ~mode ~internal - | Transaction {amount; parameters; destination = Tx_rollup dst; entrypoint} -> + | Internal + (Transaction + {amount; parameters; destination = Contract contract; entrypoint}) -> + apply_transaction + ~consume_deserialization_gas + ~ctxt + ~parameters + ~source + ~contract + ~amount + ~entrypoint + ~before_operation + ~payer + ~chain_id + ~mode + ~internal + | External + (Transaction + {amount; parameters; destination = Tx_rollup dst; entrypoint}) -> apply_transaction_to_rollup ~consume_deserialization_gas ~ctxt @@ -1248,21 +1271,34 @@ let apply_manager_operation_content : ~payer ~dst_rollup:dst ~since:before_operation - | Tx_rollup_withdraw - (* FIXME/TORU: #2488 The ticket accounting for the withdraw is not done here *) - { - tx_rollup; - level; - context_hash; - message_index; - withdraw_path; - contents; - ty; - ticketer; - amount; - destination; - entrypoint; - } -> + | Internal + (Transaction + {amount; parameters; destination = Tx_rollup dst; entrypoint}) -> + apply_transaction_to_rollup + ~consume_deserialization_gas + ~ctxt + ~parameters + ~amount + ~entrypoint + ~payer + ~dst_rollup:dst + ~since:before_operation + | External + (Tx_rollup_withdraw + (* FIXME/TORU: #2488 The ticket accounting for the withdraw is not done here *) + { + tx_rollup; + level; + context_hash; + message_index; + withdraw_path; + contents; + ty; + ticketer; + amount; + destination; + entrypoint; + }) -> (* Ticket parsing and hashing *) Script.force_decode_in_context ~consume_deserialization_gas ctxt ty >>?= fun (ty, ctxt) -> @@ -1338,7 +1374,7 @@ let apply_manager_operation_content : (* FIXME/TORU: #2488 the returned op will fail when ticket hardening is merged, it must be commented or fixed *) let op = - Internal_operation + Script_typed_ir.Internal_operation { source; (* TODO is 0 correct ? *) @@ -1358,7 +1394,7 @@ let apply_manager_operation_content : {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt} in return (ctxt, result, [op]) - | Origination {delegate; script; preorigination; credit} -> + | External (Origination {delegate; script; preorigination; credit}) -> Script.force_decode_in_context ~consume_deserialization_gas ctxt @@ -1374,9 +1410,27 @@ let apply_manager_operation_content : ~source ~credit ~before_operation - | Delegation delegate -> + | Internal (Origination {delegate; script; preorigination; credit}) -> + Script.force_decode_in_context + ~consume_deserialization_gas + ctxt + script.Script.storage + >>?= fun (_unparsed_storage, ctxt) -> + apply_origination + ~consume_deserialization_gas + ~ctxt + ~script + ~internal + ~preorigination + ~delegate + ~source + ~credit + ~before_operation + | External (Delegation delegate) -> apply_delegation ~ctxt ~source ~delegate ~since:before_operation - | Register_global_constant {value} -> + | Internal (Delegation delegate) -> + apply_delegation ~ctxt ~source ~delegate ~since:before_operation + | External (Register_global_constant {value}) -> (* Decode the value and consume gas appropriately *) Script.force_decode_in_context ~consume_deserialization_gas ctxt value >>?= fun (expr, ctxt) -> @@ -1408,7 +1462,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Set_deposits_limit limit -> ( + | External (Set_deposits_limit limit) -> ( (match limit with | None -> Result.return_unit | Some limit -> @@ -1440,7 +1494,7 @@ let apply_manager_operation_content : consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; }, [] )) - | Tx_rollup_origination -> + | External Tx_rollup_origination -> Tx_rollup.originate ctxt >>=? fun (ctxt, originated_tx_rollup) -> let result = Tx_rollup_origination_result @@ -1451,7 +1505,8 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} -> + | External (Tx_rollup_submit_batch {tx_rollup; content; burn_limit}) -> + assert_tx_rollup_feature_enabled ctxt >>=? fun () -> let (message, message_size) = Tx_rollup_message.make_batch content in Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) -> Tx_rollup_state.burn_cost ~limit:burn_limit state message_size @@ -1469,7 +1524,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Tx_rollup_commit {tx_rollup; commitment} -> ( + | External (Tx_rollup_commit {tx_rollup; commitment}) -> ( match Contract.is_implicit source with | None -> fail Tx_rollup_operation_with_non_implicit_contract @@ -1508,7 +1563,7 @@ let apply_manager_operation_content : } in return (ctxt, result, [])) - | Tx_rollup_return_bond {tx_rollup} -> ( + | External (Tx_rollup_return_bond {tx_rollup}) -> ( match Contract.is_implicit source with | None -> fail Tx_rollup_operation_with_non_implicit_contract | Some key -> @@ -1529,7 +1584,7 @@ let apply_manager_operation_content : } in return (ctxt, result, [])) - | Tx_rollup_finalize_commitment {tx_rollup} -> + | External (Tx_rollup_finalize_commitment {tx_rollup}) -> Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) -> Tx_rollup_commitment.finalize_commitment ctxt tx_rollup state >>=? fun (ctxt, state, level) -> @@ -1543,7 +1598,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Tx_rollup_remove_commitment {tx_rollup} -> + | External (Tx_rollup_remove_commitment {tx_rollup}) -> Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) -> Tx_rollup_commitment.remove_commitment ctxt tx_rollup state >>=? fun (ctxt, state, level) -> @@ -1557,7 +1612,9 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Tx_rollup_rejection {proof; tx_rollup; level; message; message_position} -> + | External + (Tx_rollup_rejection {proof; tx_rollup; level; message; message_position}) + -> Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) -> (* TODO/TORU: Check the proof *) Tx_rollup_inbox.check_message_hash @@ -1580,7 +1637,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Sc_rollup_originate {kind; boot_sector} -> + | External (Sc_rollup_originate {kind; boot_sector}) -> Sc_rollup_operations.originate ctxt ~kind ~boot_sector >>=? fun ({address; size}, ctxt) -> let consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt in @@ -1589,13 +1646,13 @@ let apply_manager_operation_content : {address; consumed_gas; size; balance_updates = []} in return (ctxt, result, []) - | Sc_rollup_add_messages {rollup; messages} -> + | External (Sc_rollup_add_messages {rollup; messages}) -> Sc_rollup.add_messages ctxt rollup messages >>=? fun (inbox_after, _size, ctxt) -> let consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt in let result = Sc_rollup_add_messages_result {consumed_gas; inbox_after} in return (ctxt, result, []) - | Sc_rollup_cement {rollup; commitment} -> + | External (Sc_rollup_cement {rollup; commitment}) -> Sc_rollup.cement_commitment ctxt rollup commitment >>=? fun ctxt -> let consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt in let result = Sc_rollup_cement_result {consumed_gas} in @@ -1607,7 +1664,8 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = let[@coq_struct "ctxt"] rec apply ctxt applied worklist = match worklist with | [] -> Lwt.return (Success ctxt, List.rev applied) - | Internal_operation ({source; operation; nonce} as op) :: rest -> ( + | Script_typed_ir.Internal_operation ({source; operation; nonce} as op) + :: rest -> ( let op_res = Apply_results.contents_of_internal_operation op in (if internal_nonce_already_recorded ctxt nonce then fail (Internal_operation_replay (Internal_contents op_res)) @@ -1621,20 +1679,20 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = ~chain_id ~internal:true ~gas_consumed_in_precheck:None - operation) + (Internal operation)) >>= function | Error errors -> let result = pack_internal_manager_operation_result op - (Failed (manager_kind op.operation, errors)) + (Failed (Script_typed_ir.manager_kind op.operation, errors)) in let skipped = List.rev_map - (fun (Internal_operation op) -> + (fun (Script_typed_ir.Internal_operation op) -> pack_internal_manager_operation_result op - (Skipped (manager_kind op.operation))) + (Skipped (Script_typed_ir.manager_kind op.operation))) rest in Lwt.return (Failure, List.rev (skipped @ result :: applied)) @@ -1896,7 +1954,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id ~internal:false ~gas_consumed_in_precheck ~chain_id - operation + (External operation) >>= function | Ok (ctxt, operation_results, internal_operations) -> ( apply_internal_manager_operations -- GitLab From 505771b8bd62c254b0722cb2a8ef6c60ca32bb15 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 3 Mar 2022 21:41:03 +0100 Subject: [PATCH 3/5] Proto/Michelson: make operation mutually recursive with ty. In preparation to allow internal operations to carry typed fields. --- .../lib_protocol/script_typed_ir.ml | 71 ++++++++++--------- .../lib_protocol/script_typed_ir.mli | 63 ++++++++-------- 2 files changed, 68 insertions(+), 66 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index c164587ef43d..98c5c1849ffc 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -98,41 +98,6 @@ type ('a, 'b) pair = 'a * 'b type ('a, 'b) union = L of 'a | R of 'b -type 'kind manager_operation = - | Transaction : - Alpha_context.transaction - -> Kind.transaction manager_operation - | Origination : - Alpha_context.origination - -> Kind.origination manager_operation - | Delegation : - Signature.Public_key_hash.t option - -> Kind.delegation manager_operation - -type packed_manager_operation = - | Manager : 'kind manager_operation -> packed_manager_operation - -let manager_kind : type kind. kind manager_operation -> kind Kind.manager = - function - | Transaction _ -> Kind.Transaction_manager_kind - | Origination _ -> Kind.Origination_manager_kind - | Delegation _ -> Kind.Delegation_manager_kind - -type 'kind internal_operation = { - source : Contract.contract; - operation : 'kind manager_operation; - nonce : int; -} - -type packed_internal_operation = - | Internal_operation : 'kind internal_operation -> packed_internal_operation -[@@ocaml.unboxed] - -type operation = { - piop : packed_internal_operation; - lazy_storage_diff : Lazy_storage.diffs option; -} - module Script_chain_id = struct type t = Chain_id_tag of Chain_id.t [@@ocaml.unboxed] @@ -1383,6 +1348,42 @@ and ('input, 'output) view_signature = } -> ('input, 'output) view_signature +and 'kind manager_operation = + | Transaction : + Alpha_context.transaction + -> Kind.transaction manager_operation + | Origination : + Alpha_context.origination + -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation + +and 'kind internal_operation = { + source : Contract.contract; + operation : 'kind manager_operation; + nonce : int; +} + +and packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation +[@@ocaml.unboxed] + +and operation = { + piop : packed_internal_operation; + lazy_storage_diff : Lazy_storage.diffs option; +} + +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation +[@@ocaml.unboxed] + +let manager_kind : type kind. kind manager_operation -> kind Kind.manager = + function + | Transaction _ -> Kind.Transaction_manager_kind + | Origination _ -> Kind.Origination_manager_kind + | Delegation _ -> Kind.Delegation_manager_kind + let kinfo_of_kinstr : type a s b f. (a, s, b, f) kinstr -> (a, s) kinfo = fun i -> match i with diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 01c4b25fd7a0..05a9e889c05d 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -78,37 +78,6 @@ type ('a, 'b) pair = 'a * 'b type ('a, 'b) union = L of 'a | R of 'b -type 'kind manager_operation = - | Transaction : - Alpha_context.transaction - -> Kind.transaction manager_operation - | Origination : - Alpha_context.origination - -> Kind.origination manager_operation - | Delegation : - Signature.Public_key_hash.t option - -> Kind.delegation manager_operation - -type packed_manager_operation = - | Manager : 'kind manager_operation -> packed_manager_operation - -val manager_kind : 'kind manager_operation -> 'kind Kind.manager - -type 'kind internal_operation = { - source : Contract.contract; - operation : 'kind manager_operation; - nonce : int; -} - -type packed_internal_operation = - | Internal_operation : 'kind internal_operation -> packed_internal_operation -[@@ocaml.unboxed] - -type operation = { - piop : packed_internal_operation; - lazy_storage_diff : Lazy_storage.diffs option; -} - module Script_chain_id : sig (** [t] is made algebraic in order to distinguish it from the other type parameters of [Script_typed_ir.ty]. *) @@ -1517,6 +1486,38 @@ and ('input, 'output) view_signature = } -> ('input, 'output) view_signature +and 'kind manager_operation = + | Transaction : + Alpha_context.transaction + -> Kind.transaction manager_operation + | Origination : + Alpha_context.origination + -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation + +and 'kind internal_operation = { + source : Contract.contract; + operation : 'kind manager_operation; + nonce : int; +} + +and packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation +[@@ocaml.unboxed] + +and operation = { + piop : packed_internal_operation; + lazy_storage_diff : Lazy_storage.diffs option; +} + +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation +[@@ocaml.unboxed] + +val manager_kind : 'kind manager_operation -> 'kind Kind.manager + val kinfo_of_kinstr : ('a, 's, 'b, 'f) kinstr -> ('a, 's) kinfo type kinstr_rewritek = { -- GitLab From b297489074417f526de797105a67e9ce1fcc4e41 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 10 Mar 2022 15:36:24 +0100 Subject: [PATCH 4/5] Proto/Michelson: factorization for apply_origination. Some code that's present for both the internal and the external cases. --- src/proto_alpha/lib_protocol/apply.ml | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 9baaec7c433e..ded97b3de40e 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1077,6 +1077,11 @@ let apply_transaction_to_rollup ~consume_deserialization_gas ~ctxt ~parameters let apply_origination ~consume_deserialization_gas ~ctxt ~script ~internal ~preorigination ~delegate ~source ~credit ~before_operation = + Script.force_decode_in_context + ~consume_deserialization_gas + ctxt + script.Script.storage + >>?= fun (_unparsed_storage, ctxt) -> Script.force_decode_in_context ~consume_deserialization_gas ctxt @@ -1395,11 +1400,6 @@ let apply_manager_operation_content : in return (ctxt, result, [op]) | External (Origination {delegate; script; preorigination; credit}) -> - Script.force_decode_in_context - ~consume_deserialization_gas - ctxt - script.Script.storage - >>?= fun (_unparsed_storage, ctxt) -> apply_origination ~consume_deserialization_gas ~ctxt @@ -1411,11 +1411,6 @@ let apply_manager_operation_content : ~credit ~before_operation | Internal (Origination {delegate; script; preorigination; credit}) -> - Script.force_decode_in_context - ~consume_deserialization_gas - ctxt - script.Script.storage - >>?= fun (_unparsed_storage, ctxt) -> apply_origination ~consume_deserialization_gas ~ctxt -- GitLab From eb59885a2e299b43877f3726113eebb37ffcc5c7 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 10 Mar 2022 22:45:35 +0100 Subject: [PATCH 5/5] Proto/Michelson: distinguish internal/external operation application. --- src/proto_alpha/lib_protocol/apply.ml | 226 +++++++++++++++----------- 1 file changed, 128 insertions(+), 98 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index ded97b3de40e..e4ed8a708ef1 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1170,10 +1170,6 @@ let apply_origination ~consume_deserialization_gas ~ctxt ~script ~internal in (ctxt, result, []) -type 'kind any_manager_operation = - | Internal of 'kind Script_typed_ir.manager_operation - | External of 'kind Alpha_context.manager_operation - (** Retrieving the source code of a contract from its address is costly @@ -1186,7 +1182,25 @@ type 'kind any_manager_operation = *) -let apply_manager_operation_content : +let prepare_apply_manager_operation_content ~ctxt ~source + ~gas_consumed_in_precheck = + let before_operation = + (* This context is not used for backtracking. Only to compute + gas consumption and originations for the operation result. *) + ctxt + in + Contract.must_exist ctxt source >>=? fun () -> + Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation >>?= fun ctxt -> + (match gas_consumed_in_precheck with + | None -> Ok ctxt + | Some gas -> Gas.consume ctxt gas) + >>?= fun ctxt -> + let consume_deserialization_gas = Script.When_needed in + (* [note]: deserialization gas has already been accounted for in the gas + consumed by the precheck and the lazy_exprs have been forced. *) + return (ctxt, before_operation, consume_deserialization_gas) + +let apply_internal_manager_operation_content : type kind. Alpha_context.t -> Script_ir_translator.unparsing_mode -> @@ -1195,7 +1209,7 @@ let apply_manager_operation_content : chain_id:Chain_id.t -> internal:bool -> gas_consumed_in_precheck:Gas.cost option -> - kind any_manager_operation -> + kind Script_typed_ir.manager_operation -> (context * kind successful_manager_operation_result * Script_typed_ir.packed_internal_operation list) @@ -1209,32 +1223,14 @@ let apply_manager_operation_content : ~internal ~gas_consumed_in_precheck operation -> - let before_operation = - (* This context is not used for backtracking. Only to compute - gas consumption and originations for the operation result. *) - ctxt - in - Contract.must_exist ctxt source >>=? fun () -> - Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation >>?= fun ctxt -> - (match gas_consumed_in_precheck with - | None -> Ok ctxt - | Some gas -> Gas.consume ctxt gas) - >>?= fun ctxt -> - let consume_deserialization_gas = Script.When_needed in - (* [note]: deserialization gas has already been accounted for in the gas - consumed by the precheck and the lazy_exprs have been forced. *) + prepare_apply_manager_operation_content + ~ctxt + ~source + ~gas_consumed_in_precheck + >>=? fun (ctxt, before_operation, consume_deserialization_gas) -> match operation with - | External (Reveal _) -> - return - (* No-op: action already performed by `precheck_manager_contents`. *) - ( ctxt, - (Reveal_result - {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt} - : kind successful_manager_operation_result), - [] ) - | External - (Transaction - {amount; parameters; destination = Contract contract; entrypoint}) -> + | Transaction + {amount; parameters; destination = Contract contract; entrypoint} -> apply_transaction ~consume_deserialization_gas ~ctxt @@ -1248,37 +1244,87 @@ let apply_manager_operation_content : ~chain_id ~mode ~internal - | Internal - (Transaction - {amount; parameters; destination = Contract contract; entrypoint}) -> - apply_transaction + >|=? fun (ctxt, manager_result, operations) -> + ( ctxt, + (manager_result : kind successful_manager_operation_result), + operations ) + | Transaction {amount; parameters; destination = Tx_rollup dst; entrypoint} -> + apply_transaction_to_rollup ~consume_deserialization_gas ~ctxt ~parameters - ~source - ~contract ~amount ~entrypoint - ~before_operation ~payer - ~chain_id - ~mode + ~dst_rollup:dst + ~since:before_operation + | Origination {delegate; script; preorigination; credit} -> + apply_origination + ~consume_deserialization_gas + ~ctxt + ~script ~internal - | External - (Transaction - {amount; parameters; destination = Tx_rollup dst; entrypoint}) -> - apply_transaction_to_rollup + ~preorigination + ~delegate + ~source + ~credit + ~before_operation + | Delegation delegate -> + apply_delegation ~ctxt ~source ~delegate ~since:before_operation + +let apply_external_manager_operation_content : + type kind. + Alpha_context.t -> + Script_ir_translator.unparsing_mode -> + payer:public_key_hash -> + source:Contract.t -> + chain_id:Chain_id.t -> + internal:bool -> + gas_consumed_in_precheck:Gas.cost option -> + kind Alpha_context.manager_operation -> + (context + * kind successful_manager_operation_result + * Script_typed_ir.packed_internal_operation list) + tzresult + Lwt.t = + fun ctxt + mode + ~payer + ~source + ~chain_id + ~internal + ~gas_consumed_in_precheck + operation -> + prepare_apply_manager_operation_content + ~ctxt + ~source + ~gas_consumed_in_precheck + >>=? fun (ctxt, before_operation, consume_deserialization_gas) -> + match operation with + | Reveal _ -> + return + (* No-op: action already performed by `precheck_manager_contents`. *) + ( ctxt, + (Reveal_result + {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt} + : kind successful_manager_operation_result), + [] ) + | Transaction + {amount; parameters; destination = Contract contract; entrypoint} -> + apply_transaction ~consume_deserialization_gas ~ctxt ~parameters + ~source + ~contract ~amount ~entrypoint + ~before_operation ~payer - ~dst_rollup:dst - ~since:before_operation - | Internal - (Transaction - {amount; parameters; destination = Tx_rollup dst; entrypoint}) -> + ~chain_id + ~mode + ~internal + | Transaction {amount; parameters; destination = Tx_rollup dst; entrypoint} -> apply_transaction_to_rollup ~consume_deserialization_gas ~ctxt @@ -1288,22 +1334,21 @@ let apply_manager_operation_content : ~payer ~dst_rollup:dst ~since:before_operation - | External - (Tx_rollup_withdraw - (* FIXME/TORU: #2488 The ticket accounting for the withdraw is not done here *) - { - tx_rollup; - level; - context_hash; - message_index; - withdraw_path; - contents; - ty; - ticketer; - amount; - destination; - entrypoint; - }) -> + | Tx_rollup_withdraw + (* FIXME/TORU: #2488 The ticket accounting for the withdraw is not done here *) + { + tx_rollup; + level; + context_hash; + message_index; + withdraw_path; + contents; + ty; + ticketer; + amount; + destination; + entrypoint; + } -> (* Ticket parsing and hashing *) Script.force_decode_in_context ~consume_deserialization_gas ctxt ty >>?= fun (ty, ctxt) -> @@ -1399,7 +1444,7 @@ let apply_manager_operation_content : {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt} in return (ctxt, result, [op]) - | External (Origination {delegate; script; preorigination; credit}) -> + | Origination {delegate; script; preorigination; credit} -> apply_origination ~consume_deserialization_gas ~ctxt @@ -1410,22 +1455,9 @@ let apply_manager_operation_content : ~source ~credit ~before_operation - | Internal (Origination {delegate; script; preorigination; credit}) -> - apply_origination - ~consume_deserialization_gas - ~ctxt - ~script - ~internal - ~preorigination - ~delegate - ~source - ~credit - ~before_operation - | External (Delegation delegate) -> + | Delegation delegate -> apply_delegation ~ctxt ~source ~delegate ~since:before_operation - | Internal (Delegation delegate) -> - apply_delegation ~ctxt ~source ~delegate ~since:before_operation - | External (Register_global_constant {value}) -> + | Register_global_constant {value} -> (* Decode the value and consume gas appropriately *) Script.force_decode_in_context ~consume_deserialization_gas ctxt value >>?= fun (expr, ctxt) -> @@ -1457,7 +1489,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | External (Set_deposits_limit limit) -> ( + | Set_deposits_limit limit -> ( (match limit with | None -> Result.return_unit | Some limit -> @@ -1489,7 +1521,7 @@ let apply_manager_operation_content : consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; }, [] )) - | External Tx_rollup_origination -> + | Tx_rollup_origination -> Tx_rollup.originate ctxt >>=? fun (ctxt, originated_tx_rollup) -> let result = Tx_rollup_origination_result @@ -1500,7 +1532,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | External (Tx_rollup_submit_batch {tx_rollup; content; burn_limit}) -> + | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} -> assert_tx_rollup_feature_enabled ctxt >>=? fun () -> let (message, message_size) = Tx_rollup_message.make_batch content in Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) -> @@ -1519,7 +1551,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | External (Tx_rollup_commit {tx_rollup; commitment}) -> ( + | Tx_rollup_commit {tx_rollup; commitment} -> ( match Contract.is_implicit source with | None -> fail Tx_rollup_operation_with_non_implicit_contract @@ -1558,7 +1590,7 @@ let apply_manager_operation_content : } in return (ctxt, result, [])) - | External (Tx_rollup_return_bond {tx_rollup}) -> ( + | Tx_rollup_return_bond {tx_rollup} -> ( match Contract.is_implicit source with | None -> fail Tx_rollup_operation_with_non_implicit_contract | Some key -> @@ -1579,7 +1611,7 @@ let apply_manager_operation_content : } in return (ctxt, result, [])) - | External (Tx_rollup_finalize_commitment {tx_rollup}) -> + | Tx_rollup_finalize_commitment {tx_rollup} -> Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) -> Tx_rollup_commitment.finalize_commitment ctxt tx_rollup state >>=? fun (ctxt, state, level) -> @@ -1593,7 +1625,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | External (Tx_rollup_remove_commitment {tx_rollup}) -> + | Tx_rollup_remove_commitment {tx_rollup} -> Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) -> Tx_rollup_commitment.remove_commitment ctxt tx_rollup state >>=? fun (ctxt, state, level) -> @@ -1607,9 +1639,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | External - (Tx_rollup_rejection {proof; tx_rollup; level; message; message_position}) - -> + | Tx_rollup_rejection {proof; tx_rollup; level; message; message_position} -> Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) -> (* TODO/TORU: Check the proof *) Tx_rollup_inbox.check_message_hash @@ -1632,7 +1662,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | External (Sc_rollup_originate {kind; boot_sector}) -> + | Sc_rollup_originate {kind; boot_sector} -> Sc_rollup_operations.originate ctxt ~kind ~boot_sector >>=? fun ({address; size}, ctxt) -> let consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt in @@ -1641,13 +1671,13 @@ let apply_manager_operation_content : {address; consumed_gas; size; balance_updates = []} in return (ctxt, result, []) - | External (Sc_rollup_add_messages {rollup; messages}) -> + | Sc_rollup_add_messages {rollup; messages} -> Sc_rollup.add_messages ctxt rollup messages >>=? fun (inbox_after, _size, ctxt) -> let consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt in let result = Sc_rollup_add_messages_result {consumed_gas; inbox_after} in return (ctxt, result, []) - | External (Sc_rollup_cement {rollup; commitment}) -> + | Sc_rollup_cement {rollup; commitment} -> Sc_rollup.cement_commitment ctxt rollup commitment >>=? fun ctxt -> let consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt in let result = Sc_rollup_cement_result {consumed_gas} in @@ -1666,7 +1696,7 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = fail (Internal_operation_replay (Internal_contents op_res)) else let ctxt = record_internal_nonce ctxt nonce in - apply_manager_operation_content + apply_internal_manager_operation_content ctxt mode ~source @@ -1674,7 +1704,7 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = ~chain_id ~internal:true ~gas_consumed_in_precheck:None - (Internal operation)) + operation) >>= function | Error errors -> let result = @@ -1941,7 +1971,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id let ctxt = Gas.set_limit ctxt gas_limit in let payer = source in let source = Contract.implicit_contract source in - apply_manager_operation_content + apply_external_manager_operation_content ctxt mode ~source @@ -1949,7 +1979,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id ~internal:false ~gas_consumed_in_precheck ~chain_id - (External operation) + operation >>= function | Ok (ctxt, operation_results, internal_operations) -> ( apply_internal_manager_operations -- GitLab