From 81e1370c9fcb888cf53285398ae851a1929a0bfd Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Thu, 9 Oct 2025 16:41:45 +0200 Subject: [PATCH 1/4] Proto: Typed_IR: views in AST only for Lambda implementation --- src/proto_alpha/lib_plugin/RPC.ml | 2 - src/proto_alpha/lib_protocol/apply.ml | 31 ++- .../lib_protocol/michelson_v1_gas.ml | 8 + .../lib_protocol/michelson_v1_gas.mli | 6 + .../lib_protocol/script_interpreter.ml | 213 ++++++++++++------ .../lib_protocol/script_ir_translator.ml | 9 +- .../lib_protocol/script_ir_translator.mli | 2 +- src/proto_alpha/lib_protocol/script_native.ml | 5 + .../lib_protocol/script_native.mli | 4 + .../lib_protocol/script_native_types.ml | 20 ++ .../lib_protocol/script_native_types.mli | 20 ++ src/proto_alpha/lib_protocol/script_typed.ml | 2 +- src/proto_alpha/lib_protocol/script_typed.mli | 2 +- .../michelson/test_ticket_accounting.ml | 1 - .../michelson/test_ticket_operations_diff.ml | 1 - 15 files changed, 230 insertions(+), 96 deletions(-) diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 09b5c218bbfd..fda15924c4fb 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -1616,7 +1616,6 @@ module Scripts = struct implementation; arg_type; storage_type; - views; entrypoints; code_size; }), @@ -1639,7 +1638,6 @@ module Scripts = struct implementation; arg_type; storage_type; - views; entrypoints; code_size; storage; diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index b412a56dcbc7..cab16bd3af26 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1348,18 +1348,27 @@ let apply_manager_operation : type kind. ~allow_forged_lazy_storage_id_in_storage:false (Script script) in - let (Script {storage_type; views; storage; _}) = parsed_script in - let views_result = - Script_ir_translator.parse_views - ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) - storage_type - views + let (Script {storage_type; storage; implementation; _}) = + parsed_script in - let* _typed_views, ctxt = - trace - (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) - views_result + let* ctxt = + match implementation with + | Lambda {views; _} -> + let views_result = + Script_ir_translator.parse_views + ctxt + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + storage_type + views + in + let* _typed_views, ctxt = + trace + (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) + views_result + in + return ctxt + (* Native branch is technically dead, a native contract cannot be originated *) + | Native _ -> return ctxt in let+ ctxt, origination_result, ops = apply_origination diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml index 5ad8fb2b54bd..c72a60d81e97 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml @@ -630,9 +630,17 @@ module Cost_of = struct let view_get (elt : Script_string.t) (m : Script_typed_ir.view_map) = map_get elt m + let native_view_get (elt : Script_string.t) + (m : 'storage Script_native_types.view_map) = + map_get elt m + let view_update (elt : Script_string.t) (m : Script_typed_ir.view_map) = map_update elt m + let native_view_update (elt : Script_string.t) + (m : 'storage Script_native_types.view_map) = + map_update elt m + let join_tickets : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.ticket -> diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.mli b/src/proto_alpha/lib_protocol/michelson_v1_gas.mli index 7fc1008106b5..8fe328f1e519 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.mli @@ -349,8 +349,14 @@ module Cost_of : sig val view_get : Script_string.t -> Script_typed_ir.view_map -> Gas.cost + val native_view_get : + Script_string.t -> 'storage Script_native_types.view_map -> Gas.cost + val view_update : Script_string.t -> Script_typed_ir.view_map -> Gas.cost + val native_view_update : + Script_string.t -> 'storage Script_native_types.view_map -> Gas.cost + val transfer_tokens : Gas.cost val implicit_account : Gas.cost diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 182af698fae3..a93b89f5cccd 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -571,7 +571,9 @@ module Raw = struct match script_opt with | None -> (return_none [@ocaml.tailcall]) ctxt | Some script -> ( - let* Ex_script (Script {storage; storage_type; views; _}), ctxt = + let* ( Ex_script + (Script {storage; storage_type; implementation; _}), + ctxt ) = parse_script ~elab_conf:legacy ~allow_forged_tickets_in_storage:true @@ -579,80 +581,151 @@ module Raw = struct ctxt script in - let*? ctxt = - Gas.consume ctxt (Interp_costs.view_get name views) - in - match Script_map.get name views with - | None -> (return_none [@ocaml.tailcall]) ctxt - | Some view -> ( - let view_result = - Script_ir_translator.parse_view - ctxt - ~elab_conf:legacy - storage_type - view - in - let* ( Typed_view - { - input_ty = input_ty'; - output_ty = output_ty'; - kinstr; - original_code_expr = _; - }, - ctxt ) = - trace_eval - (fun () -> - Script_tc_errors.Ill_typed_contract - (Micheline.strip_locations view.view_code, [])) - view_result - in - let io_ty = - let open Gas_monad.Syntax in - let* out_eq = - ty_eq ~error_details:Fast output_ty' output_ty - in - let+ in_eq = ty_eq ~error_details:Fast input_ty input_ty' in - (out_eq, in_eq) + match implementation with + | Native {kind} -> ( + let*? views = Script_native.get_views kind in + let*? ctxt = + Gas.consume ctxt (Interp_costs.native_view_get name views) in - let*? eq, ctxt = Gas_monad.run ctxt io_ty in - match eq with - | Error Inconsistent_types_fast -> - (return_none [@ocaml.tailcall]) ctxt - | Ok (Eq, Eq) -> - let kcons = - KCons (ICons_some (kinstr_location k, k), ks) + match Script_map.get name views with + | None -> (return_none [@ocaml.tailcall]) ctxt + | Some + (Ex_view + { + name = _; + ty = + { + input_ty = Ty_ex_c input_ty'; + output_ty = Ty_ex_c output_ty'; + }; + implementation; + }) -> ( + let io_ty = + let open Gas_monad.Syntax in + let* out_eq = + ty_eq ~error_details:Fast output_ty' output_ty + in + let+ in_eq = + ty_eq ~error_details:Fast input_ty input_ty' + in + (out_eq, in_eq) in - let* ctxt, balance = - Contract.get_balance_carbonated ctxt c + let*? eq, ctxt = Gas_monad.run ctxt io_ty in + match eq with + | Error Inconsistent_types_fast -> + (return_none [@ocaml.tailcall]) ctxt + | Ok (Eq, Eq) -> + let* ctxt, balance = + Contract.get_balance_carbonated ctxt c + in + let step_constants = + { + sender = + Destination.Contract + (Contract.Originated sc.self); + self = contract_hash; + amount = Tez.zero; + balance; + (* The following remain unchanged, but let's + list them anyway, so that we don't forget + to update something added later. *) + payer = sc.payer; + chain_id = sc.chain_id; + now = sc.now; + level = sc.level; + } + in + let* result, ctxt = + implementation (ctxt, step_constants) input storage + in + let gas, ctxt = + local_gas_counter_and_outdated_context ctxt + in + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + (ICons_some (kinstr_location k, k)) + ks + result + stack)) + | Lambda {views; _} -> ( + let*? ctxt = + Gas.consume ctxt (Interp_costs.view_get name views) + in + match Script_map.get name views with + | None -> (return_none [@ocaml.tailcall]) ctxt + | Some view -> ( + let view_result = + Script_ir_translator.parse_view + ctxt + ~elab_conf:legacy + storage_type + view in - let gas, ctxt = - local_gas_counter_and_outdated_context ctxt + let* ( Typed_view + { + input_ty = input_ty'; + output_ty = output_ty'; + kinstr; + original_code_expr = _; + }, + ctxt ) = + trace_eval + (fun () -> + Script_tc_errors.Ill_typed_contract + (Micheline.strip_locations view.view_code, [])) + view_result in - let sty = - Option.map (fun t -> Item_t (output_ty, t)) stack_ty + let io_ty = + let open Gas_monad.Syntax in + let* out_eq = + ty_eq ~error_details:Fast output_ty' output_ty + in + let+ in_eq = + ty_eq ~error_details:Fast input_ty input_ty' + in + (out_eq, in_eq) in - (step [@ocaml.tailcall]) - ( ctxt, - { - sender = - Destination.Contract (Contract.Originated sc.self); - self = contract_hash; - amount = Tez.zero; - balance; - (* The following remain unchanged, but let's + let*? eq, ctxt = Gas_monad.run ctxt io_ty in + match eq with + | Error Inconsistent_types_fast -> + (return_none [@ocaml.tailcall]) ctxt + | Ok (Eq, Eq) -> + let kcons = + KCons (ICons_some (kinstr_location k, k), ks) + in + let* ctxt, balance = + Contract.get_balance_carbonated ctxt c + in + let gas, ctxt = + local_gas_counter_and_outdated_context ctxt + in + let sty = + Option.map (fun t -> Item_t (output_ty, t)) stack_ty + in + (step [@ocaml.tailcall]) + ( ctxt, + { + sender = + Destination.Contract + (Contract.Originated sc.self); + self = contract_hash; + amount = Tez.zero; + balance; + (* The following remain unchanged, but let's list them anyway, so that we don't forget to update something added later. *) - payer = sc.payer; - chain_id = sc.chain_id; - now = sc.now; - level = sc.level; - } ) - gas - kinstr - (instrument - @@ KView_exit (sc, KReturn (stack, sty, kcons))) - (input, storage) - (EmptyCell, EmptyCell)))) + payer = sc.payer; + chain_id = sc.chain_id; + now = sc.now; + level = sc.level; + } ) + gas + kinstr + (instrument + @@ KView_exit (sc, KReturn (stack, sty, kcons))) + (input, storage) + (EmptyCell, EmptyCell))))) and step : type a s b t r f. (a, s, b, t, r, f) step_type = let open Lwt_result_syntax in @@ -1835,7 +1908,6 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal storage = old_storage; storage_type; entrypoints; - views; }), ctxt ) = match cached_script with @@ -1874,7 +1946,7 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal in let* (ops, new_storage), ctxt = match implementation with - | Lambda {code} -> + | Lambda {code; _} -> trace (Runtime_contract_error step_constants.self) (interp logger (ctxt, step_constants) code (arg, old_storage)) @@ -1918,7 +1990,6 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal storage; storage_type; entrypoints; - views; }) in let*? arg_type_has_tickets, ctxt = diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 1fb6a4017652..9185e117f4d0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1128,6 +1128,7 @@ type ('arg, 'storage) implementation = | Lambda : { code : (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda; + views : view_map; } -> ('arg, 'storage) implementation | Native : { @@ -1140,7 +1141,6 @@ type ('arg, 'storage) code = implementation : ('arg, 'storage) implementation; arg_type : ('arg, _) ty; storage_type : ('storage, _) ty; - views : view_map; entrypoints : 'arg entrypoints; code_size : Cache_memory_helpers.sint; } @@ -5177,7 +5177,6 @@ let get_typed_native_code : arg_type; storage_type; entrypoints; - views = Script_map.empty string_t; code_size = Saturation_repr.zero; }), ctxt ) @@ -5242,10 +5241,9 @@ let parse_code : ( Ex_code (Code { - implementation = Lambda {code}; + implementation = Lambda {code; views}; arg_type; storage_type; - views; entrypoints; code_size; }), @@ -5311,7 +5309,6 @@ let parse_script : implementation; arg_type; storage_type; - views; entrypoints; code_size; }), @@ -5343,7 +5340,6 @@ let parse_script : arg_type; storage; storage_type; - views; entrypoints; }), ctxt ) @@ -6189,7 +6185,6 @@ let script_size storage; storage_type; entrypoints = _; - views = _; })) = let nodes, storage_size = Script_typed_ir_size.value_size storage_type storage diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index dfa9e0a04e3d..ab081d51c278 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -95,6 +95,7 @@ type ('arg, 'storage) implementation = | Lambda : { code : (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda; + views : view_map; } -> ('arg, 'storage) implementation | Native : { @@ -107,7 +108,6 @@ type ('arg, 'storage) code = implementation : ('arg, 'storage) implementation; arg_type : ('arg, _) Script_typed_ir.ty; storage_type : ('storage, _) Script_typed_ir.ty; - views : Script_typed_ir.view_map; entrypoints : 'arg Script_typed_ir.entrypoints; code_size : Cache_memory_helpers.sint; (** This is an over-approximation of the value size in memory, in diff --git a/src/proto_alpha/lib_protocol/script_native.ml b/src/proto_alpha/lib_protocol/script_native.ml index cb8d86006c4d..2c32484e1e69 100644 --- a/src/proto_alpha/lib_protocol/script_native.ml +++ b/src/proto_alpha/lib_protocol/script_native.ml @@ -116,6 +116,11 @@ module CLST_contract = struct execute_withdraw (ctxt, step_constants) amount storage end +let get_views : type arg storage. + (arg, storage) kind -> storage Script_native_types.view_map tzresult = + function + | CLST_kind -> assert false + let execute (type arg storage) (ctxt, step_constants) (kind : (arg, storage) kind) (arg : arg) (storage : storage) : ((operation Script_list.t, storage) pair * context, error trace) result diff --git a/src/proto_alpha/lib_protocol/script_native.mli b/src/proto_alpha/lib_protocol/script_native.mli index bee2e761571e..21af8053fd8c 100644 --- a/src/proto_alpha/lib_protocol/script_native.mli +++ b/src/proto_alpha/lib_protocol/script_native.mli @@ -18,6 +18,10 @@ module CLST_contract : sig | Amount_too_large of Destination.t * CLST_types.nat end +val get_views : + 'arg 'storage. + ('arg, 'storage) kind -> (Script_string.t, 'storage ex_view) map tzresult + (* [execute ctxt kind arg storage] executes the given native contract [kind] with [arg] and [storage], and returns the list of operations, the new storage and the context. *) diff --git a/src/proto_alpha/lib_protocol/script_native_types.ml b/src/proto_alpha/lib_protocol/script_native_types.ml index b1ef9ed15ee1..6451f6618816 100644 --- a/src/proto_alpha/lib_protocol/script_native_types.ml +++ b/src/proto_alpha/lib_protocol/script_native_types.ml @@ -106,6 +106,26 @@ module Helpers = struct (ty, {root = entrypoint; original_type_expr = ty.untyped}) end +type ('arg, 'output) view_type = { + input_ty : 'arg ty_ex_c; + output_ty : 'output ty_ex_c; +} + +type ('arg, 'storage, 'output) view = { + name : Script_string.t; + ty : ('arg, 'output) view_type; + implementation : + context * step_constants -> + 'arg -> + 'storage -> + ('output * context) tzresult Lwt.t; +} + +type 'storage ex_view = + | Ex_view : ('arg, 'storage, 'output) view -> 'storage ex_view + +type 'storage view_map = (Script_string.t, 'storage ex_view) map + module CLST_types = struct open Helpers diff --git a/src/proto_alpha/lib_protocol/script_native_types.mli b/src/proto_alpha/lib_protocol/script_native_types.mli index 02c7161a625d..459ffe9ebb09 100644 --- a/src/proto_alpha/lib_protocol/script_native_types.mli +++ b/src/proto_alpha/lib_protocol/script_native_types.mli @@ -10,6 +10,11 @@ open Alpha_context open Script_typed_ir +type ('arg, 'output) view_type = { + input_ty : 'arg ty_ex_c; + output_ty : 'output ty_ex_c; +} + (** Types declaration of CLST contracts (entrypoints and storage). *) module CLST_types : sig type nat = Script_int.n Script_int.num @@ -39,6 +44,21 @@ type ex_kind_and_types = val get_typed_kind_and_types : Script_native_repr.t -> ex_kind_and_types tzresult +type ('arg, 'storage, 'output) view = { + name : Script_string.t; + ty : ('arg, 'output) view_type; + implementation : + context * step_constants -> + 'arg -> + 'storage -> + ('output * context) tzresult Lwt.t; +} + +type 'storage ex_view = + | Ex_view : ('arg, 'storage, 'output) view -> 'storage ex_view + +type 'storage view_map = (Script_string.t, 'storage ex_view) map + module Internal_for_tests : sig val eq_native_kind : ('arg, 'storage) kind -> ('arg', 'storage') kind -> bool diff --git a/src/proto_alpha/lib_protocol/script_typed.ml b/src/proto_alpha/lib_protocol/script_typed.ml index e69a13d518cf..62f5e28da12a 100644 --- a/src/proto_alpha/lib_protocol/script_typed.ml +++ b/src/proto_alpha/lib_protocol/script_typed.ml @@ -13,6 +13,7 @@ type ('arg, 'storage) implementation = | Lambda : { code : (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda; + views : view_map; } -> ('arg, 'storage) implementation | Native : { @@ -26,7 +27,6 @@ type ('arg, 'storage) script = arg_type : ('arg, _) ty; storage : 'storage; storage_type : ('storage, _) ty; - views : view_map; entrypoints : 'arg entrypoints; code_size : Cache_memory_helpers.sint; } diff --git a/src/proto_alpha/lib_protocol/script_typed.mli b/src/proto_alpha/lib_protocol/script_typed.mli index cdc34b34eb76..326d602e3f2d 100644 --- a/src/proto_alpha/lib_protocol/script_typed.mli +++ b/src/proto_alpha/lib_protocol/script_typed.mli @@ -13,6 +13,7 @@ type ('arg, 'storage) implementation = | Lambda : { code : (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda; + views : view_map; } -> ('arg, 'storage) implementation | Native : { @@ -26,7 +27,6 @@ type ('arg, 'storage) script = arg_type : ('arg, _) ty; storage : 'storage; storage_type : ('storage, _) ty; - views : view_map; entrypoints : 'arg entrypoints; code_size : Cache_memory_helpers.sint; (* This is an over-approximation of the value size in memory, in 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 4ff2e24731ae..bf90cb7bd415 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 @@ -346,7 +346,6 @@ let origination_operation ctxt ~sender ~script:(code, storage) ~orig_contract = storage; implementation = _; arg_type = _; - views = _; entrypoints = _; code_size = _; }), 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 d0e664c3e618..13ad856324d5 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 @@ -272,7 +272,6 @@ let origination_operation block ~sender ~baker ~script ~storage ~forges_tickets storage; implementation = _; arg_type = _; - views = _; entrypoints = _; code_size = _; }), -- GitLab From 3327be0b1e4f7da5cd6954f1b6815a54d810014d Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Thu, 9 Oct 2025 16:43:20 +0200 Subject: [PATCH 2/4] Plugin: make view RPC working with native contracts --- src/proto_alpha/lib_plugin/RPC.ml | 88 +++++++++++++++++++++---------- 1 file changed, 61 insertions(+), 27 deletions(-) diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index fda15924c4fb..067ab1fad48a 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -1211,14 +1211,8 @@ module Scripts = struct ~now_opt ~level_opt in - let script_entrypoint_type ctxt expr entrypoint = - let ctxt = Gas.set_unlimited ctxt in - let legacy = false in + let entrypoint_type ctxt arg_type entrypoint entrypoints = let open Script_ir_translator in - let* {arg_type; _}, ctxt = parse_toplevel ctxt expr in - let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _ = - parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type - in let*? r, _ctxt = Gas_monad.run ctxt @@ Script_ir_translator.find_entrypoint @@ -1230,6 +1224,24 @@ module Scripts = struct let*? (Ex_ty_cstr {original_type_expr; _}) = r in return @@ Micheline.strip_locations original_type_expr in + let script_entrypoint_type ctxt expr entrypoint = + let open Script_ir_translator in + let ctxt = Gas.set_unlimited ctxt in + let* {arg_type; _}, ctxt = + Script_ir_translator.parse_toplevel ctxt expr + in + let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _ = + parse_parameter_ty_and_entrypoints ctxt ~legacy:false arg_type + in + entrypoint_type ctxt arg_type entrypoint entrypoints + in + let native_entrypoint_type ctxt native entrypoint = + let ctxt = Gas.set_unlimited ctxt in + let*? (Ex_kind_and_types (_, {arg_type; entrypoints; _})) = + Script_native_types.get_typed_kind_and_types native + in + entrypoint_type ctxt arg_type entrypoint entrypoints + in let script_view_type ctxt contract expr view = let ctxt = Gas.set_unlimited ctxt in let open Script_ir_translator in @@ -1242,6 +1254,36 @@ module Scripts = struct | Some Script_typed_ir.{input_ty; output_ty; _} -> return (input_ty, output_ty) in + let native_view_type ctxt contract kind view = + let*? (Ex_kind_and_types (kind, _)) = + Script_native_types.get_typed_kind_and_types kind + in + let*? views = Script_native.get_views kind in + let*? view_name = Script_string.of_string view in + match Script_map.get view_name views with + | None -> + Environment.Error_monad.tzfail + (View_helpers.View_not_found (contract, view)) + | Some + (Script_native_types.Ex_view + { + ty = {input_ty = Ty_ex_c input_ty; output_ty = Ty_ex_c output_ty}; + _; + }) -> + let*? unparsed_input_ty, _ctxt = + Script_ir_unparser.unparse_ty + ~loc:Micheline.dummy_location + ctxt + input_ty + in + let*? unparsed_output_ty, _ctxt = + Script_ir_unparser.unparse_ty + ~loc:Micheline.dummy_location + ctxt + output_ty + in + return (unparsed_input_ty, unparsed_output_ty) + in Registration.register0 ~chunked:true S.run_code @@ -1412,17 +1454,13 @@ module Scripts = struct View_helpers.Viewed_contract_has_no_script) script_opt in - (* The native case will be handled in a later MR (!19583). *) - let script = + let* view_ty = match script with - | Script.Script s -> s - | Native _ -> - Stdlib.failwith - "Tzip4 views are not implemented yet for native contracts" + | Script.Native n -> native_entrypoint_type ctxt n.kind entrypoint + | Script.Script s -> + let*? decoded_script = Script_repr.(force_decode s.code) in + script_entrypoint_type ctxt decoded_script entrypoint in - (* let*? script = Environment.Error_monad.Result_syntax wrap_tzresult script in *) - let*? decoded_script = Script_repr.(force_decode script.code) in - let* view_ty = script_entrypoint_type ctxt decoded_script entrypoint in let*? ty = View_helpers.extract_view_output_type entrypoint view_ty in let contract = Contract.Originated contract_hash in let* balance = Contract.get_balance ctxt contract in @@ -1471,7 +1509,7 @@ module Scripts = struct ctxt unparsing_mode step_constants - ~script:(Script.Script script) + ~script ~cached_script:None ~entrypoint ~parameter @@ -1511,19 +1549,15 @@ module Scripts = struct ~none:(Error_monad.error View_helpers.Viewed_contract_has_no_script) script_opt in - (* The native case will be handled in a later MR (!19583). *) - let script = + let* input_ty, output_ty = match script with - | Script.Script s -> s - | Script.Native _ -> - Stdlib.failwith - "Views are not implemented yet for native contracts" + | Script.Native {kind; _} -> + native_view_type ctxt contract_hash kind view + | Script.Script {code; _} -> + let*? decoded_script = Script_repr.(force_decode code) in + script_view_type ctxt contract_hash decoded_script view in - let*? decoded_script = Script_repr.(force_decode script.code) in let contract = Contract.Originated contract_hash in - let* input_ty, output_ty = - script_view_type ctxt contract_hash decoded_script view - in let* balance = Contract.get_balance ctxt contract in let ctxt, step_constants = compute_step_constants -- GitLab From 491d3af07e1a1beb0ebe787b96349fe775d5b4b4 Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Thu, 20 Nov 2025 15:44:56 +0100 Subject: [PATCH 3/4] Proto/CLST: get_balance view --- src/proto_alpha/lib_protocol/clst_storage.ml | 3 +++ src/proto_alpha/lib_protocol/clst_storage.mli | 4 +++ src/proto_alpha/lib_protocol/script_native.ml | 26 ++++++++++++++++++- .../lib_protocol/script_native_types.ml | 7 +++++ .../lib_protocol/script_native_types.mli | 4 +++ 5 files changed, 43 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/clst_storage.ml b/src/proto_alpha/lib_protocol/clst_storage.ml index f49817cd2f5c..dda304075737 100644 --- a/src/proto_alpha/lib_protocol/clst_storage.ml +++ b/src/proto_alpha/lib_protocol/clst_storage.ml @@ -9,6 +9,9 @@ open Alpha_context open Script_native_types open Script_typed_ir +(* In case of single assets contracts, the token id of the asset is always 0. *) +let token_id = Script_int.zero_n + let get_storage ctxt = let open Lwt_result_syntax in let* clst_contract_hash = Contract.get_clst_contract_hash ctxt in diff --git a/src/proto_alpha/lib_protocol/clst_storage.mli b/src/proto_alpha/lib_protocol/clst_storage.mli index 6e8fd8909501..f90528b91a0d 100644 --- a/src/proto_alpha/lib_protocol/clst_storage.mli +++ b/src/proto_alpha/lib_protocol/clst_storage.mli @@ -9,6 +9,10 @@ open Alpha_context open Script_native_types open Script_typed_ir +(** [token_id] is the token identifier of CLST, being 0 by default for FA2 + single asset contracts. *) +val token_id : CLST_types.nat + (** [get_storage ctxt] returns the storage retrieved and parsed from the context. It doesn't fail if the storage didn't exist in the context, i.e. the CLST contract has not been originated. *) diff --git a/src/proto_alpha/lib_protocol/script_native.ml b/src/proto_alpha/lib_protocol/script_native.ml index 2c32484e1e69..f53b52c678f9 100644 --- a/src/proto_alpha/lib_protocol/script_native.ml +++ b/src/proto_alpha/lib_protocol/script_native.ml @@ -114,12 +114,36 @@ module CLST_contract = struct | L () (* deposit *) -> execute_deposit (ctxt, step_constants) () storage | R amount (* withdraw *) -> execute_withdraw (ctxt, step_constants) amount storage + + module Views = struct + let balance : storage ex_view tzresult = + let open Result_syntax in + let* name = Script_string.of_string "get_balance" in + let* ty = CLST_types.balance_view_ty in + let implementation (ctxt, _step_constants) ((address : address), token_id) + (ledger : storage) = + let open Lwt_result_syntax in + if Compare.Int.(Script_int.compare token_id Clst_storage.token_id = 0) + then Clst_storage.get_balance_from_storage ctxt ledger address + else return (Script_int.zero_n, ctxt) + in + return (Ex_view {name; ty; implementation}) + + let view_map : storage Script_native_types.view_map tzresult = + let open Result_syntax in + let* (Ex_view {name = get_balance_name; _} as get_balance) = balance in + return + @@ Script_map.update + get_balance_name + (Some get_balance) + (Script_map.empty string_t) + end end let get_views : type arg storage. (arg, storage) kind -> storage Script_native_types.view_map tzresult = function - | CLST_kind -> assert false + | CLST_kind -> CLST_contract.Views.view_map let execute (type arg storage) (ctxt, step_constants) (kind : (arg, storage) kind) (arg : arg) (storage : storage) : diff --git a/src/proto_alpha/lib_protocol/script_native_types.ml b/src/proto_alpha/lib_protocol/script_native_types.ml index 6451f6618816..c4b55058e900 100644 --- a/src/proto_alpha/lib_protocol/script_native_types.ml +++ b/src/proto_alpha/lib_protocol/script_native_types.ml @@ -155,6 +155,13 @@ module CLST_types = struct return (finalize_entrypoint arg_type) let storage_type : storage ty_node tzresult = address_big_map_ty (nat_ty ()) + + type balance_view = (address * nat, nat) view_type + + let balance_view_ty = + let open Result_syntax in + let* {typed = input_ty; _} = pair_ty (address_ty ()) (nat_ty ()) in + return {input_ty; output_ty = (nat_ty ()).typed} end type ('arg, 'storage) kind = diff --git a/src/proto_alpha/lib_protocol/script_native_types.mli b/src/proto_alpha/lib_protocol/script_native_types.mli index 459ffe9ebb09..0ac294a9d0d2 100644 --- a/src/proto_alpha/lib_protocol/script_native_types.mli +++ b/src/proto_alpha/lib_protocol/script_native_types.mli @@ -28,6 +28,10 @@ module CLST_types : sig type ledger = (address, nat) big_map type storage = ledger + + type balance_view = (address * nat, nat) view_type + + val balance_view_ty : balance_view tzresult end (** Typed equivalent of `Script_native_repr.kind` *) -- GitLab From fbf85cc48eb2512bf7aac53e91100c33865c2825 Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Thu, 20 Nov 2025 16:36:44 +0100 Subject: [PATCH 4/4] Proto/Test: test get_balance view --- .../test/integration/test_clst.ml | 53 +++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/src/proto_alpha/lib_protocol/test/integration/test_clst.ml b/src/proto_alpha/lib_protocol/test/integration/test_clst.ml index 1417a9df77d9..2d92a0184d59 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_clst.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_clst.ml @@ -22,6 +22,25 @@ let register_test ~title = ~file_tags:["clst"] ~title:("CLST: " ^ title) +let run_view ~contract ~view_name ~input (block : Block.t) = + let chain_id = Chain_id.of_block_hash block.hash in + Plugin.RPC.Scripts.run_script_view + ~gas:None + ~other_contracts:None + ~extra_big_maps:None + ~contract + ~view:view_name + ~input + ~unlimited_gas:true + ~now:None + ~chain_id + ~level:None + ~sender:None + ~payer:None + ~unparsing_mode:Script_ir_unparser.Readable + Block.rpc_ctxt + block + let get_clst_hash ctxt = let open Lwt_result_wrap_syntax in let* alpha_ctxt = Context.get_alpha_ctxt ctxt in @@ -280,3 +299,37 @@ let () = | Ok _ -> Test.fail "Transferring to withdraw is forbidden" | Error trace -> Error_helpers.expect_clst_non_empty_transfer ~loc:__LOC__ trace + +let () = + register_test ~title:"Test get_balance view" @@ fun () -> + let open Lwt_result_wrap_syntax in + let* b, sender = Context.init1 () in + let* clst_hash = get_clst_hash (B b) in + let amount = Tez.of_mutez_exn 100000000L in + let* deposit_tx = Op.clst_deposit (B b) sender amount in + let* b = Block.bake ~operation:deposit_tx b in + let* balance = + run_view + ~contract:clst_hash + ~view_name:"get_balance" + ~input: + Environment.Micheline.( + Prim + ( dummy_location, + Script.D_Pair, + [ + String (dummy_location, Contract.to_b58check sender); + Int (dummy_location, Z.zero); + ], + [] ) + |> strip_locations) + b + in + let balance = + match balance |> Environment.Micheline.root with + | Environment.Micheline.Int (_, balance_z) -> balance_z |> Z.to_int64 + | _ -> Test.fail "Unexpected output" + in + let amount = Tez.to_mutez amount in + let* () = Assert.equal_int64 ~loc:__LOC__ amount balance in + return_unit -- GitLab