diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index 9c2157543f2c7753a44b37548d7f4cdc01b6cd53..74f1cbdc2e2111fe4ab29356748b502bde1a5653 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -693,7 +693,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/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 80b187271ac5159ce313a66a02f701d4aed81ecd..e5bab8c5e1d30dcc76112fe1a8c47911f3884fad 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -357,13 +357,7 @@ let build_origination_operation ?fee ?gas_limit ?storage_limit ~initial_storage >>=? fun {Michelson_v1_parser.expanded = storage; _} -> let code = Script.lazy_expr code and storage = Script.lazy_expr storage in let origination = - Origination - { - delegate; - script = {code; storage}; - credit = balance; - preorigination = None; - } + Origination {delegate; script = {code; storage}; credit = balance} in return (Injection.prepare_manager_operation diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index 518aa3c40677356220ef265c9306bbb784ce6a63..b483f29fe2201341c1c9232e0eea6cbb74b4641a 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -86,7 +86,7 @@ let print_run_result (cctxt : #Client_context.printer) ~show_source ~parsed = %a@]@]@." print_expr storage - (Format.pp_print_list Operation_result.pp_internal_operation) + (Format.pp_print_list Operation_result.pp_internal_operation_result) operations (fun ppf -> function | None -> () @@ -109,7 +109,7 @@ let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed = %a@]@]@." print_expr storage - (Format.pp_print_list Operation_result.pp_internal_operation) + (Format.pp_print_list Operation_result.pp_internal_operation_result) operations (fun ppf -> function | None -> () diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index a2e74ec6208055f6d9712a24fe01f68b23432bdc..41779bb3f090e54988df2cd3ec4cab4e888b805b 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -73,7 +73,9 @@ val run : chain:Shell_services.chain -> block:Shell_services.block -> run_params -> - (Script.expr * packed_internal_operation list * Lazy_storage.diffs option) + (Script.expr + * Apply_results.packed_internal_operation_result list + * Lazy_storage.diffs option) tzresult Lwt.t @@ -83,7 +85,7 @@ val trace : block:Shell_services.block -> run_params -> (Script.expr - * packed_internal_operation list + * Apply_results.packed_internal_operation_result list * Script_typed_ir.execution_trace * Lazy_storage.diffs option) tzresult @@ -99,7 +101,7 @@ val print_run_result : show_source:bool -> parsed:Michelson_v1_parser.parsed -> (Script_repr.expr - * packed_internal_operation list + * Apply_results.packed_internal_operation_result list * Lazy_storage.diffs option) tzresult -> unit tzresult Lwt.t @@ -109,7 +111,7 @@ val print_trace_result : show_source:bool -> parsed:Michelson_v1_parser.parsed -> (Script_repr.expr - * packed_internal_operation list + * Apply_results.packed_internal_operation_result 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 ecf5fb52bbd8afbaf603c7e6f3be17be2aaee150..486e2ede7de523f5edb3bebb4e3e26a576ae5078 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -337,7 +337,7 @@ let estimated_gas_single (type kind) in consumed_gas operation_result >>? fun gas -> List.fold_left_e - (fun acc (Internal_operation_result (_, r)) -> + (fun acc (Operation_result (_, r)) -> consumed_gas r >>? fun gas -> Ok (Gas.Arith.add acc gas)) gas internal_operation_results @@ -379,7 +379,7 @@ let estimated_storage_single (type kind) ~tx_rollup_origination_size in storage_size_diff operation_result >>? fun storage -> List.fold_left_e - (fun acc (Internal_operation_result (_, r)) -> + (fun acc (Operation_result (_, r)) -> storage_size_diff r >>? fun storage -> Ok (Z.add acc storage)) storage internal_operation_results @@ -433,7 +433,7 @@ let originated_contracts_single (type kind) originated_contracts operation_result >>? fun contracts -> let contracts = List.rev contracts in List.fold_left_e - (fun acc (Internal_operation_result (_, r)) -> + (fun acc (Operation_result (_, r)) -> originated_contracts r >>? fun contracts -> Ok (List.rev_append contracts acc)) contracts @@ -479,7 +479,7 @@ let detect_script_failure : type kind. kind operation_metadata -> _ = in detect_script_failure operation_result >>? fun () -> List.iter_e - (fun (Internal_operation_result (_, r)) -> detect_script_failure r) + (fun (Operation_result (_, r)) -> detect_script_failure r) internal_operation_results in function diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index e74e64be2b3bb2566f2d11f5b9a18bee8280b9ee..72f0077a7b3b525126824d86f29075f3ecbb449a 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -376,12 +376,12 @@ let report_errors ~details ~show_source ?parsed ppf errs = (parsed, hilights) ; if rest <> [] then Format.fprintf ppf "@," ; print_trace (parsed_locations parsed) rest - | Environment.Ecoproto_error (Apply.Internal_operation_replay op) :: rest -> + | Environment.Ecoproto_error (Apply.Internal_operation_replay {nonce}) + :: rest -> Format.fprintf ppf - "@[Internal operation replay attempt:@,%a@]" - Operation_result.pp_internal_operation - op ; + "@[Internal operation replay attempt:@,%d@]" + nonce ; if rest <> [] then Format.fprintf ppf "@," ; print_trace locations rest | Environment.Ecoproto_error Gas.Gas_limit_too_high :: rest -> diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index 503c81d1c1703284176596a27321bf950d9682c4..3f6e1a1a61955c7b6cb703dcbea7a4136d478f6b 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -58,8 +58,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf expr) ; pp_result ppf result ; Format.fprintf ppf "@]" - | Origination {delegate; credit; script = {code; storage}; preorigination = _} - -> + | Origination {delegate; credit; script = {code; storage}} -> Format.fprintf ppf "@[%s:@,From: %a@,Credit: %s%a" @@ -320,6 +319,17 @@ let pp_balance_updates_opt ppf balance_updates = pp_balance_updates balance_updates +let manager_operation (type kind) + (operation : kind internal_operation_contents_result) : + kind manager_operation = + match operation with + | Transaction transaction -> Alpha_context.Transaction transaction + | Origination {origination; preorigination = _} -> + Alpha_context.Origination origination + | Delegation delegate -> Alpha_context.Delegation delegate + | Tx_rollup_commit tx_rollup_commit -> + Alpha_context.Tx_rollup_commit tx_rollup_commit + let pp_manager_operation_contents_and_result ppf ( Manager_operation {source; fee; operation; counter; gas_limit; storage_limit}, @@ -624,13 +634,14 @@ let pp_manager_operation_contents_and_result ppf Format.fprintf ppf "@,@[Internal operations:@ %a@]" - (Format.pp_print_list (fun ppf (Internal_operation_result (op, res)) -> + (Format.pp_print_list (fun ppf (Operation_result (op, res)) -> + let operation = manager_operation op.operation in pp_manager_operation_content op.source false pp_result ppf - (op.operation, res))) + (operation, res))) internal_operation_results) ; Format.fprintf ppf "@]" @@ -792,11 +803,16 @@ let pp_operation_result ppf pp_contents_and_result_list ppf contents_and_result_list ; Format.fprintf ppf "@]@." -let pp_internal_operation ppf - (Internal_operation {source; operation; nonce = _}) = +let pp_internal_operation_result ppf + (Apply_results.Internal_operation_result op) = + let operation = manager_operation op.operation in pp_manager_operation_content - source + op.source true (fun _ppf () -> ()) ppf (operation, ()) + +let pp_internal_operation ppf Script_typed_ir.(Internal_operation op) = + let op = result_of_internal_operation op in + pp_internal_operation_result ppf (Internal_operation_result op) diff --git a/src/proto_alpha/lib_client/operation_result.mli b/src/proto_alpha/lib_client/operation_result.mli index cc03abfcd36b557649a201ff65bf21831488fbd0..40157341b5365c8012be973b33f673e74b042ace 100644 --- a/src/proto_alpha/lib_client/operation_result.mli +++ b/src/proto_alpha/lib_client/operation_result.mli @@ -27,7 +27,10 @@ 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_operation_result -> 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 511a6d937f85cea6e851a86d246c98262adefdf6..e765c06f3fc3d35143604e77bab5bf5acd5f4ae8 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.Alpha_context.Operation.internal_operation_encoding ; + Protocol.Apply_results.internal_operation_result_encoding ; register @@ def "operation" diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index a404b33372bf320bb6473476eb2e9ed3440a0b82..051063685ee91b6e90e6546e5d2018b918e60db1 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -1461,8 +1461,11 @@ module View_helpers = struct in match operations with | [ - Internal_operation - {operation = Transaction {destination; parameters; _}; _}; + Script_typed_ir.Internal_operation + { + operation = Transaction {transaction = {destination; parameters; _}; _}; + _; + }; ] when Destination.equal destination (Contract callback) -> ok parameters @@ -1601,7 +1604,9 @@ module RPC = struct (storage, operations, lazy_storage_diff)) (obj3 (req "storage" Script.expr_encoding) - (req "operations" (list Operation.internal_operation_encoding)) + (req + "operations" + (list Apply_results.internal_operation_result_encoding)) (opt "lazy_storage_diff" Lazy_storage.encoding)) let trace_code_input_encoding = run_code_input_encoding @@ -1621,7 +1626,9 @@ module RPC = struct (storage, operations, trace, lazy_storage_diff)) (obj4 (req "storage" Script.expr_encoding) - (req "operations" (list Operation.internal_operation_encoding)) + (req + "operations" + (list Apply_results.internal_operation_result_encoding)) (req "trace" trace_encoding) (opt "lazy_storage_diff" Lazy_storage.encoding)) @@ -2177,7 +2184,7 @@ module RPC = struct entrypoints entrypoint >>? fun (r, ctxt) -> - r >>? fun (_f, Ex_ty ty) -> + r >>? fun (Ex_ty_cstr (ty, _)) -> unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _) -> Micheline.strip_locations ty_node ) in @@ -2237,7 +2244,7 @@ module RPC = struct ~cached_script:None ~script:{storage; code} ~entrypoint - ~parameter + ~parameter:(Untyped_arg parameter) ~internal:true >|=? fun ( { Script_interpreter.storage; @@ -2245,7 +2252,10 @@ module RPC = struct lazy_storage_diff; _; }, - _ ) -> (storage, operations, lazy_storage_diff)) ; + _ ) -> + ( storage, + Apply_results.results_of_internal_operations operations, + lazy_storage_diff )) ; Registration.register0 ~chunked:true S.trace_code @@ -2304,14 +2314,18 @@ module RPC = struct step_constants ~script:{storage; code} ~entrypoint - ~parameter + ~parameter:(Untyped_arg parameter) >|=? fun ( { Script_interpreter.storage; operations; lazy_storage_diff; _; }, - trace ) -> (storage, operations, trace, lazy_storage_diff)) ; + trace ) -> + ( storage, + Apply_results.results_of_internal_operations operations, + trace, + lazy_storage_diff )) ; Registration.register0 ~chunked:true S.run_view @@ -2395,7 +2409,7 @@ module RPC = struct ~script ~cached_script:None ~entrypoint - ~parameter + ~parameter:(Untyped_arg parameter) ~internal:true >>=? fun ({Script_interpreter.operations; _}, (_, _)) -> View_helpers.extract_parameter_from_operations @@ -3037,13 +3051,7 @@ module RPC = struct ~storage_limit [ Manager - (Origination - { - delegate = delegatePubKey; - script; - credit = balance; - preorigination = None; - }); + (Origination {delegate = delegatePubKey; script; credit = balance}); ] let delegation ctxt block ~branch ~source ?sourcePubKey ~counter ~fee diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 2931cde48ef4290c62d7233c44667fd2bfc58628..cb49666e422c51fcbabef3ed56ed420125208805 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2259,6 +2259,24 @@ val consensus_content_encoding : consensus_content Data_encoding.t val pp_consensus_content : Format.formatter -> consensus_content -> unit +type transaction = { + amount : Tez.tez; + parameters : Script.lazy_expr; + entrypoint : Entrypoint.t; + destination : Destination.t; +} + +type origination = { + delegate : Signature.Public_key_hash.t option; + script : Script.t; + credit : Tez.tez; +} + +type manager_tx_rollup_commit = { + tx_rollup : Tx_rollup.t; + commitment : Tx_rollup_commitments.Commitment.t; +} + type 'kind operation = { shell : Operation.shell_header; protocol_data : 'kind protocol_data; @@ -2329,20 +2347,8 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation - | Transaction : { - amount : Tez.tez; - parameters : Script.lazy_expr; - entrypoint : Entrypoint.t; - destination : Destination.t; - } - -> Kind.transaction manager_operation - | Origination : { - delegate : Signature.Public_key_hash.t option; - script : Script.t; - credit : Tez.tez; - preorigination : Contract.t option; - } - -> Kind.origination manager_operation + | Transaction : transaction -> Kind.transaction manager_operation + | Origination : origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation @@ -2360,10 +2366,8 @@ and _ manager_operation = burn_limit : Tez.tez option; } -> Kind.tx_rollup_submit_batch manager_operation - | Tx_rollup_commit : { - tx_rollup : Tx_rollup.t; - commitment : Tx_rollup_commitments.Commitment.t; - } + | Tx_rollup_commit : + manager_tx_rollup_commit -> Kind.tx_rollup_commit manager_operation | Sc_rollup_originate : { kind : Sc_rollup.Kind.t; @@ -2378,12 +2382,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 @@ -2400,9 +2398,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 @@ -2460,11 +2455,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 packed_internal_operation_in_memory_size : - packed_internal_operation -> Cache_memory_helpers.nodes_and_size - val pack : 'kind operation -> packed_operation type ('a, 'b) eq = Eq : ('a, 'a) eq @@ -2506,10 +2496,16 @@ module Operation : sig val reveal_case : Kind.reveal Kind.manager case + val transaction_tag : int + val transaction_case : Kind.transaction Kind.manager case + val origination_tag : int + val origination_case : Kind.origination Kind.manager case + val delegation_tag : int + val delegation_case : Kind.delegation Kind.manager case val tx_rollup_origination_case : diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index a049c1ed410f4ca643fffe0aeb7649485c4bf5fc..233c3d8dc7e221c511a4e24cd3c55db67fea9f02 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -542,8 +542,7 @@ let () = type error += | (* `Temporary *) Wrong_voting_period of {expected : int32; provided : int32} -type error += - | (* `Permanent *) Internal_operation_replay of packed_internal_operation +type error += (* `Permanent *) Internal_operation_replay of {nonce : int} type denunciation_kind = Preendorsement | Endorsement | Block @@ -625,14 +624,14 @@ let () = ~id:"internal_operation_replay" ~title:"Internal operation replay" ~description:"An internal operation was emitted twice by a script" - ~pp:(fun ppf (Internal_operation {nonce; _}) -> + ~pp:(fun ppf nonce -> Format.fprintf ppf "Internal operation %d was emitted twice by a script" nonce) - Operation.internal_operation_encoding - (function Internal_operation_replay op -> Some op | _ -> None) - (fun op -> Internal_operation_replay op) ; + Data_encoding.(obj1 (req "nonce" int16)) + (function Internal_operation_replay {nonce} -> Some nonce | _ -> None) + (fun nonce -> Internal_operation_replay {nonce}) ; register_error_kind `Permanent ~id:"block.invalid_denunciation" @@ -831,6 +830,238 @@ let assert_tx_rollup_feature_enabled ctxt = let assert_sc_rollup_feature_enabled ctxt = fail_unless (Constants.sc_rollup_enable ctxt) Sc_rollup_feature_disabled +let apply_delegation ctxt source delegate since = + Delegate.set ctxt source delegate >|=? fun ctxt -> + (ctxt, Delegation_result {consumed_gas = Gas.consumed ~since ~until:ctxt}, []) + +let apply_transaction ~ctxt parameter ~source ~destination amount entrypoint + ~before_operation ~payer chain_id mode ~internal = + (match Contract.is_implicit destination with + | None -> + (if Tez.(amount = zero) then + (* Detect potential call to non existent contract. *) + Contract.must_exist ctxt destination + else return_unit) + >>=? fun () -> + (* Since the contract is originated, nothing will be allocated + or the next transfer of tokens will fail. *) + return_false + | Some _ -> + (* Transfers of zero to implicit accounts are forbidden. *) + error_when Tez.(amount = zero) (Empty_transaction destination) + >>?= fun () -> + (* If the implicit contract is not yet allocated at this point then + the next transfer of tokens will allocate it. *) + Contract.allocated ctxt destination >|=? not) + >>=? fun allocated_destination_contract -> + Token.transfer ctxt (`Contract source) (`Contract destination) amount + >>=? fun (ctxt, balance_updates) -> + Script_cache.find ctxt destination >>=? fun (ctxt, cache_key, script) -> + match script with + | None -> + Lwt.return + ( ( (if Entrypoint.is_default entrypoint then Result.return_unit + else error (Script_tc_errors.No_such_entrypoint entrypoint)) + >>? fun () -> + match parameter with + | Script_interpreter.Typed_arg (Unit_t, _) -> + (* Allow [Unit] parameter to non-scripted contracts. *) + ok ctxt + | Script_interpreter.Untyped_arg parameter -> ( + match Micheline.root parameter with + | Prim (_, D_Unit, [], _) -> + (* Allow [Unit] parameter to non-scripted contracts. *) + ok ctxt + | _ -> + error + (Script_interpreter.Bad_contract_parameter destination)) + | _ -> error (Script_interpreter.Bad_contract_parameter destination) + ) + >|? fun ctxt -> + let result = + Transaction_result + (Transaction_to_contract_result + { + storage = None; + lazy_storage_diff = None; + balance_updates; + originated_contracts = []; + consumed_gas = + Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = Z.zero; + paid_storage_size_diff = Z.zero; + allocated_destination_contract; + }) + in + (ctxt, result, []) ) + | Some (script, script_ir) -> + (* Token.transfer which is being called above already loads this + value into the Irmin cache, so no need to burn gas for it. *) + Contract.get_balance ctxt destination >>=? fun balance -> + let now = Script_timestamp.now ctxt in + let level = + (Level.current ctxt).level |> Raw_level.to_int32 |> Script_int.of_int32 + |> Script_int.abs + in + let step_constants = + let open Script_interpreter in + { + source; + payer; + self = destination; + amount; + chain_id; + balance; + now; + level; + } + in + Script_interpreter.execute + ctxt + ~cached_script:(Some script_ir) + mode + step_constants + ~script + ~parameter + ~entrypoint + ~internal + >>=? fun ( {ctxt; storage; lazy_storage_diff; operations}, + (updated_cached_script, updated_size) ) -> + Contract.update_script_storage ctxt destination storage lazy_storage_diff + >>=? fun ctxt -> + Fees.record_paid_storage_space ctxt destination + >>=? fun (ctxt, new_size, paid_storage_size_diff) -> + Contract.originated_from_current_nonce ~since:before_operation ~until:ctxt + >>=? fun originated_contracts -> + Lwt.return + ( Script_cache.update + ctxt + cache_key + ( {script with storage = Script.lazy_expr storage}, + updated_cached_script ) + updated_size + >|? fun ctxt -> + let result = + Transaction_result + (Transaction_to_contract_result + { + storage = Some storage; + lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas = + Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = new_size; + paid_storage_size_diff; + allocated_destination_contract; + }) + in + (ctxt, result, operations) ) + +let apply_origination consume_deserialization_gas ~ctxt parsed_script script + ~internal preoriginate ~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 + script.Script.code + >>?= fun (unparsed_code, ctxt) -> + (match parsed_script with + | None -> + Script_ir_translator.parse_script + ctxt + ~legacy:false + ~allow_forged_in_storage:internal + script + | Some parsed_script -> + return (Script_ir_translator.Ex_script parsed_script, ctxt)) + >>=? fun (Ex_script parsed_script, ctxt) -> + let views_result = + Script_ir_translator.typecheck_views + ctxt + ~legacy:false + parsed_script.storage_type + parsed_script.views + in + trace (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) views_result + >>=? fun ctxt -> + Script_ir_translator.collect_lazy_storage + ctxt + parsed_script.storage_type + parsed_script.storage + >>?= fun (to_duplicate, ctxt) -> + let to_update = Script_ir_translator.no_lazy_storage_id in + Script_ir_translator.extract_lazy_storage_diff + ctxt + Optimized + parsed_script.storage_type + parsed_script.storage + ~to_duplicate + ~to_update + ~temporary:false + >>=? fun (storage, lazy_storage_diff, ctxt) -> + Script_ir_translator.unparse_data + ctxt + Optimized + parsed_script.storage_type + storage + >>=? fun (storage, ctxt) -> + let storage = Script.lazy_expr (Micheline.strip_locations storage) in + let script = {script with storage} in + preoriginate ctxt >>?= fun (ctxt, contract) -> + Contract.raw_originate + ctxt + ~prepaid_bootstrap_storage:false + contract + ~script:(script, lazy_storage_diff) + >>=? fun ctxt -> + (match delegate with + | None -> return ctxt + | Some delegate -> Delegate.init ctxt contract delegate) + >>=? fun ctxt -> + Token.transfer ctxt (`Contract source) (`Contract contract) credit + >>=? fun (ctxt, balance_updates) -> + Fees.record_paid_storage_space ctxt contract + >|=? fun (ctxt, size, paid_storage_size_diff) -> + let result = + Origination_result + { + lazy_storage_diff; + balance_updates; + originated_contracts = [contract]; + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = size; + paid_storage_size_diff; + } + in + (ctxt, result, []) + +let apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation = + (* TODO: bonds https://gitlab.com/tezos/tezos/-/issues/2459 *) + match Contract.is_implicit source with + | None -> + fail Tx_rollup_commit_with_non_implicit_contract + (* This is only called with implicit contracts *) + | Some key -> + Tx_rollup_commitments.add_commitment ctxt tx_rollup key commitment + >>=? fun ctxt -> + let result = + Tx_rollup_commit_result + { + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; + balance_updates = []; + } + in + return (ctxt, result, []) + +type 'kind any_manager_operation = + | Internal_mop of 'kind Script_typed_ir.manager_operation + | External_mop of 'kind Alpha_context.manager_operation + (** Retrieving the source code of a contract from its address is costly @@ -852,10 +1083,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 @@ -881,7 +1112,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_mop (Reveal _) -> return (* No-op: action already performed by `precheck_manager_contents`. *) ( ctxt, @@ -889,226 +1120,88 @@ let apply_manager_operation_content : {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt} : kind successful_manager_operation_result), [] ) - | Transaction - {amount; parameters; destination = Contract destination; entrypoint} -> ( + | External_mop + (Transaction + {amount; parameters; destination = Contract destination; entrypoint}) -> Script.force_decode_in_context ~consume_deserialization_gas ctxt parameters >>?= fun (parameter, ctxt) -> - (match Contract.is_implicit destination with - | None -> - (if Tez.(amount = zero) then - (* Detect potential call to non existent contract. *) - Contract.must_exist ctxt destination - else return_unit) - >>=? fun () -> - (* Since the contract is originated, nothing will be allocated - or the next transfer of tokens will fail. *) - return_false - | Some _ -> - (* Transfers of zero to implicit accounts are forbidden. *) - error_when Tez.(amount = zero) (Empty_transaction destination) - >>?= fun () -> - (* If the implicit contract is not yet allocated at this point then - the next transfer of tokens will allocate it. *) - Contract.allocated ctxt destination >|=? not) - >>=? fun allocated_destination_contract -> - Token.transfer ctxt (`Contract source) (`Contract destination) amount - >>=? fun (ctxt, balance_updates) -> - Script_cache.find ctxt destination >>=? fun (ctxt, cache_key, script) -> - match script with - | None -> - Lwt.return - ( ( (if Entrypoint.is_default entrypoint then Result.return_unit - else error (Script_tc_errors.No_such_entrypoint entrypoint)) - >>? fun () -> - match Micheline.root parameter with - | Prim (_, D_Unit, [], _) -> - (* Allow [Unit] parameter to non-scripted contracts. *) - ok ctxt - | _ -> - error - (Script_interpreter.Bad_contract_parameter destination) ) - >|? fun ctxt -> - let result = - Transaction_result - (Transaction_to_contract_result - { - storage = None; - lazy_storage_diff = None; - balance_updates; - originated_contracts = []; - consumed_gas = - Gas.consumed ~since:before_operation ~until:ctxt; - storage_size = Z.zero; - paid_storage_size_diff = Z.zero; - allocated_destination_contract; - }) - in - (ctxt, result, []) ) - | Some (script, script_ir) -> - (* Token.transfer which is being called above already loads this - value into the Irmin cache, so no need to burn gas for it. *) - Contract.get_balance ctxt destination >>=? fun balance -> - let now = Script_timestamp.now ctxt in - let level = - (Level.current ctxt).level |> Raw_level.to_int32 - |> Script_int.of_int32 |> Script_int.abs - in - let step_constants = - let open Script_interpreter in - { - source; - payer; - self = destination; - amount; - chain_id; - balance; - now; - level; - } - in - Script_interpreter.execute - ctxt - ~cached_script:(Some script_ir) - mode - step_constants - ~script - ~parameter - ~entrypoint - ~internal - >>=? fun ( {ctxt; storage; lazy_storage_diff; operations}, - (updated_cached_script, updated_size) ) -> - Contract.update_script_storage - ctxt - destination - storage - lazy_storage_diff - >>=? fun ctxt -> - Fees.record_paid_storage_space ctxt destination - >>=? fun (ctxt, new_size, paid_storage_size_diff) -> - Contract.originated_from_current_nonce - ~since:before_operation - ~until:ctxt - >>=? fun originated_contracts -> - Lwt.return - ( Script_cache.update - ctxt - cache_key - ( {script with storage = Script.lazy_expr storage}, - updated_cached_script ) - updated_size - >|? fun ctxt -> - let result = - Transaction_result - (Transaction_to_contract_result - { - storage = Some storage; - lazy_storage_diff; - balance_updates; - originated_contracts; - consumed_gas = - Gas.consumed ~since:before_operation ~until:ctxt; - storage_size = new_size; - paid_storage_size_diff; - allocated_destination_contract; - }) - in - (ctxt, result, operations) )) - | Origination {delegate; script; preorigination; credit} -> - Script.force_decode_in_context - ~consume_deserialization_gas - ctxt - script.storage - >>?= fun (_unparsed_storage, ctxt) -> - Script.force_decode_in_context - ~consume_deserialization_gas - ctxt - script.code - >>?= fun (unparsed_code, ctxt) -> - Script_ir_translator.parse_script - ctxt - ~legacy:false - ~allow_forged_in_storage:internal - script - >>=? fun (Ex_script parsed_script, ctxt) -> - let views_result = - Script_ir_translator.typecheck_views - ctxt - ~legacy:false - parsed_script.storage_type - parsed_script.views - in - trace - (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) - views_result - >>=? fun ctxt -> - Script_ir_translator.collect_lazy_storage - ctxt - parsed_script.storage_type - parsed_script.storage - >>?= fun (to_duplicate, ctxt) -> - let to_update = Script_ir_translator.no_lazy_storage_id in - Script_ir_translator.extract_lazy_storage_diff - ctxt - Optimized - parsed_script.storage_type - parsed_script.storage - ~to_duplicate - ~to_update - ~temporary:false - >>=? fun (storage, lazy_storage_diff, ctxt) -> - Script_ir_translator.unparse_data - ctxt - Optimized - parsed_script.storage_type - storage - >>=? fun (storage, ctxt) -> - let storage = Script.lazy_expr (Micheline.strip_locations storage) in - let script = {script with storage} in - (match preorigination with - | Some contract -> - assert internal ; - (* The preorigination field is only used to early return - the address of an originated contract in Michelson. - It cannot come from the outside. *) - ok (ctxt, contract) - | None -> Contract.fresh_contract_from_current_nonce ctxt) - >>?= fun (ctxt, contract) -> - Contract.raw_originate - ctxt - ~prepaid_bootstrap_storage:false - contract - ~script:(script, lazy_storage_diff) - >>=? fun ctxt -> - (match delegate with - | None -> return ctxt - | Some delegate -> Delegate.init ctxt contract delegate) - >>=? fun ctxt -> - Token.transfer ctxt (`Contract source) (`Contract contract) credit - >>=? fun (ctxt, balance_updates) -> - Fees.record_paid_storage_space ctxt contract - >|=? fun (ctxt, size, paid_storage_size_diff) -> - let result = - Origination_result - { - lazy_storage_diff; - balance_updates; - originated_contracts = [contract]; - consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; - storage_size = size; - paid_storage_size_diff; - } + apply_transaction + ~ctxt + (Script_interpreter.Untyped_arg parameter) + ~source + ~destination + amount + entrypoint + ~before_operation + ~payer + chain_id + mode + ~internal + | Internal_mop + (Transaction {transaction; parameters_ty; parameters = typed_parameters}) + -> + let { + amount; + parameters = _; + destination = Contract destination; + entrypoint; + } = + transaction in - (ctxt, result, []) - | Delegation delegate -> - Delegate.set ctxt source delegate >|=? fun ctxt -> - ( ctxt, - Delegation_result - {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}, - [] ) - | Register_global_constant {value} -> + apply_transaction + ~ctxt + (Script_interpreter.Typed_arg (parameters_ty, typed_parameters)) + ~source + ~destination + amount + entrypoint + ~before_operation + ~payer + chain_id + mode + ~internal + | External_mop (Origination {delegate; script; credit}) -> + (* The preoriginate parameter is only used to early return the address of + an originated contract in Michelson. It cannot come from the + outside. *) + let preoriginate ctxt = Contract.fresh_contract_from_current_nonce ctxt in + apply_origination + consume_deserialization_gas + ~ctxt + None + script + ~internal + preoriginate + ~delegate + ~source + credit + ~before_operation + | Internal_mop + (Origination + { + origination = {delegate; script; credit}; + preorigination; + parsed_script; + }) -> + apply_origination + consume_deserialization_gas + ~ctxt + (Some parsed_script) + script + ~internal + (fun ctxt -> ok (ctxt, preorigination)) + ~delegate + ~source + credit + ~before_operation + | External_mop (Delegation delegate) -> + apply_delegation ctxt source delegate before_operation + | Internal_mop (Delegation delegate) -> + apply_delegation ctxt source delegate before_operation + | External_mop (Register_global_constant {value}) -> (* Decode the value and consume gas appropriately *) Script.force_decode_in_context ~consume_deserialization_gas ctxt value >>?= fun (expr, ctxt) -> @@ -1140,7 +1233,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Set_deposits_limit limit -> ( + | External_mop (Set_deposits_limit limit) -> ( (match limit with | None -> Result.return_unit | Some limit -> @@ -1172,7 +1265,7 @@ let apply_manager_operation_content : consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; }, [] )) - | Tx_rollup_origination -> + | External_mop Tx_rollup_origination -> Tx_rollup.originate ctxt >>=? fun (ctxt, originated_tx_rollup) -> let result = Tx_rollup_origination_result @@ -1183,7 +1276,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} -> + | External_mop (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) -> @@ -1201,24 +1294,11 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Tx_rollup_commit {tx_rollup; commitment} -> ( - (* TODO: bonds https://gitlab.com/tezos/tezos/-/issues/2459 *) - match Contract.is_implicit source with - | None -> - fail Tx_rollup_commit_with_non_implicit_contract - (* This is only called with implicit contracts *) - | Some key -> - Tx_rollup_commitments.add_commitment ctxt tx_rollup key commitment - >>=? fun ctxt -> - let result = - Tx_rollup_commit_result - { - consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; - balance_updates = []; - } - in - return (ctxt, result, [])) - | Sc_rollup_originate {kind; boot_sector} -> + | External_mop (Tx_rollup_commit {tx_rollup; commitment}) -> + apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation + | Internal_mop (Tx_rollup_commit {tx_rollup; commitment}) -> + apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation + | External_mop (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 @@ -1227,7 +1307,7 @@ let apply_manager_operation_content : {address; consumed_gas; size; balance_updates = []} in return (ctxt, result, []) - | Sc_rollup_add_messages {rollup; messages} -> + | External_mop (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 @@ -1240,9 +1320,10 @@ 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 -> ( (if internal_nonce_already_recorded ctxt nonce then - fail (Internal_operation_replay (Internal_operation op)) + fail (Internal_operation_replay {nonce}) else let ctxt = record_internal_nonce ctxt nonce in apply_manager_operation_content @@ -1253,25 +1334,27 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = ~chain_id ~internal:true ~gas_consumed_in_precheck:None - operation) + (Internal_mop operation)) >>= function | Error errors -> let result = - Internal_operation_result - (op, Failed (manager_kind op.operation, errors)) + pack_operation_result + op + (Failed (Script_typed_ir.manager_kind op.operation, errors)) in let skipped = List.rev_map - (fun (Internal_operation op) -> - Internal_operation_result - (op, Skipped (manager_kind op.operation))) + (fun (Script_typed_ir.Internal_operation op) -> + pack_operation_result + op + (Skipped (Script_typed_ir.manager_kind op.operation))) rest in Lwt.return (Failure, List.rev (skipped @ result :: applied)) | Ok (ctxt, result, emitted) -> apply ctxt - (Internal_operation_result (op, Applied result) :: applied) + (pack_operation_result op (Applied result) :: applied) (emitted @ rest)) in apply ctxt [] ops @@ -1502,7 +1585,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id ~gas_consumed_in_precheck (op : kind Kind.manager contents) : (success_or_failure * kind manager_operation_result - * packed_internal_operation_result list) + * packed_operation_result list) Lwt.t = let[@coq_match_with_default] (Manager_operation { @@ -1526,7 +1609,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id ~internal:false ~gas_consumed_in_precheck ~chain_id - operation + (External_mop operation) >>= function | Ok (ctxt, operation_results, internal_operations) -> ( apply_internal_manager_operations @@ -1542,14 +1625,12 @@ let apply_manager_contents (type kind) ctxt mode chain_id | Ok (ctxt, storage_limit, operation_results) -> ( List.fold_left_es (fun (ctxt, storage_limit, res) iopr -> - let (Internal_operation_result (op, mopr)) = iopr in + let (Operation_result (op, mopr)) = iopr in match mopr with | Applied smopr -> burn_storage_fees ctxt smopr ~storage_limit ~payer:source >>=? fun (ctxt, storage_limit, smopr) -> - let iopr = - Internal_operation_result (op, Applied smopr) - in + let iopr = Operation_result (op, Applied smopr) in return (ctxt, storage_limit, iopr :: res) | _ -> return (ctxt, storage_limit, iopr :: res)) (ctxt, storage_limit, []) @@ -1808,9 +1889,8 @@ let mark_backtracked results = op.internal_operation_results; }, mark_contents_list rest ) - and mark_internal_operation_results (Internal_operation_result (kind, result)) - = - Internal_operation_result (kind, mark_manager_operation_result result) + and mark_internal_operation_results (Operation_result (kind, result)) = + Operation_result (kind, mark_manager_operation_result result) and mark_manager_operation_result : type kind. kind manager_operation_result -> kind manager_operation_result = function @@ -2539,7 +2619,7 @@ let apply_liquidity_baking_subsidy ctxt ~escape_vote = Optimized step_constants ~script - ~parameter + ~parameter:(Untyped_arg parameter) ~cached_script:(Some script_ir) ~entrypoint:Entrypoint.default ~internal:false diff --git a/src/proto_alpha/lib_protocol/apply.mli b/src/proto_alpha/lib_protocol/apply.mli index 3083094a71514b096a0eafce01f4a3e3c174604c..d0651ee2fff920cfc89c86529f00732fca02f591 100644 --- a/src/proto_alpha/lib_protocol/apply.mli +++ b/src/proto_alpha/lib_protocol/apply.mli @@ -36,8 +36,7 @@ open Alpha_context open Apply_results -type error += - | (* `Permanent *) Internal_operation_replay of packed_internal_operation +type error += (* `Permanent *) Internal_operation_replay of {nonce : int} type error += (* Permanent *) Gas_quota_exceeded_init_deserialize diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index ab9b01cbb3ad0cc22a2d660aeeef853cec9070e6..27d479640d6ce612675d6d295488090102018338 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -46,6 +46,53 @@ let error_encoding = let trace_encoding = make_trace_encoding error_encoding +type 'kind internal_operation_contents_result = + | Transaction : + Alpha_context.transaction + -> Kind.transaction internal_operation_contents_result + | Origination : { + origination : Alpha_context.origination; + preorigination : Contract.t; + } + -> Kind.origination internal_operation_contents_result + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation internal_operation_contents_result + | Tx_rollup_commit : + Alpha_context.manager_tx_rollup_commit + -> Kind.tx_rollup_commit internal_operation_contents_result + +type 'kind internal_operation_result = { + source : Contract.contract; + operation : 'kind internal_operation_contents_result; + nonce : int; +} + +type packed_internal_operation_result = + | Internal_operation_result : + 'kind internal_operation_result + -> packed_internal_operation_result + +let result_of_internal_operation (type kind) + ({source; operation; nonce} : kind Script_typed_ir.internal_operation) : + kind internal_operation_result = + let operation : kind internal_operation_contents_result = + match operation with + | Script_typed_ir.Transaction {transaction; _} -> Transaction transaction + | Script_typed_ir.Origination {origination; preorigination; _} -> + Origination {origination; preorigination} + | Script_typed_ir.Delegation delegate -> Delegation delegate + | Script_typed_ir.Tx_rollup_commit tx_rollup_commit -> + Tx_rollup_commit tx_rollup_commit + in + {source; operation; nonce} + +let results_of_internal_operations l = + let f (Script_typed_ir.Internal_operation internal_op) = + Internal_operation_result (result_of_internal_operation internal_op) + in + List.map f l + type successful_transaction_result = | Transaction_to_contract_result of { storage : Script.expr option; @@ -157,10 +204,16 @@ type 'kind manager_operation_result = | Skipped : 'kind Kind.manager -> 'kind manager_operation_result [@@coq_force_gadt] -type packed_internal_operation_result = - | Internal_operation_result : - 'kind internal_operation * 'kind manager_operation_result - -> packed_internal_operation_result +type packed_operation_result = + | Operation_result : + 'kind internal_operation_result * 'kind manager_operation_result + -> packed_operation_result + +let pack_operation_result (type kind) + (internal_op : kind Script_typed_ir.internal_operation) + (manager_op : kind manager_operation_result) = + let internal_op = result_of_internal_operation internal_op in + Operation_result (internal_op, manager_op) module Manager_result = struct type 'kind case = @@ -169,8 +222,9 @@ module Manager_result = struct encoding : 'a Data_encoding.t; kind : 'kind Kind.manager; iselect : - packed_internal_operation_result -> - ('kind internal_operation * 'kind manager_operation_result) option; + packed_operation_result -> + ('kind internal_operation_result * 'kind manager_operation_result) + option; select : packed_successful_manager_operation_result -> 'kind successful_manager_operation_result option; @@ -241,10 +295,7 @@ module Manager_result = struct obj2 (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) - ~iselect:(function - | Internal_operation_result (({operation = Reveal _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Reveal_result _ as op) -> Some op | _ -> None) @@ -322,8 +373,7 @@ module Manager_result = struct ~op_case:Operation.Encoding.Manager_operations.transaction_case ~encoding:transaction_to_contract_case ~iselect:(function - | Internal_operation_result (({operation = Transaction _; _} as op), res) - -> + | Operation_result (({operation = Transaction _; _} as op), res) -> Some (op, res) | _ -> None) ~select:(function @@ -346,8 +396,7 @@ module Manager_result = struct (dft "paid_storage_size_diff" z Z.zero) (opt "lazy_storage_diff" Lazy_storage.encoding)) ~iselect:(function - | Internal_operation_result (({operation = Origination _; _} as op), res) - -> + | Operation_result (({operation = Origination _; _} as op), res) -> Some (op, res) | _ -> None) ~select:(function @@ -401,11 +450,7 @@ module Manager_result = struct (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) (dft "storage_size" z Z.zero) (req "global_address" Script_expr_hash.encoding)) - ~iselect:(function - | Internal_operation_result - (({operation = Register_global_constant _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Register_global_constant_result _ as op) -> Some op @@ -443,8 +488,7 @@ module Manager_result = struct (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) ~iselect:(function - | Internal_operation_result (({operation = Delegation _; _} as op), res) - -> + | Operation_result (({operation = Delegation _; _} as op), res) -> Some (op, res) | _ -> None) ~select:(function @@ -466,11 +510,7 @@ module Manager_result = struct obj2 (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) - ~iselect:(function - | Internal_operation_result - (({operation = Set_deposits_limit _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Set_deposits_limit_result _ as op) -> Some op @@ -493,11 +533,7 @@ module Manager_result = struct (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) (req "originated_rollup" Tx_rollup.encoding)) - ~iselect:(function - | Internal_operation_result - (({operation = Tx_rollup_origination; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Tx_rollup_origination_result _ as op) -> Some op @@ -532,11 +568,7 @@ module Manager_result = struct (req "balance_updates" Receipt.balance_updates_encoding) (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) - ~iselect:(function - | Internal_operation_result - (({operation = Tx_rollup_submit_batch _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Tx_rollup_submit_batch_result _ as op) -> Some op @@ -560,8 +592,7 @@ module Manager_result = struct (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) ~iselect:(function - | Internal_operation_result - (({operation = Tx_rollup_commit _; _} as op), res) -> + | Operation_result (({operation = Tx_rollup_commit _; _} as op), res) -> Some (op, res) | _ -> None) ~select:(function @@ -586,11 +617,7 @@ module Manager_result = struct (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) (req "size" z)) - ~iselect:(function - | Internal_operation_result - (({operation = Sc_rollup_originate _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Sc_rollup_originate_result _ as op) -> Some op @@ -618,11 +645,7 @@ module Manager_result = struct (req "consumed_gas" Gas.Arith.n_integral_encoding) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) (req "inbox_after" Sc_rollup.Inbox.encoding)) - ~iselect:(function - | Internal_operation_result - (({operation = Sc_rollup_add_messages _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Sc_rollup_add_messages_result _ as op) -> Some op @@ -637,10 +660,153 @@ module Manager_result = struct {consumed_gas = consumed_milligas; inbox_after}) end +module Internal_result = struct + open Data_encoding + + type packed_internal_operation_contents_result = + | Piocr : + 'kind internal_operation_contents_result + -> packed_internal_operation_contents_result + + type 'kind case = + | MCase : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : + packed_internal_operation_contents_result -> + 'kind internal_operation_contents_result option; + proj : 'kind internal_operation_contents_result -> 'a; + inj : 'a -> 'kind internal_operation_contents_result; + } + -> 'kind case + [@@coq_force_gadt] + + let[@coq_axiom_with_reason "gadt"] transaction_case = + MCase + { + tag = Operation.Encoding.transaction_tag; + 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))); + select = (function Piocr (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 + { + tag = Operation.Encoding.origination_tag; + name = "origination"; + encoding = + obj4 + (req "balance" Tez.encoding) + (opt "delegate" Signature.Public_key_hash.encoding) + (req "script" Script.encoding) + (req "preorigination" Contract.encoding); + select = (function Piocr (Origination _ as op) -> Some op | _ -> None); + proj = + (function + | Origination + {origination = {credit; delegate; script}; preorigination} -> + (credit, delegate, script, preorigination)); + inj = + (fun (credit, delegate, script, preorigination) -> + Origination + {origination = {credit; delegate; script}; preorigination}); + } + + let[@coq_axiom_with_reason "gadt"] delegation_case = + MCase + { + tag = Operation.Encoding.delegation_tag; + name = "delegation"; + encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding); + select = (function Piocr (Delegation _ as op) -> Some op | _ -> None); + proj = (function Delegation key -> key); + inj = (fun key -> Delegation key); + } + + let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + MCase + { + tag = 3; + name = "tx_rollup_commit"; + encoding = + obj2 + (req "tx_rollup" Tx_rollup.encoding) + (req "commitment" Tx_rollup_commitments.Commitment.encoding); + select = + (function Piocr (Tx_rollup_commit _ as op) -> Some op | _ -> None); + proj = + (function + | Tx_rollup_commit {tx_rollup; commitment} -> (tx_rollup, commitment)); + inj = + (fun (tx_rollup, commitment) -> + Tx_rollup_commit {tx_rollup; commitment}); + } +end + let internal_operation_result_encoding : packed_internal_operation_result Data_encoding.t = let make (type kind) - (Manager_result.MCase res_case : kind Manager_result.case) = + (Internal_result.MCase ires_case : kind Internal_result.case) = + case + (Tag ires_case.tag) + ~title:ires_case.name + (merge_objs + (obj3 + (req "kind" (constant ires_case.name)) + (req "source" Contract.encoding) + (req "nonce" uint16)) + ires_case.encoding) + (fun (Internal_operation_result op) -> + match ires_case.select (Piocr op.operation) with + | Some op_contents -> + Some (((), op.source, op.nonce), ires_case.proj op_contents) + | None -> None) + (fun (((), source, nonce), op) -> + let op = {source; operation = ires_case.inj op; nonce} in + Internal_operation_result op) + in + def "apply_results.alpha.internal_operation_result" + @@ union + [ + make Internal_result.transaction_case; + make Internal_result.origination_case; + make Internal_result.delegation_case; + make Internal_result.tx_rollup_commit_case; + ] + +let operation_result_encoding : packed_operation_result Data_encoding.t = + let make (type kind) + (Manager_result.MCase res_case : kind Manager_result.case) + (Internal_result.MCase ires_case : kind Internal_result.case) = let (Operation.Encoding.Manager_operations.MCase op_case) = res_case.op_case in @@ -652,29 +818,25 @@ let internal_operation_result_encoding : (req "kind" (constant op_case.name)) (req "source" Contract.encoding) (req "nonce" uint16)) - (merge_objs op_case.encoding (obj1 (req "result" res_case.t)))) + (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) (fun op -> match res_case.iselect op with | Some (op, res) -> - Some (((), op.source, op.nonce), (op_case.proj op.operation, res)) + Some (((), op.source, op.nonce), (ires_case.proj op.operation, res)) | None -> None) (fun (((), source, nonce), (op, res)) -> - let op = {source; operation = op_case.inj op; nonce} in - Internal_operation_result (op, res)) + let op = {source; operation = ires_case.inj op; nonce} in + Operation_result (op, res)) in - def "operation.alpha.internal_operation_result" + def "apply_results.alpha.operation_result" @@ union [ - make Manager_result.reveal_case; - make Manager_result.transaction_case; - make Manager_result.origination_case; - make Manager_result.delegation_case; - make Manager_result.register_global_constant_case; - make Manager_result.set_deposits_limit_case; - make Manager_result.tx_rollup_origination_case; - make Manager_result.tx_rollup_submit_batch_case; - make Manager_result.sc_rollup_originate_case; - make Manager_result.sc_rollup_add_messages_case; + make Manager_result.transaction_case Internal_result.transaction_case; + make Manager_result.origination_case Internal_result.origination_case; + make Manager_result.delegation_case Internal_result.delegation_case; + make + Manager_result.tx_rollup_commit_case + Internal_result.tx_rollup_commit_case; ] let successful_manager_operation_result_encoding : @@ -738,7 +900,7 @@ type 'kind contents_result = | Manager_operation_result : { balance_updates : Receipt.balance_updates; operation_result : 'kind manager_operation_result; - internal_operation_results : packed_internal_operation_result list; + internal_operation_results : packed_operation_result list; } -> 'kind Kind.manager contents_result @@ -1011,7 +1173,7 @@ module Encoding = struct (req "operation_result" res_case.t) (dft "internal_operation_results" - (list internal_operation_result_encoding) + (list operation_result_encoding) []); select = (function diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index 7fcdc6979d045abe94cd51d1709fcef7e2e00bf3..af31a30012649452eb189fb9d5ee357ecc9a53fa 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -33,6 +33,37 @@ open Alpha_context +type 'kind internal_operation_contents_result = + | Transaction : + Alpha_context.transaction + -> Kind.transaction internal_operation_contents_result + | Origination : { + origination : Alpha_context.origination; + preorigination : Contract.t; + } + -> Kind.origination internal_operation_contents_result + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation internal_operation_contents_result + | Tx_rollup_commit : + Alpha_context.manager_tx_rollup_commit + -> Kind.tx_rollup_commit internal_operation_contents_result + +type 'kind internal_operation_result = { + source : Contract.contract; + operation : 'kind internal_operation_contents_result; + nonce : int; +} + +type packed_internal_operation_result = + | Internal_operation_result : + 'kind internal_operation_result + -> packed_internal_operation_result + +val results_of_internal_operations : + Script_typed_ir.packed_internal_operation list -> + packed_internal_operation_result list + (** Result of applying a {!Operation.t}. Follows the same structure. *) type 'kind operation_metadata = {contents : 'kind contents_result_list} @@ -87,7 +118,7 @@ and 'kind contents_result = | Manager_operation_result : { balance_updates : Receipt.balance_updates; operation_result : 'kind manager_operation_result; - internal_operation_results : packed_internal_operation_result list; + internal_operation_results : packed_operation_result list; } -> 'kind Kind.manager contents_result @@ -197,10 +228,23 @@ and packed_successful_manager_operation_result = 'kind successful_manager_operation_result -> packed_successful_manager_operation_result -and packed_internal_operation_result = - | Internal_operation_result : - 'kind internal_operation * 'kind manager_operation_result - -> packed_internal_operation_result +and packed_operation_result = + | Operation_result : + 'kind internal_operation_result * 'kind manager_operation_result + -> packed_operation_result + +val result_of_internal_operation : + 'kind Script_typed_ir.internal_operation -> 'kind internal_operation_result + +val pack_operation_result : + 'kind Script_typed_ir.internal_operation -> + 'kind manager_operation_result -> + packed_operation_result + +val operation_result_encoding : packed_operation_result Data_encoding.t + +val internal_operation_result_encoding : + packed_internal_operation_result Data_encoding.t val pack_migration_operation_results : Migration.origination_result list -> diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 2cb975ed4e87f6418ff06397fdbf258bfb3a18ae..7d5cd4b2cde6196d6bbb45761cc69d446b533047 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -377,7 +377,7 @@ let[@coq_axiom_with_reason "gadt"] register () = entrypoint >>? fun (r, ctxt) -> r |> function - | Ok (_f, Ex_ty ty) -> + | Ok (Ex_ty_cstr (ty, _)) -> unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _) -> Some (Micheline.strip_locations ty_node) | Error _ -> Result.return_none )) ; diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 98705d3724231e36e9b311c70816f3f296181a1f..fe2a125a532f2a15df43f8d21879d664722f16a1 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -176,6 +176,24 @@ type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} let raw_encoding = Operation.encoding +type transaction = { + amount : Tez_repr.tez; + parameters : Script_repr.lazy_expr; + entrypoint : Entrypoint_repr.t; + destination : Destination_repr.t; +} + +type origination = { + delegate : Signature.Public_key_hash.t option; + script : Script_repr.t; + credit : Tez_repr.tez; +} + +type manager_tx_rollup_commit = { + tx_rollup : Tx_rollup_repr.t; + commitment : Tx_rollup_commitments_repr.Commitment.t; +} + type 'kind operation = { shell : Operation.shell_header; protocol_data : 'kind protocol_data; @@ -246,20 +264,8 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation - | Transaction : { - amount : Tez_repr.tez; - parameters : Script_repr.lazy_expr; - entrypoint : Entrypoint_repr.t; - destination : Destination_repr.t; - } - -> Kind.transaction manager_operation - | Origination : { - delegate : Signature.Public_key_hash.t option; - script : Script_repr.t; - credit : Tez_repr.tez; - preorigination : Contract_repr.t option; - } - -> Kind.origination manager_operation + | Transaction : transaction -> Kind.transaction manager_operation + | Origination : origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation @@ -277,10 +283,8 @@ and _ manager_operation = burn_limit : Tez_repr.t option; } -> Kind.tx_rollup_submit_batch manager_operation - | Tx_rollup_commit : { - tx_rollup : Tx_rollup_repr.t; - commitment : Tx_rollup_commitments_repr.Commitment.t; - } + | Tx_rollup_commit : + manager_tx_rollup_commit -> Kind.tx_rollup_commit manager_operation | Sc_rollup_originate : { kind : Sc_rollup_repr.Kind.t; @@ -309,12 +313,6 @@ let manager_kind : type kind. kind manager_operation -> kind Kind.manager = | Sc_rollup_originate _ -> Kind.Sc_rollup_originate_manager_kind | Sc_rollup_add_messages _ -> Kind.Sc_rollup_add_messages_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 @@ -334,9 +332,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 @@ -467,21 +462,11 @@ module Encoding = struct (function Manager (Origination _ as op) -> Some op | _ -> None); proj = (function - | Origination - { - credit; - delegate; - script; - preorigination = - _ - (* the hash is only used internally - when originating from smart - contracts, don't serialize it *); - } -> + | Origination {credit; delegate; script} -> (credit, delegate, script)); inj = (fun (credit, delegate, script) -> - Origination {credit; delegate; script; preorigination = None}); + Origination {credit; delegate; script}); } let[@coq_axiom_with_reason "gadt"] delegation_case = @@ -615,32 +600,6 @@ module Encoding = struct (fun (rollup, messages) -> Sc_rollup_add_messages {rollup; messages}); } - - 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 sc_rollup_originate_case; - make sc_rollup_add_messages_case; - ] end type 'b case = @@ -922,13 +881,20 @@ module Encoding = struct let reveal_case = make_manager_case 107 Manager_operations.reveal_case + let transaction_tag = 108 + let transaction_case = - make_manager_case 108 Manager_operations.transaction_case + make_manager_case transaction_tag Manager_operations.transaction_case + + let origination_tag = 109 let origination_case = - make_manager_case 109 Manager_operations.origination_case + make_manager_case origination_tag Manager_operations.origination_case + + let delegation_tag = 110 - let delegation_case = make_manager_case 110 Manager_operations.delegation_case + let delegation_case = + make_manager_case delegation_tag Manager_operations.delegation_case let register_global_constant_case = make_manager_case 111 Manager_operations.register_global_constant_case @@ -1027,17 +993,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 @@ -1050,8 +1005,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 @@ -1257,70 +1210,3 @@ let equal : type a b. a operation -> b operation -> (a, b) eq option = equal_contents_kind_list op1.protocol_data.contents op2.protocol_data.contents - -open Cache_memory_helpers - -let script_lazy_expr_size (expr : Script_repr.lazy_expr) = - let fun_value expr = ret_adding (expr_size expr) word_size in - let fun_bytes bytes = (Nodes.zero, word_size +! bytes_size bytes) in - let fun_combine expr_size bytes_size = expr_size ++ bytes_size in - ret_adding - (Data_encoding.apply_lazy ~fun_value ~fun_bytes ~fun_combine expr) - header_size - -let script_repr_size ({code; storage} : Script_repr.t) = - ret_adding (script_lazy_expr_size code ++ script_lazy_expr_size storage) h2w - -let internal_manager_operation_size (type a) (op : a manager_operation) = - match op with - | Transaction {amount = _; parameters; entrypoint; destination} -> - ret_adding - (script_lazy_expr_size parameters) - (h4w +! int64_size - +! Entrypoint_repr.in_memory_size entrypoint - +! Destination_repr.in_memory_size destination) - | Origination {delegate; script; credit = _; preorigination} -> - ret_adding - (script_repr_size script) - (h4w - +! option_size - (fun _ -> Contract_repr.public_key_hash_in_memory_size) - delegate - +! int64_size - +! option_size Contract_repr.in_memory_size preorigination) - | Delegation pkh_opt -> - ( Nodes.zero, - h1w - +! option_size - (fun _ -> Contract_repr.public_key_hash_in_memory_size) - pkh_opt ) - | Sc_rollup_originate _ -> (Nodes.zero, h2w) - | Sc_rollup_add_messages _ -> (Nodes.zero, h2w) - | Reveal _ -> - (* Reveals can't occur as internal operations *) - assert false - | Register_global_constant _ -> - (* Global constant registrations can't occur as internal operations *) - assert false - | Set_deposits_limit _ -> - (* Set_deposits_limit can't occur as internal operations *) - assert false - | Tx_rollup_origination -> - (* Tx_rollup_origination operation can’t occur as internal operations *) - assert false - | Tx_rollup_submit_batch _ -> - (* Tx_rollup_submit_batch operation can’t occur as internal operations *) - assert false - | Tx_rollup_commit _ -> - (* Tx_rollup_commit operation can’t occur as internal operations *) - assert false - -let packed_internal_operation_in_memory_size : - packed_internal_operation -> nodes_and_size = function - | Internal_operation iop -> - let {source; operation; nonce = _} = iop in - let source_size = Contract_repr.in_memory_size source in - let nonce_size = word_size in - ret_adding - (internal_manager_operation_size operation) - (h2w +! source_size +! nonce_size) diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 506229d3506558f140f1f2ac81cf21b7fc50ec74..57b6350c7a28e923f19d0536c6af1e6db9794688 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -155,6 +155,24 @@ type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} val raw_encoding : raw Data_encoding.t +type transaction = { + amount : Tez_repr.tez; + parameters : Script_repr.lazy_expr; + entrypoint : Entrypoint_repr.t; + destination : Destination_repr.t; +} + +type origination = { + delegate : Signature.Public_key_hash.t option; + script : Script_repr.t; + credit : Tez_repr.tez; +} + +type manager_tx_rollup_commit = { + tx_rollup : Tx_rollup_repr.t; + commitment : Tx_rollup_commitments_repr.Commitment.t; +} + type 'kind operation = { shell : Operation.shell_header; protocol_data : 'kind protocol_data; @@ -225,20 +243,8 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation - | Transaction : { - amount : Tez_repr.tez; - parameters : Script_repr.lazy_expr; - entrypoint : Entrypoint_repr.t; - destination : Destination_repr.t; - } - -> Kind.transaction manager_operation - | Origination : { - delegate : Signature.Public_key_hash.t option; - script : Script_repr.t; - credit : Tez_repr.tez; - preorigination : Contract_repr.t option; - } - -> Kind.origination manager_operation + | Transaction : transaction -> Kind.transaction manager_operation + | Origination : origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation @@ -256,10 +262,8 @@ and _ manager_operation = burn_limit : Tez_repr.t option; } -> Kind.tx_rollup_submit_batch manager_operation - | Tx_rollup_commit : { - tx_rollup : Tx_rollup_repr.t; - commitment : Tx_rollup_commitments_repr.Commitment.t; - } + | Tx_rollup_commit : + manager_tx_rollup_commit -> Kind.tx_rollup_commit manager_operation | Sc_rollup_originate : { kind : Sc_rollup_repr.Kind.t; @@ -274,12 +278,6 @@ and _ manager_operation = 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 @@ -302,9 +300,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 @@ -335,15 +330,10 @@ 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 -val packed_internal_operation_in_memory_size : - packed_internal_operation -> Cache_memory_helpers.nodes_and_size - module Encoding : sig type 'b case = | Case : { @@ -379,10 +369,16 @@ module Encoding : sig val reveal_case : Kind.reveal Kind.manager case + val transaction_tag : int + val transaction_case : Kind.transaction Kind.manager case + val origination_tag : int + val origination_case : Kind.origination Kind.manager case + val delegation_tag : int + val delegation_case : Kind.delegation Kind.manager case val register_global_constant_case : diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index f6831ed5e160c09f1eb027bf0221dbd99b9034c6..cc880affa35e13c3dc1b0ffcc6b18574972881cd 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1127,7 +1127,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = { storage_type; arg_type; - lambda = Lam (_, code); + lambda = Lam (_, code) as lambda; views; entrypoints; k; @@ -1141,6 +1141,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = gas storage_type arg_type + lambda code views entrypoints @@ -1671,6 +1672,10 @@ let internal_step ctxt step_constants gas kinstr accu stack = let step logger ctxt step_constants descr stack = step_descr ~log_now:false logger (ctxt, step_constants) descr stack +type execution_arg = + | Typed_arg : 'a Script_typed_ir.ty * 'a -> execution_arg + | Untyped_arg : Script.expr -> execution_arg + (* High-level functions @@ -1711,10 +1716,24 @@ let execute logger ctxt mode step_constants ~entrypoint ~internal (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint) >>?= fun (r, ctxt) -> record_trace (Bad_contract_parameter step_constants.self) r - >>?= fun (box, _) -> - trace - (Bad_contract_parameter step_constants.self) - (parse_data ctxt ~legacy:false ~allow_forged:internal arg_type (box arg)) + >>?= fun (Ex_ty_cstr (entrypoint_ty, box)) -> + (match arg with + | Untyped_arg arg -> + let arg = Micheline.root arg in + trace + (Bad_contract_parameter step_constants.self) + (parse_data ctxt ~legacy:false ~allow_forged:internal entrypoint_ty arg) + >>=? fun (parsed_arg, ctxt) -> return (box parsed_arg, ctxt) + | Typed_arg (parsed_arg_ty, parsed_arg) -> + Gas_monad.run + ctxt + (Script_ir_translator.ty_eq + ~error_details:Informative + Micheline.dummy_location + entrypoint_ty + parsed_arg_ty) + >>?= fun (res, ctxt) -> + res >>?= fun Eq -> return (box parsed_arg, ctxt)) >>=? fun (arg, ctxt) -> Script_ir_translator.collect_lazy_storage ctxt arg_type arg >>?= fun (to_duplicate, ctxt) -> @@ -1787,7 +1806,7 @@ let execute ?logger ctxt ~cached_script mode step_constants ~script ~entrypoint ~internal script cached_script - (Micheline.root parameter) + parameter >|=? fun (storage, operations, ctxt, lazy_storage_diff, ex_script, approx_size) -> ({ctxt; storage; lazy_storage_diff; operations}, (ex_script, approx_size)) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli index 7b003e1f42ccc4bcf55c52c6d3934fc962eb0486..9d96c8c5fb003e5afd4c1cb888b030cb48d28a98 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/script_interpreter.mli @@ -77,6 +77,10 @@ val step : 's -> ('r * 'f * context) tzresult Lwt.t +type execution_arg = + | Typed_arg : 'a Script_typed_ir.ty * 'a -> execution_arg + | Untyped_arg : Script.expr -> execution_arg + (** [execute ?logger ctxt ~cached_script mode step_constant ~script ~entrypoint ~parameter ~internal] interprets the [script]'s [entrypoint] for a given [parameter]. @@ -106,7 +110,7 @@ val execute : step_constants -> script:Script.t -> entrypoint:Entrypoint.t -> - parameter:Script.expr -> + parameter:execution_arg -> internal:bool -> (execution_result * (Script_ir_translator.ex_script * int)) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index d6b0b1a3d2d460f543717b5c09731b6d91bde584..3de40740560a770c2d32b8941d4de4bafdaf49e2 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -511,17 +511,19 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = ~to_update ~temporary:true >>=? fun (p, lazy_storage_diff, ctxt) -> + let parameters_ty = tp in + let parameters = p in unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> Gas.consume ctxt (Script.strip_locations_cost p) >>?= fun ctxt -> - let operation = - Transaction - { - amount; - destination; - entrypoint; - parameters = Script.lazy_expr (Micheline.strip_locations p); - } + let transaction = + { + amount; + destination; + entrypoint; + parameters = Script.lazy_expr (Micheline.strip_locations p); + } in + let operation = Transaction {transaction; parameters_ty; parameters} in fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let iop = {source = sc.self; operation; nonce} in let res = {piop = Internal_operation iop; lazy_storage_diff} in @@ -537,7 +539,7 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = (* TODO: https://gitlab.com/tezos/tezos/-/issues/1688 Refactor the sharing part of unparse_script and create_contract *) -let create_contract (ctxt, sc) gas storage_type param_type code views +let create_contract (ctxt, sc) gas storage_type param_type lambda code views entrypoints delegate credit init = let ctxt = update_context gas ctxt in let loc = Micheline.dummy_location in @@ -558,7 +560,7 @@ let create_contract (ctxt, sc) gas storage_type param_type code views [] ) :: views in - let views = SMap.fold view views [] |> List.rev in + let view_list = SMap.fold view views [] |> List.rev in let code = strip_locations (Seq @@ -568,7 +570,7 @@ let create_contract (ctxt, sc) gas storage_type param_type code views Prim (loc, K_storage, [unparsed_storage_type], []); Prim (loc, K_code, [code], []); ] - @ views )) + @ view_list )) in collect_lazy_storage ctxt storage_type init >>?= fun (to_duplicate, ctxt) -> let to_update = no_lazy_storage_id in @@ -585,15 +587,28 @@ let create_contract (ctxt, sc) gas storage_type param_type code views Gas.consume ctxt (Script.strip_locations_cost storage) >>?= fun ctxt -> let storage = strip_locations storage in Contract.fresh_contract_from_current_nonce ctxt >>?= fun (ctxt, contract) -> + let origination = + { + credit; + delegate; + script = + {code = Script.lazy_expr code; storage = Script.lazy_expr storage}; + } + in + Script_ir_translator.code_size ctxt lambda views >>?= fun (ctxt, code_size) -> + let parsed_script = + { + code = lambda; + arg_type = param_type; + storage = init; + storage_type; + views; + entrypoints; + code_size; + } + in let operation = - Origination - { - credit; - delegate; - preorigination = Some contract; - script = - {code = Script.lazy_expr code; storage = Script.lazy_expr storage}; - } + Origination {origination; preorigination = contract; parsed_script} in fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let piop = Internal_operation {source = sc.self; operation; nonce} in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a2269dd33e4647e624863249c378808fef363f7b..0cbbdcc48c6918a810d20d21644e99e908252d9a 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -480,9 +480,8 @@ let unparse_key_hash ~loc ctxt mode k = (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} = - let bytes = - Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding piop - in + let (Internal_operation iop) = piop in + let bytes = Bytes.of_string @@ string_of_int iop.nonce in Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt -> (Bytes (loc, bytes), ctxt) @@ -1825,36 +1824,36 @@ type 'before dup_n_proof_argument = ('before, 'a) dup_n_gadt_witness * 'a ty -> 'before dup_n_proof_argument +type 'a ex_ty_cstr = Ex_ty_cstr : 'b ty * ('b -> 'a) -> 'a ex_ty_cstr + let find_entrypoint (type full error_trace) ~(error_details : error_trace error_details) (full : full ty) (entrypoints : full entrypoints) entrypoint : - ((Script.node -> Script.node) * ex_ty, error_trace) Gas_monad.t = + (full ex_ty_cstr, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let loc = Micheline.dummy_location in let rec find_entrypoint : type t. - t ty -> - t entrypoints -> - Entrypoint.t -> - ((Script.node -> Script.node) * ex_ty, unit) Gas_monad.t = + t ty -> t entrypoints -> Entrypoint.t -> (t ex_ty_cstr, unit) Gas_monad.t + = fun ty entrypoints entrypoint -> let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in match (ty, entrypoints) with | (_, {name = Some name; _}) when Entrypoint.(name = entrypoint) -> - return ((fun e -> e), Ex_ty ty) + return (Ex_ty_cstr (ty, fun e -> e)) | (Union_t (tl, tr, _), {nested = Entrypoints_Union {left; right}; _}) -> ( Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function - | Ok (f, t) -> return ((fun e -> Prim (loc, D_Left, [f e], [])), t) + | Ok (Ex_ty_cstr (t, f')) -> return (Ex_ty_cstr (t, fun e -> L (f' e))) | Error () -> - let+ (f, t) = find_entrypoint tr right entrypoint in - ((fun e -> Prim (loc, D_Right, [f e], [])), t)) + let+ (Ex_ty_cstr (t, f')) = find_entrypoint tr right entrypoint in + Ex_ty_cstr (t, fun e -> R (f' e))) | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) in Gas_monad.bind_recover (find_entrypoint full entrypoints entrypoint) @@ function | Ok f_t -> return f_t | Error () -> - if Entrypoint.is_default entrypoint then return ((fun e -> e), Ex_ty full) + if Entrypoint.is_default entrypoint then + return (Ex_ty_cstr (full, fun e -> e)) else Gas_monad.of_result @@ Error @@ -1868,7 +1867,7 @@ let find_entrypoint_for_type (type full exp error_trace) ~error_details let open Gas_monad.Syntax in let* res = find_entrypoint ~error_details full entrypoints entrypoint in match res with - | (_, Ex_ty ty) -> ( + | Ex_ty_cstr (ty, _) -> ( match entrypoints.name with | Some e when Entrypoint.is_root e && Entrypoint.is_default entrypoint -> Gas_monad.bind_recover @@ -4608,7 +4607,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : entrypoints entrypoint >>? fun (r, ctxt) -> - r >>? fun (_, Ex_ty param_type) -> + r >>? fun (Ex_ty_cstr (param_type, _)) -> contract_t loc param_type >>? fun res_ty -> let instr = { @@ -5259,6 +5258,24 @@ let parse_contract_for_script : (ctxt, Some contract) | Error Inconsistent_types_fast -> (ctxt, None))) ))) +let code_size ctxt code views = + let open Script_typed_ir_size in + let view_size view = + node_size view.view_code ++ node_size view.input_ty + ++ node_size view.output_ty + in + let views_size = SMap.fold (fun _ v s -> view_size v ++ s) views zero in + (* The size of the storage_type and the arg_type is counted by + [lambda_size]. *) + let ir_size = lambda_size code in + let (nodes, code_size) = views_size ++ ir_size in + (* We consume gas after the fact in order to not have to instrument + [node_size] (for efficiency). + This is safe, as we already pay gas proportional to [views_size] and + [ir_size] during their typechecking. *) + Gas.consume ctxt (Script_typed_ir_size_costs.nodes_cost ~nodes) + >>? fun ctxt -> ok (ctxt, code_size) + let parse_code : ?type_logger:type_logger -> context -> @@ -5300,25 +5317,10 @@ let parse_code : code_field) >>=? fun (code, ctxt) -> Lwt.return - (let open Script_typed_ir_size in - let view_size view = - node_size view.view_code ++ node_size view.input_ty - ++ node_size view.output_ty - in - let views_size = SMap.fold (fun _ v s -> view_size v ++ s) views zero in - (* The size of the storage_type and the arg_type is counted by - [lambda_size]. *) - let ir_size = lambda_size code in - let (nodes, code_size) = views_size ++ ir_size in - (* We consume gas after the fact in order to not have to instrument - [node_size] (for efficiency). - This is safe, as we already pay gas proportional to [views_size] - and [ir_size] during their typechecking. *) - Gas.consume ctxt (Script_typed_ir_size_costs.nodes_cost ~nodes) - >>? fun ctxt -> - ok - ( Ex_code {code; arg_type; storage_type; views; entrypoints; code_size}, - ctxt )) + ( code_size ctxt code views >>? fun (ctxt, code_size) -> + ok + ( Ex_code {code; arg_type; storage_type; views; entrypoints; code_size}, + ctxt ) ) let parse_storage : ?type_logger:type_logger -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index c32b8b0e48b361fa65ef4406b013036983190155..4c7f3b7ff6fcce40e96ea12bc10bc145aada75d4 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -411,12 +411,18 @@ val parse_contract_for_script : entrypoint:Entrypoint.t -> (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t +(** ['a ex_ty_cstr] is like [ex_ty], but also adds to the existential a function + used to reconstruct a value of type ['a] from the internal type of the + existential (typically, that will be the type of en antry-point). *) +type 'a ex_ty_cstr = + | Ex_ty_cstr : 'b Script_typed_ir.ty * ('b -> 'a) -> 'a ex_ty_cstr + val find_entrypoint : error_details:'error_trace error_details -> 't Script_typed_ir.ty -> 't Script_typed_ir.entrypoints -> Entrypoint.t -> - ((Script.node -> Script.node) * ex_ty, 'error_trace) Gas_monad.t + ('t ex_ty_cstr, 'error_trace) Gas_monad.t val list_entrypoints : context -> @@ -489,6 +495,14 @@ val get_single_sapling_state : 'a -> (Sapling.Id.t option * context) tzresult +(** [code_size ctxt code views] returns an overapproximation of the size of + the in-memory representation of [code] and [views] in the context [ctxt]. *) +val code_size : + context -> + ('a, 'b) Script_typed_ir.lambda -> + Script_typed_ir.view Script_typed_ir.SMap.t -> + (context * Cache_memory_helpers.sint) tzresult + (** [script_size script] returns an overapproximation of the size of the in-memory representation of [script] as well as the cost associated to computing that overapproximation. *) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index a595f3f764a017df707790fb82a7364a5c9b0c14..d4bf4e0c1903b5a49ded16b7b477022f94803a3c 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -98,11 +98,6 @@ type ('a, 'b) pair = 'a * 'b type ('a, 'b) union = L of 'a | R of 'b -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] @@ -1406,6 +1401,50 @@ and ('a, 'b) view_signature = output_ty : 'b ty; } +and operation = { + piop : packed_internal_operation; + lazy_storage_diff : Lazy_storage.diffs option; +} + +and packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation + +and 'kind internal_operation = { + source : Contract.contract; + operation : 'kind manager_operation; + nonce : int; +} + +and 'kind manager_operation = + | Transaction : { + transaction : Alpha_context.transaction; + parameters_ty : 'arg ty; + parameters : 'arg; + } + -> Kind.transaction manager_operation + | Origination : { + origination : Alpha_context.origination; + preorigination : Contract.t; + parsed_script : ('arg, 'storage) script; + } + -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation + | Tx_rollup_commit : + Alpha_context.manager_tx_rollup_commit + -> Kind.tx_rollup_commit 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 + | Tx_rollup_commit _ -> Kind.Tx_rollup_commit_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 75fa5e457ddca566728b27acd425797da0789d0a..62b1cfe4b69c7d3e6c6657effaf01b116c9f7993 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -78,11 +78,6 @@ type ('a, 'b) pair = 'a * 'b type ('a, 'b) union = L of 'a | R of 'b -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]. *) @@ -1533,6 +1528,45 @@ and ('a, 'b) view_signature = output_ty : 'b ty; } +and operation = { + piop : packed_internal_operation; + lazy_storage_diff : Lazy_storage.diffs option; +} + +and packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation + +and 'kind internal_operation = { + source : Contract.contract; + operation : 'kind manager_operation; + nonce : int; +} + +and 'kind manager_operation = + | Transaction : { + transaction : Alpha_context.transaction; + parameters_ty : 'arg ty; + parameters : 'arg; + } + -> Kind.transaction manager_operation + | Origination : { + origination : Alpha_context.origination; + preorigination : Contract.t; + parsed_script : ('arg, 'storage) script; + } + -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation + | Tx_rollup_commit : + Alpha_context.manager_tx_rollup_commit + -> Kind.tx_rollup_commit manager_operation + +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation + +val manager_kind : 'kind manager_operation -> 'kind Kind.manager + val kinfo_of_kinstr : ('a, 's, 'b, 'f) kinstr -> ('a, 's) kinfo type kinstr_rewritek = { diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 4b83db4087292c36ed7378efa8a23c5de48ebd8e..4977575268235cf6b1f7468d6783523db3fcb02f 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -198,12 +198,6 @@ let sapling_state_size {Sapling.id; diff; memo_size = _} = +! Sapling.diff_in_memory_size diff +! sapling_memo_size_size -let operation_size {piop; lazy_storage_diff} = - ret_adding - (Operation.packed_internal_operation_in_memory_size piop - ++ option_size_vec Lazy_storage.diffs_in_memory_size lazy_storage_diff) - h2w - let chain_id_size = h1w +? Chain_id.size (* [contents] is handle by the recursion scheme in [value_size] *) @@ -313,7 +307,10 @@ let rec value_size : | Sapling_transaction_t _ -> ret_succ_adding accu (Sapling.transaction_in_memory_size x) | Sapling_state_t _ -> ret_succ_adding accu (sapling_state_size x) - | Operation_t -> ret_succ (accu ++ operation_size x) + (* Operations are neither storable nor pushable so they can appear neither + in the storage nor in the script. Hence they cannot appear in the cache + and we never need to measure their size. *) + | Operation_t -> assert false | Chain_id_t -> ret_succ_adding accu chain_id_size | Never_t -> ( match x with _ -> .) (* Related to https://gitlab.com/dannywillems/ocaml-bls12-381/-/issues/56. diff --git a/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml index 2570b95a18e5decabe6597818f83ebb08f68babe..8fa0c2592ab17519dff30dc7b606864a682ed647 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml @@ -97,6 +97,6 @@ let run_script ctx ?(step_constants = default_step_constants) contract ~script ~cached_script:None ~entrypoint - ~parameter:parameter_expr + ~parameter:(Untyped_arg parameter_expr) ~internal:false >>=?? fun res -> return res diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index d53c8a63ec7a981cf2ffa7c1dcbece6a02628a4e..e0e16d9446db8127e88e5fec8ac20255387fb41a 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -143,7 +143,7 @@ let detect_script_failure : in detect_script_failure operation_result >>? fun () -> List.iter_e - (fun (Internal_operation_result (_, r)) -> detect_script_failure r) + (fun (Operation_result (_, r)) -> detect_script_failure r) internal_operation_results in function diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index f9cee94d50f289d9cce8f6817f188fc5b3258bc5..7e3131a81e538bca66d729eea6ce312785d2f323 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -310,15 +310,15 @@ let originated_contract op = exception Impossible -let contract_origination ?counter ?delegate ~script ?(preorigination = None) - ?public_key ?credit ?fee ?gas_limit ?storage_limit ctxt source = +let contract_origination ?counter ?delegate ~script ?public_key ?credit ?fee + ?gas_limit ?storage_limit ctxt source = Context.Contract.manager ctxt source >>=? fun account -> let default_credit = Tez.of_mutez @@ Int64.of_int 1000001 in let default_credit = WithExceptions.Option.to_exn ~none:Impossible default_credit in let credit = Option.value ~default:default_credit credit in - let operation = Origination {delegate; script; credit; preorigination} in + let operation = Origination {delegate; script; credit} in manager_operation ?counter ?public_key diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.mli b/src/proto_alpha/lib_protocol/test/helpers/op.mli index f2781898e3bf4c00a1e0d75a3b0421378524f5a1..ccf86e2b973b2c6fcf97b2908de3683cfa916e18 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/op.mli @@ -99,7 +99,6 @@ val contract_origination : ?counter:Z.t -> ?delegate:public_key_hash -> script:Script.t -> - ?preorigination:Contract.contract option -> ?public_key:public_key -> ?credit:Tez.tez -> ?fee:Tez.tez -> 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 da849f548ff2577e04973712fea737631b6dd151..4a48d30ca93fb2b0325911da245d8e7e39fcea85 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 Error_monad_operators let wrap m = m >|= Environment.wrap_tzresult @@ -327,20 +328,28 @@ let originate_script block ~script ~storage ~src ~baker ~forges_tickets = in Incremental.finalize_block incr >|=? fun block -> (destination, script, block) -let origination_operation ~src ~script ~orig_contract = - Internal_operation - { - source = src; - operation = - Origination - { - delegate = None; - script; - credit = Tez.one; - preorigination = Some orig_contract; - }; - nonce = 1; - } +let origination_operation ~ctxt ~src ~script ~orig_contract = + Script_ir_translator.parse_script + ctxt + ~legacy:true + ~allow_forged_in_storage:true + script + >>=?? fun (Script_ir_translator.Ex_script parsed_script, ctxt) -> + let operation = + Script_typed_ir.Internal_operation + { + source = src; + operation = + Origination + { + origination = {delegate = None; script; credit = Tez.one}; + preorigination = orig_contract; + parsed_script; + }; + nonce = 1; + } + in + return (operation, ctxt) let originate block ~src ~baker ~script ~storage ~forges_tickets = let open Lwt_tzresult_syntax in @@ -363,17 +372,22 @@ let transfer_operation ctxt ~src ~destination ~arg_type ~arg = arg) in return - ( Internal_operation + ( Script_typed_ir.Internal_operation { source = src; operation = Transaction { - amount = Tez.zero; - parameters = - Script.lazy_expr @@ Micheline.strip_locations params_node; - entrypoint = Entrypoint.default; - destination = Destination.Contract destination; + transaction = + { + amount = Tez.zero; + parameters = + Script.lazy_expr @@ Micheline.strip_locations params_node; + entrypoint = Entrypoint.default; + destination = Destination.Contract destination; + }; + parameters_ty = arg_type; + parameters = arg; }; nonce = 1; }, @@ -1116,8 +1130,8 @@ let test_update_invalid_origination () = ~forges_tickets:true in let ctxt = Incremental.alpha_ctxt incr in - let operation = - origination_operation ~src ~orig_contract:destination ~script + let* (operation, ctxt) = + origination_operation ~ctxt ~src ~orig_contract:destination ~script in assert_fail_with ~loc:__LOC__ @@ -1156,8 +1170,8 @@ let test_update_valid_origination () = let* (_, ctxt) = wrap @@ Ticket_balance.adjust_balance ctxt red_self_token_hash ~delta:Z.one in - let operation = - origination_operation ~src:self ~orig_contract:originated ~script + let* (operation, ctxt) = + origination_operation ~ctxt ~src:self ~orig_contract:originated ~script in let* (_, ctxt) = let* (ticket_diffs, ctxt) = @@ -1202,8 +1216,8 @@ let test_update_self_origination () = wrap @@ Ticket_balance_key.ticket_balance_key ctxt ~owner:originated red_token in - let operation = - origination_operation ~src:self ~orig_contract:originated ~script + let* (operation, ctxt) = + origination_operation ~ctxt ~src:self ~orig_contract:originated ~script in let* (_, ctxt) = wrap 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 adadc5dea93cbc5e8570f129be938640fe6df170..50ed2c0b629a20bd5263b41122f26c77e3e111ec 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 @@ -33,7 +33,9 @@ *) open Protocol +open Script_typed_ir open Alpha_context +open Error_monad_operators (** A local non-private type that mirrors [Ticket_operations_diff.ticket_token_diff]. *) @@ -58,7 +60,7 @@ let big_map_updates_of_key_values ctxt key_values = wrap (Script_ir_translator.hash_comparable_data ctxt - Script_typed_ir.int_key + int_key (Script_int_repr.of_int key)) in return @@ -229,68 +231,33 @@ let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = let* incr = Incremental.begin_construction ~policy:Block.(By_account baker) block in + let ctxt = Incremental.alpha_ctxt incr in + Script_ir_translator.parse_script + ctxt + ~legacy:true + ~allow_forged_in_storage:true + script + >>=?? fun (Script_ir_translator.Ex_script parsed_script, ctxt) -> let operation = - Internal_operation + Script_typed_ir.Internal_operation { source = src; operation = Origination { - delegate = None; - script; - credit = Tez.one; - preorigination = Some orig_contract; + origination = {delegate = None; script; credit = Tez.one}; + preorigination = orig_contract; + parsed_script; }; nonce = 1; } in + let incr = Incremental.set_alpha_ctxt incr ctxt 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 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) = @@ -301,20 +268,39 @@ let originate block ~src ~baker ~script ~storage ~forges_tickets = in return (orig_contract, incr) -let transfer_operation ~src ~destination ~parameters = - Internal_operation - { - source = src; - operation = - Transaction - { - amount = Tez.zero; - parameters = Script.lazy_expr @@ Expr.from_string parameters; - entrypoint = Entrypoint.default; - destination = Destination.Contract destination; - }; - nonce = 1; - } +let transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters = + let open Lwt_tzresult_syntax in + let ctxt = Incremental.alpha_ctxt incr in + let* (params_node, ctxt) = + wrap + (Script_ir_translator.unparse_data + ctxt + Script_ir_translator.Readable + parameters_ty + parameters) + in + let incr = Incremental.set_alpha_ctxt incr ctxt in + return + ( Script_typed_ir.Internal_operation + { + source = src; + operation = + Transaction + { + transaction = + { + amount = Tez.zero; + parameters = + Script.lazy_expr @@ Micheline.strip_locations params_node; + entrypoint = Entrypoint.default; + destination = Destination.Contract destination; + }; + parameters_ty; + parameters; + }; + nonce = 1; + }, + incr ) let ticket_diffs_of_operations incr operations = wrap @@ -343,26 +329,24 @@ let ticket_big_map_script = code { CAR; NIL operation ; PAIR } } |} +let list_ticket_string_ty = + ticket_t Micheline.dummy_location string_key >>? fun ticket_ty -> + list_t Micheline.dummy_location ticket_ty + +let make_ticket (ticketer, contents, amount) = + Script_string.of_string contents >>?= fun contents -> + return {ticketer; contents; amount = nat amount} + +let make_tickets (l : (Contract.t * string * int) list) = + let* elements = List.map_es make_ticket l in + return {elements; length = List.length elements} + (** Test that no tickets are returned for operations that do not contain tickets. *) 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_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:[] @@ -378,8 +362,13 @@ let test_transfer_to_non_ticket_contract () = ~storage:"Unit" ~forges_tickets:false in - let operation = - transfer_operation ~src ~destination:orig_contract ~parameters:"Unit" + let* (operation, incr) = + transfer_operation + ~incr + ~src + ~destination:orig_contract + ~parameters_ty:unit_t + ~parameters:() in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] @@ -396,8 +385,15 @@ let test_transfer_empty_ticket_list () = ~storage:"{}" ~forges_tickets:false in - let operation = - transfer_operation ~src ~destination:orig_contract ~parameters:"{}" + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets [] >>=?? fun parameters -> + let* (operation, incr) = + transfer_operation + ~incr + ~src + ~destination:orig_contract + ~parameters_ty + ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] @@ -415,11 +411,15 @@ let test_transfer_one_ticket () = ~storage:"{}" ~forges_tickets:false in - let parameters = - Printf.sprintf {|{Pair %S "white" 1}|} (Contract.to_b58check ticketer) - in - let operation = - transfer_operation ~src ~destination:orig_contract ~parameters + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets [(ticketer, "white", 1)] >>=?? fun parameters -> + let* (operation, incr) = + transfer_operation + ~incr + ~src + ~destination:orig_contract + ~parameters_ty + ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs @@ -448,22 +448,22 @@ let test_transfer_multiple_tickets () = ~storage:"{}" ~forges_tickets:false in - let operation = - let parameters = - let ticketer_addr = Contract.to_b58check ticketer in - Printf.sprintf - {|{ - Pair %S "red" 1; - Pair %S "blue" 2 ; - Pair %S "green" 3; - Pair %S "red" 4;} - |} - ticketer_addr - ticketer_addr - ticketer_addr - ticketer_addr - in - transfer_operation ~src ~destination:orig_contract ~parameters + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets + [ + (ticketer, "red", 1); + (ticketer, "blue", 2); + (ticketer, "green", 3); + (ticketer, "red", 4); + ] + >>=?? fun parameters -> + let* (operation, incr) = + transfer_operation + ~incr + ~src + ~destination:orig_contract + ~parameters_ty + ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs @@ -493,31 +493,20 @@ let test_transfer_multiple_tickets () = let test_transfer_different_tickets () = let* (baker, src, block) = init () in let* (ticketer1, ticketer2) = two_ticketers block in - let parameters = - let ticketer1_addr = Contract.to_b58check ticketer1 in - let ticketer2_addr = Contract.to_b58check ticketer2 in - Printf.sprintf - {|{ - Pair %S "red" 1; - Pair %S "green" 1; - Pair %S "blue" 1; - Pair %S "red" 1; - Pair %S "green" 1; - Pair %S "blue" 1 ; - Pair %S "red" 1; - Pair %S "green" 1; - Pair %S "blue" 1; } - |} - ticketer1_addr - ticketer1_addr - ticketer1_addr - ticketer2_addr - ticketer2_addr - ticketer2_addr - ticketer1_addr - ticketer1_addr - ticketer1_addr - in + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets + [ + (ticketer1, "red", 1); + (ticketer1, "green", 1); + (ticketer1, "blue", 1); + (ticketer2, "red", 1); + (ticketer2, "green", 1); + (ticketer2, "blue", 1); + (ticketer1, "red", 1); + (ticketer1, "green", 1); + (ticketer1, "blue", 1); + ] + >>=?? fun parameters -> let* (destination, incr) = originate block @@ -527,7 +516,9 @@ let test_transfer_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let operation = transfer_operation ~src ~destination ~parameters in + let* (operation, incr) = + transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters + in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt @@ -571,14 +562,10 @@ let test_transfer_different_tickets () = let test_transfer_to_two_contracts_with_different_tickets () = let* (baker, src, block) = init () in let* ticketer = one_ticketer block in - let parameters = - let ticketer_addr = Contract.to_b58check ticketer in - Printf.sprintf - {|{Pair %S "red" 1; Pair %S "green" 1; Pair %S "blue" 1; }|} - ticketer_addr - ticketer_addr - ticketer_addr - in + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets + [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] + >>=?? fun parameters -> let* (destination1, incr) = originate block @@ -588,8 +575,13 @@ let test_transfer_to_two_contracts_with_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let operation1 = - transfer_operation ~src ~destination:destination1 ~parameters + let* (operation1, incr) = + transfer_operation + ~incr + ~src + ~destination:destination1 + ~parameters_ty + ~parameters in let* block = Incremental.finalize_block incr in let* (destination2, incr) = @@ -601,8 +593,13 @@ let test_transfer_to_two_contracts_with_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let operation2 = - transfer_operation ~src ~destination:destination2 ~parameters + let* (operation2, incr) = + transfer_operation + ~incr + ~src + ~destination:destination2 + ~parameters_ty + ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation1; operation2] @@ -907,15 +904,17 @@ let test_originate_and_transfer () = ~storage:"{}" ~forges_tickets:false in - let parameters = - Printf.sprintf - {|{Pair %S "red" 1; Pair %S "green" 1; Pair %S "blue" 1; }|} - ticketer_addr - ticketer_addr - ticketer_addr - in - let operation2 = - transfer_operation ~src ~destination:destination2 ~parameters + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets + [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] + >>=?? fun parameters -> + let* (operation2, incr) = + transfer_operation + ~incr + ~src + ~destination:destination2 + ~parameters_ty + ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation1; operation2] @@ -1032,13 +1031,23 @@ let test_transfer_big_map_with_tickets () = ~storage:"{}" ~forges_tickets:false in + ticket_t Micheline.dummy_location string_key >>??= fun value_type -> + big_map_t Micheline.dummy_location int_key value_type + >>??= fun parameters_ty -> let parameters = - Printf.sprintf "%d" @@ Z.to_int (Big_map.Id.unparse_to_z big_map_id) + { + id = Some big_map_id; + diff = {map = Big_map_overlay.empty; size = 0}; + key_type = int_key; + value_type; + } in - let operation = + let* (operation, incr) = transfer_operation + ~incr ~src:ticketer_contract ~destination:orig_contract + ~parameters_ty ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.mli b/src/proto_alpha/lib_protocol/ticket_accounting.mli index fb91eae764f5f544a795460022a51a754867f0ca..9465950564795f9773058d7ba40d692b623e957f 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 555951a41882f907f3c780115535cd9266a5ec17..6989af4537d4c6ccd4817e608c0adf4a82d9dc1f 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -130,101 +130,32 @@ module Ticket_token_map = struct map end -let parse_and_cache_script ctxt ~destination ~get_non_cached_script = - Script_cache.find ctxt destination >>=? fun (ctxt, _cache_key, cached) -> - match cached with - | Some (_script, ex_script) -> return (ex_script, ctxt) - | None -> - get_non_cached_script ctxt >>=? fun (script, ctxt) -> - Script_ir_translator.parse_script - ctxt - ~legacy:true - ~allow_forged_in_storage:true - script - >>=? fun (ex_script, ctxt) -> - (* Add the parsed script to the script-cache in order to avoid having to - re-parse when applying the operation at a later stage. *) - let (size, cost) = Script_ir_translator.script_size ex_script in - Gas.consume ctxt cost >>?= fun ctxt -> - Script_cache.insert ctxt destination (script, ex_script) size - >>?= fun ctxt -> return (ex_script, ctxt) - -let tickets_of_transaction ctxt ~destination ~parameters = +let tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters = match Contract.is_implicit destination with | Some _ -> return (None, ctxt) | None -> - (* TODO: #2351 - Avoid having to load the script from the cache. - After internal operations are in place we should be able to use the - typed script directly. - *) - parse_and_cache_script - ctxt - ~destination - ~get_non_cached_script:(fun ctxt -> - (* Look up the script from the context. *) - Contract.get_script ctxt destination >>=? fun (ctxt, script_opt) -> - match script_opt with - | None -> fail (Failed_to_get_script destination) - | Some script -> return (script, ctxt)) - >>=? fun (Script_ir_translator.Ex_script {arg_type; _}, ctxt) -> - Ticket_scanner.type_has_tickets ctxt arg_type + Ticket_scanner.type_has_tickets ctxt parameters_ty >>?= fun (has_tickets, ctxt) -> - (* Load the tickets from the parameters. *) - (* TODO: #2350 - Avoid having to decode and parse the [parameters] node. - After internal operations are in place we should be able to use the - typed script directly. - *) - Script.force_decode_in_context - ctxt - ~consume_deserialization_gas:When_needed - parameters - >>?= fun (expr, ctxt) -> - Ticket_scanner.tickets_of_node + Ticket_scanner.tickets_of_value ~include_lazy:true ctxt has_tickets - (Micheline.root expr) + parameters >>=? fun (tickets, ctxt) -> return (Some {destination; tickets}, ctxt) (** Extract tickets of an origination operation by scanning the storage. *) let tickets_of_origination ctxt ~preorigination script = - match preorigination with - | None -> fail Contract_not_originated - | Some destination -> - (* TODO: #2351 - Avoid having to load the script from the cache. - After internal operations are in place we should be able to use the - typed script directly. - *) - parse_and_cache_script - ctxt - ~destination - ~get_non_cached_script:(fun ctxt -> - (* For an origination operation we already have the script. *) - return (script, ctxt)) - >>=? fun ( Script_ir_translator.Ex_script - { - storage; - storage_type; - code = _; - arg_type = _; - views = _; - entrypoints = _; - code_size = _; - }, - ctxt ) -> - (* Extract any tickets from the storage. Note that if the type of the - contract storage does not contain tickets, storage is not scanned. *) - Ticket_scanner.type_has_tickets ctxt storage_type - >>?= fun (has_tickets, ctxt) -> - Ticket_scanner.tickets_of_value - ctxt - ~include_lazy:true - has_tickets - storage - >|=? fun (tickets, ctxt) -> (Some {tickets; destination}, ctxt) + (* Extract any tickets from the storage. Note that if the type of the + contract storage does not contain tickets, storage is not scanned. *) + Ticket_scanner.type_has_tickets ctxt script.Script_typed_ir.storage_type + >>?= fun (has_tickets, ctxt) -> + Ticket_scanner.tickets_of_value + ctxt + ~include_lazy:true + has_tickets + script.Script_typed_ir.storage + >|=? fun (tickets, ctxt) -> + (Some {tickets; destination = preorigination}, ctxt) (* TODO: #2352 Extend operations scanning to support rollup-operations once ready. @@ -232,27 +163,25 @@ 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 = _; + transaction = + { + amount = _; + parameters = _; + entrypoint = _; + destination = Destination.Contract destination; + }; + parameters_ty; parameters; - entrypoint = _; - destination = Destination.Contract destination; } -> - tickets_of_transaction ctxt ~destination ~parameters - | Origination {delegate = _; script; credit = _; preorigination} -> - tickets_of_origination ctxt ~preorigination script + tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters + | Origination {origination = _; preorigination; parsed_script} -> + tickets_of_origination ctxt ~preorigination parsed_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) - | Sc_rollup_originate {kind = _; boot_sector = _} -> return (None, ctxt) - | Sc_rollup_add_messages {rollup = _; messages = _} -> 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 1b2e7731f7a90f7357dfbf0bc44ea4548dad45ed..0c984a7c34b285df7e8320a92172545df1590e69 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 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out index 2ff966fe8b77239f387748fce68d83f0b91c23c2..fd114ecea713d0dd83cb141d87770cf70a2aef6b 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out @@ -1,7 +1,7 @@ tests_alpha/test_contract.py::TestSelfAddressTransfer::test_send_self_address Node is bootstrapped. -Estimated gas: 5192.870 units (will add 100 for safety) +Estimated gas: 5192.330 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -37,6 +37,6 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: Unit Storage size: 83 bytes - Consumed gas: 2059.158 + Consumed gas: 2058.618 Injected block at minimal timestamp diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out index bb009da93fb33588f24070eec55ca4f52b9d6e17..95bc904195354d50bf7433a7d9d8de54ad92275b 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out @@ -78,7 +78,7 @@ Injected block at minimal timestamp [CONTRACT_HASH] Node is bootstrapped. -Estimated gas: 4338.878 units (will add 100 for safety) +Estimated gas: 4338.998 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -113,7 +113,7 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: 0x0000e7670f32038107a59a2b9cfefae36ea21f5aa63c Storage size: 65 bytes - Consumed gas: 1212.540 + Consumed gas: 1212.660 Injected block at minimal timestamp "[CONTRACT_HASH]" diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out index 9e27ff8ce890972b4bf7d30d64d1d1ded4f0cd5b..96b92d284e10753716e36d935910abc13315c972 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out @@ -143,7 +143,7 @@ Injected block at minimal timestamp [CONTRACT_HASH] Node is bootstrapped. -Estimated gas: 5177.041 units (will add 100 for safety) +Estimated gas: 5177.161 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -181,7 +181,7 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: Unit Storage size: 38 bytes - Consumed gas: 2048.709 + Consumed gas: 2048.829 Balance updates: [CONTRACT_HASH] ... -ꜩ100 [CONTRACT_HASH] ... +ꜩ100 @@ -191,7 +191,7 @@ Injected block at minimal timestamp [CONTRACT_HASH] Node is bootstrapped. -Estimated gas: 4324.014 units (will add 100 for safety) +Estimated gas: 4324.134 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -229,7 +229,7 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: Unit Storage size: 38 bytes - Consumed gas: 2048.709 + Consumed gas: 2048.829 Balance updates: [CONTRACT_HASH] ... -ꜩ100 [CONTRACT_HASH] ... +ꜩ100 diff --git "a/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" "b/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" index 4b98d5ac09ecaff8db1244cb7e9f5a67e11b7127..d08a4da8f2af8a2d2b4d6a1fbce4264fa48087e1 100644 --- "a/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" +++ "b/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" @@ -26,24 +26,23 @@ emitted operations [ None 50000 Unit ] - - location: 13 (remaining gas: 1039983.548 units remaining) - [ 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b + - location: 13 (remaining gas: 1039982.468 units remaining) + [ 0x30 "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm" ] - - location: 25 (remaining gas: 1039983.533 units remaining) + - location: 25 (remaining gas: 1039982.453 units remaining) [ "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm" ] - - location: 27 (remaining gas: 1039983.518 units remaining) + - location: 27 (remaining gas: 1039982.438 units remaining) [ (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 28 (remaining gas: 1039983.503 units remaining) + - location: 28 (remaining gas: 1039982.423 units remaining) [ {} (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 25 (remaining gas: 1039983.473 units remaining) - [ 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b + - location: 25 (remaining gas: 1039982.393 units remaining) + [ 0x30 {} (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 30 (remaining gas: 1039983.458 units remaining) - [ { 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b } + - location: 30 (remaining gas: 1039982.378 units remaining) + [ { 0x30 } (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 31 (remaining gas: 1039983.443 units remaining) - [ (Pair { 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b } - (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm")) ] + - location: 31 (remaining gas: 1039982.363 units remaining) + [ (Pair { 0x30 } (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm")) ] diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out index 5b38b45e78b4b36ba5e80d35effe3e1e49521acf..7762c8f85ac3dcfd483adb4c76ab4201d8c732f9 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestAddApproveTransferRemove::test_add_liquidity Node is bootstrapped. -Estimated gas: 11824.095 units (will add 100 for safety) +Estimated gas: 9874.655 units (will add 100 for safety) Estimated storage: 141 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -12,13 +12,13 @@ and/or an external block explorer to make sure that it has been included. This sequence of operations was run: Manager signed operations: From: [CONTRACT_HASH] - Fee to the baker: ꜩ0.001548 + Fee to the baker: ꜩ0.001353 Expected counter: [EXPECTED_COUNTER] - Gas limit: 11925 + Gas limit: 9975 Storage limit: 161 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.001548 - payload fees(the block proposer) ....... +ꜩ0.001548 + [CONTRACT_HASH] ... -ꜩ0.001353 + payload fees(the block proposer) ....... +ꜩ0.001353 Transaction: Amount: ꜩ9001 From: [CONTRACT_HASH] @@ -58,7 +58,7 @@ This sequence of operations was run: Set map(0)[0x01d496def47a3be89f5d54c6e6bb13cc6645d6e16600] to 721 Storage size: 2263 bytes Paid storage size diff: 68 bytes - Consumed gas: 4394.836 + Consumed gas: 3095.236 Balance updates: [CONTRACT_HASH] ... -ꜩ0.017 storage fees ........................... +ꜩ0.017 @@ -75,7 +75,7 @@ This sequence of operations was run: Set map(2)[0x000002298c03ed7d454a101eb7022bc95f7e5f41ac78] to 72007 Storage size: 2048 bytes Paid storage size diff: 70 bytes - Consumed gas: 4516.613 + Consumed gas: 3866.773 Balance updates: [CONTRACT_HASH] ... -ꜩ0.0175 storage fees ........................... +ꜩ0.0175 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out index 9c736aaec8dedc641e6ca2baa40fb7710993bdfe..319005e5ca276f4205012b31d75e769786a3a8ab 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestAddApproveTransferRemove::test_remove_liquidity Node is bootstrapped. -Estimated gas: 10535.551 units (will add 100 for safety) +Estimated gas: 8586.111 units (will add 100 for safety) Estimated storage: 67 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -12,13 +12,13 @@ and/or an external block explorer to make sure that it has been included. This sequence of operations was run: Manager signed operations: From: [CONTRACT_HASH] - Fee to the baker: ꜩ0.001416 + Fee to the baker: ꜩ0.001221 Expected counter: [EXPECTED_COUNTER] - Gas limit: 10636 + Gas limit: 8687 Storage limit: 87 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.001416 - payload fees(the block proposer) ....... +ꜩ0.001416 + [CONTRACT_HASH] ... -ꜩ0.001221 + payload fees(the block proposer) ....... +ꜩ0.001221 Transaction: Amount: ꜩ0 From: [CONTRACT_HASH] @@ -47,7 +47,7 @@ This sequence of operations was run: Updated big_maps: Unset map(2)[0x0000e7670f32038107a59a2b9cfefae36ea21f5aa63c] Storage size: 2048 bytes - Consumed gas: 2522.999 + Consumed gas: 1873.159 Transaction: Amount: ꜩ0 From: [CONTRACT_HASH] @@ -63,7 +63,7 @@ This sequence of operations was run: Set map(0)[0x0000e7670f32038107a59a2b9cfefae36ea21f5aa63c] to 10 Storage size: 2330 bytes Paid storage size diff: 67 bytes - Consumed gas: 3677.591 + Consumed gas: 2377.991 Balance updates: [CONTRACT_HASH] ... -ꜩ0.01675 storage fees ........................... +ꜩ0.01675 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out index f9805a93c93e1f1a53337d86d07fbd66fad54345..320386a0ccd36e186dee358e4fc5d0c4217b3be6 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestTrades::test_add_liquidity Node is bootstrapped. -Estimated gas: 11824.095 units (will add 100 for safety) +Estimated gas: 9874.655 units (will add 100 for safety) Estimated storage: 141 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -12,13 +12,13 @@ and/or an external block explorer to make sure that it has been included. This sequence of operations was run: Manager signed operations: From: [CONTRACT_HASH] - Fee to the baker: ꜩ0.001548 + Fee to the baker: ꜩ0.001353 Expected counter: [EXPECTED_COUNTER] - Gas limit: 11925 + Gas limit: 9975 Storage limit: 161 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.001548 - payload fees(the block proposer) ....... +ꜩ0.001548 + [CONTRACT_HASH] ... -ꜩ0.001353 + payload fees(the block proposer) ....... +ꜩ0.001353 Transaction: Amount: ꜩ9001 From: [CONTRACT_HASH] @@ -58,7 +58,7 @@ This sequence of operations was run: Set map(0)[0x01d496def47a3be89f5d54c6e6bb13cc6645d6e16600] to 721 Storage size: 2263 bytes Paid storage size diff: 68 bytes - Consumed gas: 4394.836 + Consumed gas: 3095.236 Balance updates: [CONTRACT_HASH] ... -ꜩ0.017 storage fees ........................... +ꜩ0.017 @@ -75,7 +75,7 @@ This sequence of operations was run: Set map(2)[0x000002298c03ed7d454a101eb7022bc95f7e5f41ac78] to 72007 Storage size: 2048 bytes Paid storage size diff: 70 bytes - Consumed gas: 4516.613 + Consumed gas: 3866.773 Balance updates: [CONTRACT_HASH] ... -ꜩ0.0175 storage fees ........................... +ꜩ0.0175 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out index c272e7202084240eb4d2e48031110bad877f7d77..a26a11c0d324578943f651e50b47bacc5fa3f89c 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestTrades::test_buy_tok Node is bootstrapped. -Estimated gas: 7500.823 units (will add 100 for safety) +Estimated gas: 6201.223 units (will add 100 for safety) Estimated storage: 326 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -12,13 +12,13 @@ and/or an external block explorer to make sure that it has been included. This sequence of operations was run: Manager signed operations: From: [CONTRACT_HASH] - Fee to the baker: ꜩ0.001108 + Fee to the baker: ꜩ0.000978 Expected counter: [EXPECTED_COUNTER] - Gas limit: 7601 + Gas limit: 6302 Storage limit: 346 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.001108 - payload fees(the block proposer) ....... +ꜩ0.001108 + [CONTRACT_HASH] ... -ꜩ0.000978 + payload fees(the block proposer) ....... +ꜩ0.000978 Transaction: Amount: ꜩ9001 From: [CONTRACT_HASH] @@ -56,7 +56,7 @@ This sequence of operations was run: Set map(0)[0x0000e7670f32038107a59a2b9cfefae36ea21f5aa63c] to 360 Storage size: 2331 bytes Paid storage size diff: 68 bytes - Consumed gas: 3677.595 + Consumed gas: 2377.995 Balance updates: [CONTRACT_HASH] ... -ꜩ0.017 storage fees ........................... +ꜩ0.017 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out index dec69e87bf86c78f4953c58beb74f9ce589d5be9..5ce9374689486dc5e4535b02f496481b8a4cc86f 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestTrades::test_sell_tok Node is bootstrapped. -Estimated gas: 9819.219 units (will add 100 for safety) +Estimated gas: 8519.619 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -12,13 +12,13 @@ and/or an external block explorer to make sure that it has been included. This sequence of operations was run: Manager signed operations: From: [CONTRACT_HASH] - Fee to the baker: ꜩ0.001337 + Fee to the baker: ꜩ0.001207 Expected counter: [EXPECTED_COUNTER] - Gas limit: 9920 + Gas limit: 8620 Storage limit: 0 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.001337 - payload fees(the block proposer) ....... +ꜩ0.001337 + [CONTRACT_HASH] ... -ꜩ0.001207 + payload fees(the block proposer) ....... +ꜩ0.001207 Transaction: Amount: ꜩ0 From: [CONTRACT_HASH] @@ -51,7 +51,7 @@ This sequence of operations was run: Unset map(0)[0x0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd6] Set map(0)[0x01d496def47a3be89f5d54c6e6bb13cc6645d6e16600] to 461 Storage size: 2331 bytes - Consumed gas: 4574.872 + Consumed gas: 3275.272 Transaction: Amount: ꜩ3891.966034 From: [CONTRACT_HASH]