From 9edf8131bf8f79bb814a776bd9b7ff624a5b38a2 Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Mon, 13 Oct 2025 15:03:57 +0200 Subject: [PATCH 1/7] Proto: add helper combinator for native contracts entrypoints Co-authored-by: Marina Polubelova --- .../lib_protocol/script_native_types.ml | 87 ++++++++++++++----- .../test/unit/test_native_contracts.ml | 47 +++++++++- 2 files changed, 111 insertions(+), 23 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_native_types.ml b/src/proto_alpha/lib_protocol/script_native_types.ml index 24e932062490..21be4424c54d 100644 --- a/src/proto_alpha/lib_protocol/script_native_types.ml +++ b/src/proto_alpha/lib_protocol/script_native_types.ml @@ -17,28 +17,76 @@ module Helpers = struct combinator to define native contract types. *) type 'a ty_node = {untyped : Script.node; typed : 'a ty_ex_c} - let prim ?(loc = dummy_location) ?(annot = []) ?named prim args = + (* We actually don't need the location at all *) + let loc = dummy_location + + let prim ?(annot = []) ?named prim args = let annot = match named with Some name -> name :: annot | None -> annot in Prim (loc, prim, args, annot) - let unit_ty ?loc () = - {untyped = prim ?loc Script.T_unit []; typed = Ty_ex_c unit_t} + let unit_ty () = {untyped = prim Script.T_unit []; typed = Ty_ex_c unit_t} (* Some combinators are unused for now but will be used later, and they serve as an example to implement the rest. They are not exported as they are specific to building native contracts types. *) [@@@ocaml.warning "-32"] - let int_ty ?loc () = - {untyped = prim ?loc Script.T_int []; typed = Ty_ex_c int_t} + let int_ty () = {untyped = prim Script.T_int []; typed = Ty_ex_c int_t} - let pair_ty (type a b) ?(loc = dummy_location) - ({untyped = unty1; typed = Ty_ex_c ty1; _} : a ty_node) + let pair_ty (type a b) ({untyped = unty1; typed = Ty_ex_c ty1; _} : a ty_node) ({untyped = unty2; typed = Ty_ex_c ty2; _} : b ty_node) : (a * b) ty_node tzresult = let open Result_syntax in let+ pair_t = Script_typed_ir.pair_t loc ty1 ty2 in - {untyped = prim ~loc Script.T_pair [unty1; unty2]; typed = pair_t} + {untyped = prim Script.T_pair [unty1; unty2]; typed = pair_t} + + let or_ty (type l r) ({untyped = untyl; typed = Ty_ex_c tyl; _} : l ty_node) + ({untyped = untyr; typed = Ty_ex_c tyr; _} : r ty_node) : + (l, r) or_ ty_node tzresult = + let open Result_syntax in + let+ typed = Script_typed_ir.or_t loc tyl tyr in + {untyped = prim Script.T_or [untyl; untyr]; typed} + + (** Entrypoints combinator *) + + (* The combinators will build the `or-tree` with the correct entrypoints representation. *) + + (** Generates the leaf of the entrypoint tree, i.e. an entrypoint. *) + let make_entrypoint_leaf (type t) name ({untyped; typed} : t ty_node) = + let open Result_syntax in + let untyped = + match untyped with + | Prim (loc, prim, args, annot) -> + Prim (loc, prim, args, ("%" ^ name) :: annot) + | untyped -> untyped + in + let* name = Entrypoint.of_string_strict ~loc name in + let at_node = Some {name; original_type_expr = untyped} in + return ({typed; untyped}, {at_node; nested = Entrypoints_None}) + + (** Generates a `or` node out of two entrypoints. *) + let make_entrypoint_node (type left right) + ((left_ty, left_etp) : left ty_node * left entrypoints_node) + ((right_ty, right_etp) : right ty_node * right entrypoints_node) = + let open Result_syntax in + let* node_ty = or_ty left_ty right_ty in + let entrypoints = Entrypoints_Or {left = left_etp; right = right_etp} in + return (node_ty, {at_node = None; nested = entrypoints}) + + (** Generate the entrypoints representation for contract that don't have + entrypoint. *) + let finalize_no_entrypoint (type t) (ty : t ty_node) = + ( ty, + { + root = {at_node = None; nested = Entrypoints_None}; + original_type_expr = ty.untyped; + } ) + + (** Once the entrypoints tree has been built, simply generate the + `entrypoints` type out of it. *) + let finalize_entrypoint (type t) + ((ty, entrypoint) : t ty_node * t entrypoints_node) = + (ty, {root = entrypoint; original_type_expr = ty.untyped}) end module CLST_types = struct @@ -48,7 +96,8 @@ module CLST_types = struct type storage = unit - let arg_type : arg ty_node = unit_ty () + let arg_type : arg ty_node * arg entrypoints = + finalize_no_entrypoint (unit_ty ()) let storage_type : storage ty_node = unit_ty () end @@ -65,14 +114,11 @@ let get_typed_kind_and_types = let open Result_syntax in function | Script_native_repr.CLST -> - let {typed = Ty_ex_c arg_type; untyped} = CLST_types.arg_type in - let {typed = Ty_ex_c storage_type; _} = CLST_types.storage_type in - (* The entrypoints will be introduced in a later MR (!19584). *) - let entrypoints = - { - root = {at_node = None; nested = Entrypoints_None}; - original_type_expr = untyped; - } + let {typed = Ty_ex_c arg_type; untyped = _}, entrypoints = + CLST_types.arg_type + in + let {typed = Ty_ex_c storage_type; untyped = _} = + CLST_types.storage_type in return (Ex_kind_and_types (CLST_kind, {arg_type; storage_type; entrypoints})) @@ -87,7 +133,8 @@ module Internal_for_tests = struct typed : 'a ty_ex_c; } - type ('arg, 'storage) tys = 'arg Helpers.ty_node * 'storage Helpers.ty_node + type ('arg, 'storage) tys = + 'arg Helpers.ty_node * 'arg entrypoints * 'storage Helpers.ty_node type ex_ty_node = Ex : ('arg, 'storage) tys -> ex_ty_node @@ -95,7 +142,7 @@ module Internal_for_tests = struct let open Result_syntax in function | Script_native_repr.CLST -> - let arg_type = CLST_types.arg_type in + let arg_type, arg_entrypoints = CLST_types.arg_type in let storage_type = CLST_types.storage_type in - return (Ex (arg_type, storage_type)) + return (Ex (arg_type, arg_entrypoints, storage_type)) end diff --git a/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml b/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml index 9127f999edfd..c493657a0c1f 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml @@ -31,7 +31,19 @@ let test_unparse_ty loc ctxt expected ty = ty in if actual = expected then Ok ctxt - else Alcotest.failf "Unexpected error: %s" loc + else Alcotest.failf "Unexpected error: unparsing %s" loc + +let test_unparse_parameter_ty ctxt expected ty entrypoints = + let open Result_syntax in + let* actual, ctxt = + Script_ir_unparser.unparse_parameter_ty + ctxt + ~loc:Environment.Micheline.dummy_location + ty + ~entrypoints + in + if actual = expected then Ok ctxt + else Alcotest.failf "Unexpected error: unparsing parameter" let location = function | Environment.Micheline.Prim (loc, _, _, _) @@ -41,6 +53,28 @@ let location = function | Seq (loc, _) -> loc +let test_parse_parameter_ty (type exp expc) ctxt node + (expected : (exp, expc) Script_typed_ir.ty) = + let open Result_wrap_syntax in + let@ result = + let* Ex_parameter_ty_and_entrypoints {arg_type; entrypoints = _}, ctxt = + Script_ir_translator.parse_parameter_ty_and_entrypoints + ctxt + ~legacy:true + node + in + let* eq, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.ty_eq + ~error_details:(Informative (location node)) + arg_type + expected + in + let+ Eq = eq in + ctxt + in + result + let test_parse_ty (type exp expc) ctxt node (expected : (exp, expc) Script_typed_ir.ty) = let open Result_wrap_syntax in @@ -84,6 +118,7 @@ let test_native_contract_types kind () = untyped = untyped_parameter_type; typed = Script_typed_ir.Ty_ex_c parameter_type; }, + parameter_entrypoints, { untyped = untyped_storage_type; typed = Script_typed_ir.Ty_ex_c storage_type; @@ -91,9 +126,15 @@ let test_native_contract_types kind () = Script_native_types.Internal_for_tests.types_of_kind kind in let*?@ ctxt = - test_unparse_ty "parameter" ctxt untyped_parameter_type parameter_type + test_unparse_parameter_ty + ctxt + untyped_parameter_type + parameter_type + parameter_entrypoints + in + let*? ctxt = + test_parse_parameter_ty ctxt untyped_parameter_type parameter_type in - let*? ctxt = test_parse_ty ctxt untyped_parameter_type parameter_type in let*?@ ctxt = test_unparse_ty "storage" ctxt untyped_storage_type storage_type in -- GitLab From 4c96beda69fafc7f96792b8665b183407f2e6298 Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Tue, 18 Nov 2025 10:48:23 +0100 Subject: [PATCH 2/7] Proto/CLST: ledger storage Co-authored-by: Marina Polubelova --- .../lib_protocol/script_native_repr.ml | 5 ++-- .../lib_protocol/script_native_types.ml | 29 ++++++++++++++++--- .../lib_protocol/script_native_types.mli | 9 ++++-- .../test/unit/test_native_contracts.ml | 8 +---- 4 files changed, 35 insertions(+), 16 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_native_repr.ml b/src/proto_alpha/lib_protocol/script_native_repr.ml index 9dc853a79844..ded04889b2ab 100644 --- a/src/proto_alpha/lib_protocol/script_native_repr.ml +++ b/src/proto_alpha/lib_protocol/script_native_repr.ml @@ -11,9 +11,8 @@ type with_storage = {kind : t; storage : Script_repr.lazy_expr} module CLST_contract = struct let initial_storage = - Micheline.( - Prim (dummy_location, Michelson_v1_primitives.D_Unit, [], []) - |> strip_locations |> Script_repr.lazy_expr) + Micheline.(Seq (dummy_location, [])) + |> Micheline.strip_locations |> Script_repr.lazy_expr let with_initial_storage = {kind = CLST; storage = initial_storage} end diff --git a/src/proto_alpha/lib_protocol/script_native_types.ml b/src/proto_alpha/lib_protocol/script_native_types.ml index 21be4424c54d..2c97180ce451 100644 --- a/src/proto_alpha/lib_protocol/script_native_types.ml +++ b/src/proto_alpha/lib_protocol/script_native_types.ml @@ -33,6 +33,23 @@ module Helpers = struct let int_ty () = {untyped = prim Script.T_int []; typed = Ty_ex_c int_t} + let nat_ty () = {untyped = prim Script.T_nat []; typed = Ty_ex_c nat_t} + + let address_ty () = + {untyped = prim Script.T_address []; typed = Ty_ex_c address_t} + + let address_big_map_ty (type value) + ({untyped = unty_value; typed = Ty_ex_c ty_value; _} : value ty_node) : + (address, value) big_map ty_node tzresult = + let open Result_syntax in + let* big_map_t : ((address, value) big_map, _) ty = + big_map_t loc address_t ty_value + in + let untyped_big_map = + prim Script.T_big_map [(address_ty ()).untyped; unty_value] + in + return {untyped = untyped_big_map; typed = Ty_ex_c big_map_t} + let pair_ty (type a b) ({untyped = unty1; typed = Ty_ex_c ty1; _} : a ty_node) ({untyped = unty2; typed = Ty_ex_c ty2; _} : b ty_node) : (a * b) ty_node tzresult = @@ -92,14 +109,18 @@ end module CLST_types = struct open Helpers + type nat = Script_int.n Script_int.num + type arg = unit - type storage = unit + type ledger = (address, nat) big_map + + type storage = ledger let arg_type : arg ty_node * arg entrypoints = finalize_no_entrypoint (unit_ty ()) - let storage_type : storage ty_node = unit_ty () + let storage_type : storage ty_node tzresult = address_big_map_ty (nat_ty ()) end type ('arg, 'storage) kind = @@ -117,7 +138,7 @@ let get_typed_kind_and_types = let {typed = Ty_ex_c arg_type; untyped = _}, entrypoints = CLST_types.arg_type in - let {typed = Ty_ex_c storage_type; untyped = _} = + let* {typed = Ty_ex_c storage_type; untyped = _} = CLST_types.storage_type in return @@ -143,6 +164,6 @@ module Internal_for_tests = struct function | Script_native_repr.CLST -> let arg_type, arg_entrypoints = CLST_types.arg_type in - let storage_type = CLST_types.storage_type in + let* storage_type = CLST_types.storage_type in return (Ex (arg_type, arg_entrypoints, storage_type)) end diff --git a/src/proto_alpha/lib_protocol/script_native_types.mli b/src/proto_alpha/lib_protocol/script_native_types.mli index 3ab65a995701..2f752c2fe862 100644 --- a/src/proto_alpha/lib_protocol/script_native_types.mli +++ b/src/proto_alpha/lib_protocol/script_native_types.mli @@ -8,12 +8,17 @@ (** Native contracts types declaration and combinators. *) open Alpha_context +open Script_typed_ir (** Types declaration of CLST contracts (entrypoints and storage). *) module CLST_types : sig + type nat = Script_int.n Script_int.num + type arg = unit - type storage = unit + type ledger = (address, nat) big_map + + type storage = ledger end (** Typed equivalent of `Script_native_repr.kind` *) @@ -38,7 +43,7 @@ module Internal_for_tests : sig typed : 'ty Script_typed_ir.ty_ex_c; } - type ('arg, 'storage) tys = 'arg ty_node * 'storage ty_node + type ('arg, 'storage) tys = 'arg ty_node * 'arg entrypoints * 'storage ty_node type ex_ty_node = Ex : ('arg, 'storage) tys -> ex_ty_node diff --git a/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml b/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml index c493657a0c1f..1c3f4b3a38aa 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml @@ -235,10 +235,4 @@ let () = (test_native_contract_types Script.CLST) ; register_test ~title:"Check parsing native contract" - (test_parse_contract Script.CLST Script_native_types.CLST_kind) ; - register_test - ~title:"Check executing native contract" - (test_call_native_contract - Script.CLST - (strip_location unit_param) - (strip_location unit_param)) + (test_parse_contract Script.CLST Script_native_types.CLST_kind) -- GitLab From 5ac4fc4a2a79d14f45da69d86e8ffabf3f3131c2 Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Tue, 18 Nov 2025 11:44:01 +0100 Subject: [PATCH 3/7] Proto/CLST: deposit entrypoint Co-authored-by: Marina Polubelova --- src/proto_alpha/lib_protocol/script_native.ml | 25 +++++++++++++++++-- .../lib_protocol/script_native_types.ml | 17 +++++++++---- .../lib_protocol/script_native_types.mli | 4 ++- 3 files changed, 38 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_native.ml b/src/proto_alpha/lib_protocol/script_native.ml index 3424cdd45da1..a1e156eedea2 100644 --- a/src/proto_alpha/lib_protocol/script_native.ml +++ b/src/proto_alpha/lib_protocol/script_native.ml @@ -12,8 +12,29 @@ open Script_typed_ir module CLST_contract = struct open Script_native_types.CLST_types - let execute (ctxt, _) (_value : arg) (storage : storage) = - Lwt_result_syntax.return ((Script_list.empty, storage), ctxt) + let execute_deposit (ctxt, (step_constants : Script_typed_ir.step_constants)) + (() : deposit) (ledger : storage) : + ((operation Script_list.t, storage) pair * context) tzresult Lwt.t = + let open Lwt_result_syntax in + let address = + {destination = step_constants.sender; entrypoint = Entrypoint.default} + in + let* amount_opt, ctxt = Script_big_map.get ctxt address ledger in + let added_amount = + Tez.to_mutez step_constants.amount + |> Script_int.of_int64 |> Script_int.abs + in + let new_amount = + Script_int.(add_n added_amount (Option.value ~default:zero_n amount_opt)) + in + let* new_ledger, ctxt = + Script_big_map.update ctxt address (Some new_amount) ledger + in + return ((Script_list.empty, new_ledger), ctxt) + + let execute (ctxt, (step_constants : step_constants)) (value : arg) + (storage : storage) = + execute_deposit (ctxt, step_constants) value storage end let execute (type arg storage) (ctxt, step_constants) diff --git a/src/proto_alpha/lib_protocol/script_native_types.ml b/src/proto_alpha/lib_protocol/script_native_types.ml index 2c97180ce451..9402d028ea0c 100644 --- a/src/proto_alpha/lib_protocol/script_native_types.ml +++ b/src/proto_alpha/lib_protocol/script_native_types.ml @@ -111,14 +111,21 @@ module CLST_types = struct type nat = Script_int.n Script_int.num - type arg = unit + type deposit = unit + + type arg = deposit type ledger = (address, nat) big_map type storage = ledger - let arg_type : arg ty_node * arg entrypoints = - finalize_no_entrypoint (unit_ty ()) + let deposit_type : (deposit ty_node * deposit entrypoints_node) tzresult = + make_entrypoint_leaf "deposit" (unit_ty ()) + + let arg_type : (arg ty_node * arg entrypoints) tzresult = + let open Result_syntax in + let* deposit_type = deposit_type in + return (finalize_entrypoint deposit_type) let storage_type : storage ty_node tzresult = address_big_map_ty (nat_ty ()) end @@ -135,7 +142,7 @@ let get_typed_kind_and_types = let open Result_syntax in function | Script_native_repr.CLST -> - let {typed = Ty_ex_c arg_type; untyped = _}, entrypoints = + let* {typed = Ty_ex_c arg_type; untyped = _}, entrypoints = CLST_types.arg_type in let* {typed = Ty_ex_c storage_type; untyped = _} = @@ -163,7 +170,7 @@ module Internal_for_tests = struct let open Result_syntax in function | Script_native_repr.CLST -> - let arg_type, arg_entrypoints = CLST_types.arg_type in + let* arg_type, arg_entrypoints = CLST_types.arg_type in let* storage_type = CLST_types.storage_type in return (Ex (arg_type, arg_entrypoints, storage_type)) end diff --git a/src/proto_alpha/lib_protocol/script_native_types.mli b/src/proto_alpha/lib_protocol/script_native_types.mli index 2f752c2fe862..c53d5e19b273 100644 --- a/src/proto_alpha/lib_protocol/script_native_types.mli +++ b/src/proto_alpha/lib_protocol/script_native_types.mli @@ -14,7 +14,9 @@ open Script_typed_ir module CLST_types : sig type nat = Script_int.n Script_int.num - type arg = unit + type deposit = unit + + type arg = deposit type ledger = (address, nat) big_map -- GitLab From 4181ff6e75bf8a37906d7961bf9c10c9de20ebec Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Mon, 24 Nov 2025 11:32:27 +0100 Subject: [PATCH 4/7] Proto/CLST: helpers to retrieve the storage and read the balance --- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 1 + src/proto_alpha/lib_protocol/clst_storage.ml | 61 +++++++++++++++++++ src/proto_alpha/lib_protocol/clst_storage.mli | 40 ++++++++++++ src/proto_alpha/lib_protocol/dune | 4 ++ src/proto_alpha/lib_protocol/script_native.ml | 12 ++-- 5 files changed, 112 insertions(+), 6 deletions(-) create mode 100644 src/proto_alpha/lib_protocol/clst_storage.ml create mode 100644 src/proto_alpha/lib_protocol/clst_storage.mli diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index cd5ab26f0369..962a509eb08d 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -274,6 +274,7 @@ "Ticket_accounting", "Ticket_transfer", + "Clst_storage", "Script_native", "Script_interpreter_defs", "Script_interpreter", diff --git a/src/proto_alpha/lib_protocol/clst_storage.ml b/src/proto_alpha/lib_protocol/clst_storage.ml new file mode 100644 index 000000000000..f49817cd2f5c --- /dev/null +++ b/src/proto_alpha/lib_protocol/clst_storage.ml @@ -0,0 +1,61 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2025 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script_native_types +open Script_typed_ir + +let get_storage ctxt = + let open Lwt_result_syntax in + let* clst_contract_hash = Contract.get_clst_contract_hash ctxt in + let* ctxt, clst_storage = Contract.get_storage ctxt clst_contract_hash in + let identity : Alpha_context.t -> CLST_types.storage -> 'a = + fun ctxt storage -> return (Some storage, ctxt) + in + match clst_storage with + | Some clst_storage -> + let*? (Ex_kind_and_types (CLST_kind, {storage_type; _})) = + Script_native_types.get_typed_kind_and_types Script_native_repr.CLST + in + let elab_conf = Script_ir_translator_config.make ~legacy:true () in + let* storage, ctxt = + Script_ir_translator.parse_storage + ~elab_conf + ctxt + ~allow_forged_tickets:true + ~allow_forged_lazy_storage_id:true + storage_type + ~storage:(Script.lazy_expr clst_storage) + in + (* `parse_storage`'s result cannot be retrieved as is, as it will yield a + GADT error (basically the storage escaping its scope, due to + `Ex_kind_and_types`). As such we return the storage through an identity + function. Thanks @lrand for the trick. *) + identity ctxt storage + | None -> return (None, ctxt) + +let get_balance_from_storage ctxt storage contract = + let open Lwt_result_syntax in + let* balance, ctxt = Script_big_map.get ctxt contract storage in + return (Option.value balance ~default:Script_int.zero_n, ctxt) + +let get_balance ctxt contract = + let open Lwt_result_syntax in + let contract = + Script_typed_ir. + { + destination = Destination.Contract contract; + entrypoint = Entrypoint.default; + } + in + let* storage_opt, ctxt = get_storage ctxt in + match storage_opt with + | Some storage -> get_balance_from_storage ctxt storage contract + | None -> return (Script_int.zero_n, ctxt) + +let set_balance_from_storage ctxt storage contract amount = + Script_big_map.update ctxt contract (Some amount) storage diff --git a/src/proto_alpha/lib_protocol/clst_storage.mli b/src/proto_alpha/lib_protocol/clst_storage.mli new file mode 100644 index 000000000000..6e8fd8909501 --- /dev/null +++ b/src/proto_alpha/lib_protocol/clst_storage.mli @@ -0,0 +1,40 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2025 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +open Alpha_context +open Script_native_types +open Script_typed_ir + +(** [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. *) +val get_storage : + context -> (CLST_types.storage option * context) tzresult Lwt.t + +(** [get_balance_from_storage ctxt storage address] returns the balance from the + given address, extracted from the CLST contract's storage. Returns `zero_n` + if no balance has been found, following FA2.1 specification. *) +val get_balance_from_storage : + context -> + CLST_types.storage -> + address -> + (CLST_types.nat * context) tzresult Lwt.t + +(** [get_balance context contract] retrieves the balance of a given contract on + the CLST contract. This is a combination of `get_storage` and + `get_balance_from_storage`. *) +val get_balance : + context -> Contract.t -> (CLST_types.nat * context) tzresult Lwt.t + +(** [set_balance_from_storage ctxt storage address amount] updates the balance of the + given address to [amount]. *) +val set_balance_from_storage : + context -> + CLST_types.storage -> + address -> + CLST_types.nat -> + (CLST_types.storage * context) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index 91d4bf6c99cf..85500afa762f 100644 --- a/src/proto_alpha/lib_protocol/dune +++ b/src/proto_alpha/lib_protocol/dune @@ -280,6 +280,7 @@ Ticket_operations_diff Ticket_accounting Ticket_transfer + Clst_storage Script_native Script_interpreter_defs Script_interpreter @@ -583,6 +584,7 @@ ticket_operations_diff.ml ticket_operations_diff.mli ticket_accounting.ml ticket_accounting.mli ticket_transfer.ml ticket_transfer.mli + clst_storage.ml clst_storage.mli script_native.ml script_native.mli script_interpreter_defs.ml script_interpreter.ml script_interpreter.mli @@ -887,6 +889,7 @@ ticket_operations_diff.ml ticket_operations_diff.mli ticket_accounting.ml ticket_accounting.mli ticket_transfer.ml ticket_transfer.mli + clst_storage.ml clst_storage.mli script_native.ml script_native.mli script_interpreter_defs.ml script_interpreter.ml script_interpreter.mli @@ -1175,6 +1178,7 @@ ticket_operations_diff.ml ticket_operations_diff.mli ticket_accounting.ml ticket_accounting.mli ticket_transfer.ml ticket_transfer.mli + clst_storage.ml clst_storage.mli script_native.ml script_native.mli script_interpreter_defs.ml script_interpreter.ml script_interpreter.mli diff --git a/src/proto_alpha/lib_protocol/script_native.ml b/src/proto_alpha/lib_protocol/script_native.ml index a1e156eedea2..a4d3110ea14b 100644 --- a/src/proto_alpha/lib_protocol/script_native.ml +++ b/src/proto_alpha/lib_protocol/script_native.ml @@ -13,22 +13,22 @@ module CLST_contract = struct open Script_native_types.CLST_types let execute_deposit (ctxt, (step_constants : Script_typed_ir.step_constants)) - (() : deposit) (ledger : storage) : + (() : deposit) (storage : storage) : ((operation Script_list.t, storage) pair * context) tzresult Lwt.t = let open Lwt_result_syntax in let address = {destination = step_constants.sender; entrypoint = Entrypoint.default} in - let* amount_opt, ctxt = Script_big_map.get ctxt address ledger in + let* amount, ctxt = + Clst_storage.get_balance_from_storage ctxt storage address + in let added_amount = Tez.to_mutez step_constants.amount |> Script_int.of_int64 |> Script_int.abs in - let new_amount = - Script_int.(add_n added_amount (Option.value ~default:zero_n amount_opt)) - in + let new_amount = Script_int.(add_n added_amount amount) in let* new_ledger, ctxt = - Script_big_map.update ctxt address (Some new_amount) ledger + Script_big_map.update ctxt address (Some new_amount) storage in return ((Script_list.empty, new_ledger), ctxt) -- GitLab From da1679191af1515927ccecead8146c773bdcebbb Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Tue, 18 Nov 2025 14:45:57 +0100 Subject: [PATCH 5/7] Proto/Plugin: RPC clstz_balance Co-authored-by: Marina Polubelova --- .../lib_plugin/contract_services.ml | 23 ++++++++++++++++++- .../lib_plugin/contract_services.mli | 6 +++++ src/proto_alpha/lib_protocol/alpha_context.ml | 6 ++--- .../lib_protocol/alpha_context.mli | 6 ++--- .../test/integration/test_native_contracts.ml | 12 +++------- .../test/unit/test_native_contracts.ml | 8 ++----- 6 files changed, 39 insertions(+), 22 deletions(-) diff --git a/src/proto_alpha/lib_plugin/contract_services.ml b/src/proto_alpha/lib_plugin/contract_services.ml index cebe731db402..b18585e05d3c 100644 --- a/src/proto_alpha/lib_plugin/contract_services.ml +++ b/src/proto_alpha/lib_plugin/contract_services.ml @@ -388,6 +388,23 @@ module S = struct let mk_call1 (service, _f) ctxt block id q = RPC_context.make_call1 service ctxt block id q () end + + module CLST = struct + let balance_service = + RPC_service.get_service + ~description: + "Returns the CLST balance of a contract. Returns 0 if the contract \ + is originated or does not hold any CLST token." + ~query:RPC_query.empty + ~output:Script_int.n_encoding + RPC_path.(custom_root /: Contract.rpc_arg / "clst_balance") + + let register_balance () = + register1 ~chunked:false balance_service (fun ctxt contract () () -> + let open Lwt_result_syntax in + let* balance, _ = Clst_storage.get_balance ctxt contract in + return balance) + end end module Implem = struct @@ -790,7 +807,8 @@ let register () = (fun ctxt contract () () -> Contract.For_RPC.get_estimated_own_pending_slashed_amount ctxt contract) ; - S.Sapling.register () + S.Sapling.register () ; + S.CLST.register_balance () let list ctxt block = RPC_context.make_call0 S.list ctxt block () () @@ -901,3 +919,6 @@ let single_sapling_get_diff ctxt block id ?offset_commitment ?offset_nullifier block (Contract.Originated id) Sapling_services.{offset_commitment; offset_nullifier} + +let clst_balance ctxt block contract = + RPC_context.make_call1 S.CLST.balance_service ctxt block contract () () diff --git a/src/proto_alpha/lib_plugin/contract_services.mli b/src/proto_alpha/lib_plugin/contract_services.mli index 039cd04cd698..dda794586b34 100644 --- a/src/proto_alpha/lib_plugin/contract_services.mli +++ b/src/proto_alpha/lib_plugin/contract_services.mli @@ -188,6 +188,12 @@ val single_sapling_get_diff : unit -> (Sapling.root * Sapling.diff) shell_tzresult Lwt.t +val clst_balance : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + Script_int.n Script_int.num shell_tzresult Lwt.t + val register : unit -> unit (** Functions used in the implementation of this file's RPCs, but also diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 2990d4f5c589..4483ea59b0a3 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -469,6 +469,9 @@ module Contract = struct let get_delegate_status = Contract_delegate_storage.get_delegate_status + let get_clst_contract_hash ctxt = + Storage.Contract.Native_contracts.CLST.get ctxt + module For_RPC = struct include Contract_storage.For_RPC include Delegate_slashed_deposits_storage.For_RPC @@ -483,9 +486,6 @@ module Contract = struct module Internal_for_tests = struct include Contract_repr include Contract_storage - - let get_clst_contract_hash ctxt = - Storage.Contract.Native_contracts.CLST.get ctxt end end diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 418391a21e13..346352993754 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1888,6 +1888,9 @@ module Contract : sig val get_total_supply : context -> Tez.t tzresult Lwt.t + val get_clst_contract_hash : + context -> (Contract_hash.t, error trace) result Lwt.t + module Legacy_big_map_diff : sig type item = private | Update of { @@ -1928,9 +1931,6 @@ module Contract : sig val originated_contract : Origination_nonce.Internal_for_tests.t -> t val paid_storage_space : context -> t -> Z.t tzresult Lwt.t - - val get_clst_contract_hash : - context -> (Contract_hash.t, error trace) result Lwt.t end (** Functions used exclusively for RPC calls *) diff --git a/src/proto_alpha/lib_protocol/test/integration/test_native_contracts.ml b/src/proto_alpha/lib_protocol/test/integration/test_native_contracts.ml index f6b163878601..5c47e0ce86da 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_native_contracts.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_native_contracts.ml @@ -30,9 +30,7 @@ let test_mainnet_context () = let test_feature_flag_enabled () = let open Lwt_result_wrap_syntax in let* ctxt = test_context ~enable_feature:true () in - let*! hash = - Alpha_context.Contract.Internal_for_tests.get_clst_contract_hash ctxt - in + let*! hash = Alpha_context.Contract.get_clst_contract_hash ctxt in match hash with | Ok _ -> return_unit | Error _ -> @@ -43,9 +41,7 @@ let test_feature_flag_enabled () = let test_feature_flag_disabled () = let open Lwt_result_wrap_syntax in let* ctxt = test_context ~enable_feature:false () in - let*!@ hash = - Alpha_context.Contract.Internal_for_tests.get_clst_contract_hash ctxt - in + let*!@ hash = Alpha_context.Contract.get_clst_contract_hash ctxt in Assert.proto_error ~loc:__LOC__ hash (function | Raw_context.Storage_error (Missing_key (_, Raw_context.Get)) -> true | _ -> false) @@ -53,9 +49,7 @@ let test_feature_flag_disabled () = let test_feature_flag_disabled_on_mainnet () = let open Lwt_result_wrap_syntax in let* ctxt = test_mainnet_context () in - let*!@ hash = - Alpha_context.Contract.Internal_for_tests.get_clst_contract_hash ctxt - in + let*!@ hash = Alpha_context.Contract.get_clst_contract_hash ctxt in Assert.proto_error ~loc:__LOC__ hash (function | Raw_context.Storage_error (Missing_key (_, Raw_context.Get)) -> true | _ -> false) diff --git a/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml b/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml index 1c3f4b3a38aa..e9d7a3868c40 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_native_contracts.ml @@ -175,9 +175,7 @@ let check_parse_contract ctxt kind_with_storage expected_kind = let test_parse_contract kind expected_kind () = let open Lwt_result_wrap_syntax in let* ctxt = test_context () in - let*@ contract_hash = - Contract.Internal_for_tests.get_clst_contract_hash ctxt - in + let*@ contract_hash = Contract.get_clst_contract_hash ctxt in let* kind_with_storage, _ = get_native_contract ctxt contract_hash kind in check_parse_contract ctxt kind_with_storage expected_kind @@ -200,9 +198,7 @@ let execute_native_contract ctxt contract_hash kind parameter = let test_call_native_contract kind parameter expected_storage () = let open Lwt_result_wrap_syntax in let* ctxt = test_context () in - let*@ contract_hash = - Contract.Internal_for_tests.get_clst_contract_hash ctxt - in + let*@ contract_hash = Contract.get_clst_contract_hash ctxt in let* res, _ctxt = execute_native_contract ctxt contract_hash kind parameter in if res.storage <> expected_storage then Test.fail "Unexpected storage" ; return_unit -- GitLab From 0bc782ad4692dc67f66d33f024cf2e02916cb320 Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Tue, 18 Nov 2025 17:30:24 +0100 Subject: [PATCH 6/7] Proto/Test: test depositing to CLST Co-authored-by: Marina Polubelova --- manifest/product_octez.ml | 1 + .../lib_protocol/test/helpers/op.ml | 17 ++++++++ .../lib_protocol/test/helpers/op.mli | 13 ++++++ .../lib_protocol/test/integration/dune | 3 +- .../test/integration/test_clst.ml | 42 +++++++++++++++++++ 5 files changed, 75 insertions(+), 1 deletion(-) create mode 100644 src/proto_alpha/lib_protocol/test/integration/test_clst.ml diff --git a/manifest/product_octez.ml b/manifest/product_octez.ml index da4c45fc390e..a97ccb5e9889 100644 --- a/manifest/product_octez.ml +++ b/manifest/product_octez.ml @@ -6449,6 +6449,7 @@ end = struct ("test_storage", true); ("test_token", true); ("test_native_contracts", N.(number >= 025)); + ("test_clst", N.(number >= 025)); ] |> conditional_list in diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index 144df38520e5..4ea36fc0b842 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -1566,3 +1566,20 @@ let set_op_signature op new_signature = let copy_op_signature ~src ~dst = let signature = get_op_signature src in set_op_signature dst signature + +let clst_deposit ?force_reveal ?counter ?fee ?gas_limit ?storage_limit + (ctxt : Context.t) (src : Contract.t) (amount : Tez.t) = + let open Lwt_result_wrap_syntax in + let* alpha_ctxt = Context.get_alpha_ctxt ctxt in + let*@ clst_hash = Contract.get_clst_contract_hash alpha_ctxt in + unsafe_transaction + ?force_reveal + ?counter + ?fee + ?gas_limit + ?storage_limit + ~entrypoint:(Entrypoint.of_string_strict_exn "deposit") + ctxt + src + (Contract.Originated clst_hash) + amount diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.mli b/src/proto_alpha/lib_protocol/test/helpers/op.mli index 6db4de48ecbd..03eaab56c058 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/op.mli @@ -904,3 +904,16 @@ val get_op_signature : t -> signature option val set_op_signature : t -> signature option -> t val copy_op_signature : src:t -> dst:t -> t + +(** [clst_deposit ctxt src amount] returns a deposit operation of [amount] tez + on the CLST contract. *) +val clst_deposit : + ?force_reveal:bool -> + ?counter:Manager_counter.t -> + ?fee:Tez.t -> + ?gas_limit:gas_limit -> + ?storage_limit:Z.t -> + Context.t -> + Contract.t -> + Tez.t -> + Operation.packed tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/integration/dune b/src/proto_alpha/lib_protocol/test/integration/dune index 010bc039ccc6..6e0fe85d7478 100644 --- a/src/proto_alpha/lib_protocol/test/integration/dune +++ b/src/proto_alpha/lib_protocol/test/integration/dune @@ -40,7 +40,8 @@ test_storage_functions test_storage test_token - test_native_contracts)) + test_native_contracts + test_clst)) (executable (name main) diff --git a/src/proto_alpha/lib_protocol/test/integration/test_clst.ml b/src/proto_alpha/lib_protocol/test/integration/test_clst.ml new file mode 100644 index 000000000000..03668acbd41e --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/test_clst.ml @@ -0,0 +1,42 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2025 Nomadic Labs, *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol (CLST) + Invocation: dune exec src/proto_alpha/lib_protocol/test/integration/main.exe \ + -- --file test_clst.ml + Subject: CLST contract +*) + +open Protocol +open Alpha_context + +let register_test ~title = + Tezt_helpers.register_test_es + ~__FILE__ + ~file_tags:["clst"] + ~title:("CLST: " ^ title) + +let test_deposit = + register_test ~title:"Test deposit of a non null amount" @@ fun () -> + let open Lwt_result_wrap_syntax in + let* b, sender = Context.init1 () in + let amount = Tez.of_mutez_exn 100000000L in + let* deposit_tx = Op.clst_deposit (Context.B b) sender amount in + let* b = Block.bake ~operation:deposit_tx b in + let* balance = + Plugin.Contract_services.clst_balance Block.rpc_ctxt b sender + in + let amount = Tez.to_mutez amount in + let balance = + Option.value_f + ~default:(fun () -> assert false) + (Script_int.to_int64 balance) + in + Check.((amount = balance) int64 ~error_msg:"Expected %L, got %R") ; + return_unit -- GitLab From 78e8b71f88a2a09774fdfb1c4fc5bfc95c472f2b Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Wed, 26 Nov 2025 14:27:39 +0100 Subject: [PATCH 7/7] Proto/CLST: forbid empty deposits --- src/proto_alpha/lib_protocol/script_native.ml | 15 +++++++++++++++ src/proto_alpha/lib_protocol/script_native.mli | 4 ++++ .../lib_protocol/test/helpers/error_helpers.ml | 9 +++++++++ .../lib_protocol/test/integration/test_clst.ml | 12 ++++++++++++ 4 files changed, 40 insertions(+) diff --git a/src/proto_alpha/lib_protocol/script_native.ml b/src/proto_alpha/lib_protocol/script_native.ml index a4d3110ea14b..01d1cf65df41 100644 --- a/src/proto_alpha/lib_protocol/script_native.ml +++ b/src/proto_alpha/lib_protocol/script_native.ml @@ -12,10 +12,13 @@ open Script_typed_ir module CLST_contract = struct open Script_native_types.CLST_types + type error += Empty_deposit + let execute_deposit (ctxt, (step_constants : Script_typed_ir.step_constants)) (() : deposit) (storage : storage) : ((operation Script_list.t, storage) pair * context) tzresult Lwt.t = let open Lwt_result_syntax in + let*? () = error_when Tez.(step_constants.amount = zero) Empty_deposit in let address = {destination = step_constants.sender; entrypoint = Entrypoint.default} in @@ -43,3 +46,15 @@ let execute (type arg storage) (ctxt, step_constants) Lwt.t = match kind with | CLST_kind -> CLST_contract.execute (ctxt, step_constants) arg storage + +let () = + register_error_kind + `Branch + ~id:"clst.empty_deposit" + ~title:"Empty deposit" + ~description:"Forbidden to deposit 0ꜩ to CLST contract." + ~pp:(fun ppf () -> + Format.fprintf ppf "Deposit of 0ꜩ on CLST are forbidden.") + Data_encoding.unit + (function CLST_contract.Empty_deposit -> Some () | _ -> None) + (fun () -> CLST_contract.Empty_deposit) diff --git a/src/proto_alpha/lib_protocol/script_native.mli b/src/proto_alpha/lib_protocol/script_native.mli index af2a4b156f52..bf3e8ad62ccc 100644 --- a/src/proto_alpha/lib_protocol/script_native.mli +++ b/src/proto_alpha/lib_protocol/script_native.mli @@ -9,6 +9,10 @@ open Alpha_context open Script_native_types open Script_typed_ir +module CLST_contract : sig + type error += Empty_deposit +end + (* [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/test/helpers/error_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/error_helpers.ml index 15482f1cb176..fa51a6d0801c 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/error_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/error_helpers.ml @@ -230,3 +230,12 @@ let wrong_slot_used_for_attestation = function let missing_companion_key_for_bls_dal = function | Validate_errors.Consensus.Missing_companion_key_for_bls_dal _ -> true | _ -> false + +let expect_clst_empty_deposit ~loc errs = + Assert.expect_error ~loc errs (function + (* CLST is interacted with as a Michelson contract, as such the trace is + always part of the interpreter error trace. *) + | Script_interpreter.Runtime_contract_error _ + :: Script_native.CLST_contract.Empty_deposit :: _ -> + true + | _ -> false) 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 03668acbd41e..c04eca70fc81 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_clst.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_clst.ml @@ -40,3 +40,15 @@ let test_deposit = in Check.((amount = balance) int64 ~error_msg:"Expected %L, got %R") ; return_unit + +let test_deposit_zero = + register_test ~title:"Test depositing 0 tez amount is forbidden" @@ fun () -> + let open Lwt_result_wrap_syntax in + let* b, sender = Context.init1 () in + let amount = Tez.of_mutez_exn 0L in + let* deposit_tx = Op.clst_deposit (Context.B b) sender amount in + let*! b = Block.bake ~operation:deposit_tx b in + match b with + | Ok _ -> + Test.fail "Empty deposits on CLST are forbidden and expected to fail" + | Error trace -> Error_helpers.expect_clst_empty_deposit ~loc:__LOC__ trace -- GitLab