From 7802101c6fe86a5ab4a7ccc3cddcdbb339783d17 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Tue, 19 Oct 2021 17:21:20 +0200 Subject: [PATCH 01/28] Proto: add Entrypoint module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 1 + src/proto_alpha/lib_protocol/alpha_context.ml | 1 + .../lib_protocol/alpha_context.mli | 2 ++ src/proto_alpha/lib_protocol/dune.inc | 5 ++++ .../lib_protocol/entrypoint_repr.ml | 24 +++++++++++++++++++ .../lib_protocol/entrypoint_repr.mli | 24 +++++++++++++++++++ 6 files changed, 57 insertions(+) create mode 100644 src/proto_alpha/lib_protocol/entrypoint_repr.ml create mode 100644 src/proto_alpha/lib_protocol/entrypoint_repr.mli diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index ff740bead3bb..5b465faf904c 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -43,6 +43,7 @@ "Roll_repr_legacy", "Vote_repr", "Block_header_repr", + "Entrypoint_repr", "Operation_repr", "Manager_repr", "Commitment_repr", diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index d12c2727c14f..2307848c39db 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -60,6 +60,7 @@ module Sc_rollup = struct include Sc_rollup_storage end +module Entrypoint = Entrypoint_repr include Operation_repr module Operation = struct diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 01e977d92410..7bfddaa07b46 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -449,6 +449,8 @@ module Gas : sig val cost_of_repr : Gas_limit_repr.cost -> cost end +module Entrypoint : module type of Entrypoint_repr + module Script_string : module type of Script_string_repr module Script_int : module type of Script_int_repr diff --git a/src/proto_alpha/lib_protocol/dune.inc b/src/proto_alpha/lib_protocol/dune.inc index b3578652efaf..f5ea20b62fa6 100644 --- a/src/proto_alpha/lib_protocol/dune.inc +++ b/src/proto_alpha/lib_protocol/dune.inc @@ -68,6 +68,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end roll_repr_legacy.mli roll_repr_legacy.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml + entrypoint_repr.mli entrypoint_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml @@ -202,6 +203,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end roll_repr_legacy.mli roll_repr_legacy.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml + entrypoint_repr.mli entrypoint_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml @@ -336,6 +338,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end roll_repr_legacy.mli roll_repr_legacy.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml + entrypoint_repr.mli entrypoint_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml @@ -492,6 +495,7 @@ include Tezos_raw_protocol_alpha.Main Roll_repr_legacy Vote_repr Block_header_repr + Entrypoint_repr Operation_repr Manager_repr Commitment_repr @@ -667,6 +671,7 @@ include Tezos_raw_protocol_alpha.Main roll_repr_legacy.mli roll_repr_legacy.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml + entrypoint_repr.mli entrypoint_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml new file mode 100644 index 000000000000..e92238e979aa --- /dev/null +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -0,0 +1,24 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli new file mode 100644 index 000000000000..e92238e979aa --- /dev/null +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -0,0 +1,24 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) -- GitLab From 7b1a537c76a91cff74a6d136643b862e1ddcb376 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Tue, 19 Oct 2021 18:23:33 +0200 Subject: [PATCH 02/28] Proto: add Entrypoint.t and use it MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- src/proto_alpha/lib_client/client_proto_args.mli | 4 ++-- src/proto_alpha/lib_client/client_proto_context.ml | 2 +- src/proto_alpha/lib_client/client_proto_context.mli | 6 +++--- src/proto_alpha/lib_client/client_proto_fa12.ml | 2 +- src/proto_alpha/lib_client/client_proto_multisig.ml | 11 ++++++----- src/proto_alpha/lib_client/client_proto_multisig.mli | 4 ++-- src/proto_alpha/lib_client/client_proto_programs.ml | 4 ++-- src/proto_alpha/lib_client/client_proto_programs.mli | 8 ++++---- src/proto_alpha/lib_client/managed_contract.mli | 6 +++--- .../lib_client/michelson_v1_entrypoints.mli | 6 +++--- src/proto_alpha/lib_plugin/plugin.ml | 6 +++--- src/proto_alpha/lib_protocol/alpha_context.mli | 2 +- src/proto_alpha/lib_protocol/contract_services.mli | 2 +- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 2 ++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 3 +++ src/proto_alpha/lib_protocol/operation_repr.ml | 2 +- src/proto_alpha/lib_protocol/operation_repr.mli | 2 +- src/proto_alpha/lib_protocol/script_interpreter.mli | 2 +- src/proto_alpha/lib_protocol/script_ir_translator.ml | 9 +++++---- src/proto_alpha/lib_protocol/script_ir_translator.mli | 6 +++--- src/proto_alpha/lib_protocol/script_tc_errors.ml | 4 ++-- src/proto_alpha/lib_protocol/script_typed_ir.ml | 6 +++--- src/proto_alpha/lib_protocol/script_typed_ir.mli | 6 +++--- .../lib_protocol/test/helpers/cpmm_repr.ml | 2 +- src/proto_alpha/lib_protocol/test/helpers/op.mli | 2 +- 25 files changed, 58 insertions(+), 51 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_args.mli b/src/proto_alpha/lib_client/client_proto_args.mli index 3bc4b659fbaf..35dea2912f35 100644 --- a/src/proto_alpha/lib_client/client_proto_args.mli +++ b/src/proto_alpha/lib_client/client_proto_args.mli @@ -54,9 +54,9 @@ val default_arg_arg : (string option, full) Clic.arg val source_arg : (string option, full) Clic.arg -val entrypoint_arg : (string option, full) Clic.arg +val entrypoint_arg : (Entrypoint.t option, full) Clic.arg -val default_entrypoint_arg : (string option, full) Clic.arg +val default_entrypoint_arg : (Entrypoint.t option, full) Clic.arg val delegate_arg : (Signature.Public_key_hash.t option, full) Clic.arg diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index ca8568f80708..6324b12c4e74 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -485,7 +485,7 @@ type batch_transfer_operation = { storage_limit : Z.t option; amount : string; arg : string option; - entrypoint : string option; + entrypoint : Entrypoint.t option; } let batch_transfer_operation_encoding = diff --git a/src/proto_alpha/lib_client/client_proto_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index a07876950e77..1d1895ad6f71 100644 --- a/src/proto_alpha/lib_client/client_proto_context.mli +++ b/src/proto_alpha/lib_client/client_proto_context.mli @@ -193,7 +193,7 @@ val parse_arg_transfer : string option -> Script.lazy_expr tzresult Lwt.t val build_transaction_operation : amount:Tez.t -> parameters:Script.lazy_expr -> - ?entrypoint:string -> + ?entrypoint:Entrypoint.t -> ?fee:Tez.t -> ?gas_limit:Gas.Arith.integral -> ?storage_limit:Z.t -> @@ -213,7 +213,7 @@ val transfer : src_pk:public_key -> src_sk:Client_keys.sk_uri -> destination:Contract.t -> - ?entrypoint:string -> + ?entrypoint:Entrypoint.t -> ?arg:string -> amount:Tez.t -> ?fee:Tez.t -> @@ -267,7 +267,7 @@ type batch_transfer_operation = { storage_limit : Z.t option; amount : string; arg : string option; - entrypoint : string option; + entrypoint : Entrypoint.t option; } val batch_transfer_operation_encoding : batch_transfer_operation Data_encoding.t diff --git a/src/proto_alpha/lib_client/client_proto_fa12.ml b/src/proto_alpha/lib_client/client_proto_fa12.ml index fb7e31dc856b..ec9546e9d863 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.ml +++ b/src/proto_alpha/lib_client/client_proto_fa12.ml @@ -36,7 +36,7 @@ type error += Entrypoint_mismatch of string * (Script.expr * Script.expr) option type error += Action_unwrapping_error of string * Script.expr -type error += Not_a_viewable_entrypoint of string +type error += Not_a_viewable_entrypoint of Entrypoint.t type error += Not_an_entrypoint of Script.expr diff --git a/src/proto_alpha/lib_client/client_proto_multisig.ml b/src/proto_alpha/lib_client/client_proto_multisig.ml index 7ffb4f883006..6e73014211fe 100644 --- a/src/proto_alpha/lib_client/client_proto_multisig.ml +++ b/src/proto_alpha/lib_client/client_proto_multisig.ml @@ -59,7 +59,7 @@ type error += Unsupported_feature_generic_call_ty of Script.expr type error += Unsupported_feature_lambda of string type error += - | Ill_typed_argument of Contract.t * string * Script.expr * Script.expr + | Ill_typed_argument of Contract.t * Entrypoint.t * Script.expr * Script.expr type error += Ill_typed_lambda of Script.expr * Script.expr @@ -472,7 +472,7 @@ type multisig_contract_description = { (* The hash of the contract script *) requires_chain_id : bool; (* The signatures should contain the chain identifier *) - main_entrypoint : string option; + main_entrypoint : Entrypoint.t option; (* name of the main entrypoint of the multisig contract, None means use the default entrypoint *) generic : bool; (* False means that the contract uses a custom action type, true @@ -582,7 +582,8 @@ let optimized_key_hash ~loc (key_hash : Signature.Public_key_hash.t) = Signature.Public_key_hash.encoding key_hash) -let optimized_address ~loc ~(address : Contract.t) ~(entrypoint : string) = +let optimized_address ~loc ~(address : Contract.t) ~(entrypoint : Entrypoint.t) + = let entrypoint = match entrypoint with "default" -> "" | name -> name in bytes ~loc @@ -601,7 +602,7 @@ type multisig_action = | Transfer of { amount : Tez.t; destination : Contract.t; - entrypoint : string; + entrypoint : Entrypoint.t; parameter_type : Script.expr; parameter : Script.expr; } @@ -953,7 +954,7 @@ type multisig_prepared_action = { threshold : Z.t; keys : public_key list; counter : Z.t; - entrypoint : string option; + entrypoint : Entrypoint.t option; generic : bool; } diff --git a/src/proto_alpha/lib_client/client_proto_multisig.mli b/src/proto_alpha/lib_client/client_proto_multisig.mli index ad4a6306d60c..909cc0b550cd 100644 --- a/src/proto_alpha/lib_client/client_proto_multisig.mli +++ b/src/proto_alpha/lib_client/client_proto_multisig.mli @@ -36,7 +36,7 @@ type multisig_action = | Transfer of { amount : Tez.t; destination : Contract.t; - entrypoint : string; + entrypoint : Entrypoint.t; parameter_type : Script.expr; parameter : Script.expr; } @@ -57,7 +57,7 @@ type multisig_prepared_action = { (* Information needed to execute the action ones enough signatures have been gathered. *) counter : Z.t; - entrypoint : string option; + entrypoint : Entrypoint.t option; generic : bool; } diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index b0b1b295e529..a9c72dfe1dfb 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -125,7 +125,7 @@ type simulation_params = { type run_view_params = { shared_params : simulation_params; contract : Contract.t; - entrypoint : string; + entrypoint : Entrypoint.t; } type run_params = { @@ -134,7 +134,7 @@ type run_params = { balance : Tez.t; program : Michelson_v1_parser.parsed; storage : Michelson_v1_parser.parsed; - entrypoint : string option; + entrypoint : Entrypoint.t option; } let run_view (cctxt : #Protocol_client_context.rpc_context) diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index 16c9a45acfff..dd17e04ae6d3 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -47,7 +47,7 @@ type simulation_params = { type run_view_params = { shared_params : simulation_params; contract : Contract.t; - entrypoint : string; + entrypoint : Entrypoint.t; } (* Parameters specific to simulations of contract calls *) @@ -57,7 +57,7 @@ type run_params = { balance : Tez.t; program : Michelson_v1_parser.parsed; storage : Michelson_v1_parser.parsed; - entrypoint : string option; + entrypoint : Entrypoint.t option; } val run_view : @@ -158,7 +158,7 @@ val entrypoint_type : chain:Shell_services.chain -> block:Shell_services.block -> Michelson_v1_parser.parsed -> - entrypoint:string -> + entrypoint:Entrypoint.t -> Script.expr option tzresult Lwt.t val print_entrypoint_type : @@ -167,7 +167,7 @@ val print_entrypoint_type : ?script_name:string -> show_source:bool -> parsed:Michelson_v1_parser.parsed -> - entrypoint:string -> + entrypoint:Entrypoint.t -> Script_repr.expr option tzresult -> unit tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/managed_contract.mli b/src/proto_alpha/lib_client/managed_contract.mli index ae532c986987..e272420913a9 100644 --- a/src/proto_alpha/lib_client/managed_contract.mli +++ b/src/proto_alpha/lib_client/managed_contract.mli @@ -71,7 +71,7 @@ val build_transaction_operation : block:Block_services.block -> contract:Contract.t -> destination:Contract.t -> - ?entrypoint:string -> + ?entrypoint:Entrypoint.t -> ?arg:string -> amount:Tez.t -> ?fee:Tez.t -> @@ -99,7 +99,7 @@ val transfer : src_sk:Client_keys.sk_uri -> contract:Contract.t -> destination:Contract.t -> - ?entrypoint:string -> + ?entrypoint:Entrypoint.t -> ?arg:string -> amount:Tez.t -> ?fee:Tez.t -> @@ -118,7 +118,7 @@ val build_lambda_for_transfer_to_implicit : val build_lambda_for_transfer_to_originated : destination:Contract.t -> - entrypoint:string -> + entrypoint:Entrypoint.t -> amount:Tez.t -> parameter_type:Script.expr -> parameter:Script.expr -> diff --git a/src/proto_alpha/lib_client/michelson_v1_entrypoints.mli b/src/proto_alpha/lib_client/michelson_v1_entrypoints.mli index 96d3ad82c2f0..83dfe900e3b3 100644 --- a/src/proto_alpha/lib_client/michelson_v1_entrypoints.mli +++ b/src/proto_alpha/lib_client/michelson_v1_entrypoints.mli @@ -31,7 +31,7 @@ val script_entrypoint_type : chain:Chain_services.chain -> block:Block_services.block -> Alpha_context.Script.expr -> - entrypoint:string -> + entrypoint:Alpha_context.Entrypoint.t -> Alpha_context.Script.expr option tzresult Lwt.t (** Returns [Some type] if the script has an entrypoint of type [type]. None if it does not exists. *) @@ -40,7 +40,7 @@ val contract_entrypoint_type : chain:Chain_services.chain -> block:Block_services.block -> contract:Alpha_context.Contract.t -> - entrypoint:string -> + entrypoint:Alpha_context.Entrypoint.t -> Alpha_context.Script.expr option tzresult Lwt.t val print_entrypoint_type : @@ -49,7 +49,7 @@ val print_entrypoint_type : emacs:bool -> ?contract:Alpha_context.Contract.t -> ?script_name:string -> - entrypoint:string -> + entrypoint:Alpha_context.Entrypoint.t -> Alpha_context.Script.expr option tzresult -> unit tzresult Lwt.t diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 2567812a0d0b..1b07411b7357 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -912,13 +912,13 @@ module View_helpers = struct type Environment.Error_monad.error += View_callback_origination_failed type Environment.Error_monad.error += - | Illformed_view_type of string * Script.expr + | Illformed_view_type of Entrypoint.t * Script.expr type Environment.Error_monad.error += - | View_never_returns of string * Contract.t + | View_never_returns of Entrypoint.t * Contract.t type Environment.Error_monad.error += - | View_unexpected_return of string * Contract.t + | View_unexpected_return of Entrypoint.t * Contract.t let () = Environment.Error_monad.register_error_kind diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 7bfddaa07b46..803769294a17 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2076,7 +2076,7 @@ and _ manager_operation = | Transaction : { amount : Tez.tez; parameters : Script.lazy_expr; - entrypoint : string; + entrypoint : Entrypoint.t; destination : Contract.contract; } -> Kind.transaction manager_operation diff --git a/src/proto_alpha/lib_protocol/contract_services.mli b/src/proto_alpha/lib_protocol/contract_services.mli index 458dfbe4d617..58a36ba40652 100644 --- a/src/proto_alpha/lib_protocol/contract_services.mli +++ b/src/proto_alpha/lib_protocol/contract_services.mli @@ -83,7 +83,7 @@ val entrypoint_type : 'a #RPC_context.simple -> 'a -> Contract.t -> - string -> + Entrypoint.t -> Script.expr shell_tzresult Lwt.t val list_entrypoints : diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index e92238e979aa..4fcf7bcf728b 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -22,3 +22,5 @@ (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) + +include Compare.String diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index e92238e979aa..0a9af70777e8 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -22,3 +22,6 @@ (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) + +(** An entrypoint is a string of at most 31 characters *) +type t = string diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 19fbd8508a6c..e9cab67ae27c 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -240,7 +240,7 @@ and _ manager_operation = | Transaction : { amount : Tez_repr.tez; parameters : Script_repr.lazy_expr; - entrypoint : string; + entrypoint : Entrypoint_repr.t; destination : Contract_repr.contract; } -> Kind.transaction manager_operation diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 8e83456ee898..dd279466c4d5 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -218,7 +218,7 @@ and _ manager_operation = | Transaction : { amount : Tez_repr.tez; parameters : Script_repr.lazy_expr; - entrypoint : string; + entrypoint : Entrypoint_repr.t; destination : Contract_repr.contract; } -> Kind.transaction manager_operation diff --git a/src/proto_alpha/lib_protocol/script_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli index 2f2f5b7c672b..0fce503243a4 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/script_interpreter.mli @@ -104,7 +104,7 @@ val execute : Script_ir_translator.unparsing_mode -> step_constants -> script:Script.t -> - entrypoint:string -> + entrypoint:Entrypoint.t -> parameter:Script.expr -> internal:bool -> (execution_result * (Script_ir_translator.ex_script * int)) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 1ec20ed9f6f5..826aeed5b243 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1942,7 +1942,8 @@ let find_entrypoint (type full error_trace) in let loc = Micheline.dummy_location in let rec find_entrypoint : - type t. t ty -> string -> ((Script.node -> Script.node) * ex_ty) option = + type t. + t ty -> Entrypoint.t -> ((Script.node -> Script.node) * ex_ty) option = fun t entrypoint -> match t with | Union_t ((tl, al), (tr, ar), _) -> ( @@ -1988,7 +1989,7 @@ let find_entrypoint (type full error_trace) let find_entrypoint_for_type (type full exp error_trace) ~legacy ~error_details ~(full : full ty) ~(expected : exp ty) ~root_name entrypoint loc : - (string * exp ty, error_trace) Gas_monad.t = + (Entrypoint.t * exp ty, error_trace) Gas_monad.t = let open Gas_monad in match find_entrypoint ~error_details full ~root_name entrypoint with | Error _ as err -> of_result err @@ -5436,7 +5437,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra Script.location -> arg ty -> Contract.t -> - entrypoint:string -> + entrypoint:Entrypoint.t -> (context * arg typed_contract) tzresult Lwt.t = fun ~stack_depth ~legacy ctxt loc arg contract ~entrypoint -> match Contract.is_implicit contract with @@ -5619,7 +5620,7 @@ let parse_contract_for_script : Script.location -> arg ty -> Contract.t -> - entrypoint:string -> + entrypoint:Entrypoint.t -> (context * arg typed_contract option) tzresult Lwt.t = fun ctxt loc arg contract ~entrypoint -> match Contract.is_implicit contract with diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 44937a3459d4..d273e04246b3 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -396,7 +396,7 @@ val parse_contract : Script.location -> 'a Script_typed_ir.ty -> Contract.t -> - entrypoint:string -> + entrypoint:Entrypoint.t -> (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t val parse_contract_for_script : @@ -404,14 +404,14 @@ val parse_contract_for_script : Script.location -> 'a Script_typed_ir.ty -> Contract.t -> - entrypoint:string -> + entrypoint:Entrypoint.t -> (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t val find_entrypoint : error_details:'error_trace error_details -> 't Script_typed_ir.ty -> root_name:Script_ir_annot.field_annot option -> - string -> + Entrypoint.t -> ((Script.node -> Script.node) * ex_ty, 'error_trace) result module Entrypoints_map : Map.S with type key = string diff --git a/src/proto_alpha/lib_protocol/script_tc_errors.ml b/src/proto_alpha/lib_protocol/script_tc_errors.ml index e44a47319ba5..bed34f3a951b 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors.ml @@ -62,9 +62,9 @@ type error += Unexpected_operation of Script.location type error += Unexpected_contract of Script.location -type error += No_such_entrypoint of string +type error += No_such_entrypoint of Entrypoint.t -type error += Duplicate_entrypoint of string +type error += Duplicate_entrypoint of Entrypoint.t type error += Unreachable_entrypoint of prim list diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 0872eb130b07..734936c2e4cb 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -61,7 +61,7 @@ type step_constants = { type never = | -type address = Contract.t * string +type address = Contract.t * Entrypoint.t type ('a, 'b) pair = 'a * 'b @@ -803,7 +803,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = | IContract : (address, 's) kinfo * 'a ty - * string + * Entrypoint.t * ('a typed_contract option, 's, 'r, 'f) kinstr -> (address, 's, 'r, 'f) kinstr | IView : @@ -870,7 +870,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = | ISelf : ('a, 's) kinfo * 'b ty - * string + * Entrypoint.t * ('b typed_contract, 'a * 's, 'r, 'f) kinstr -> ('a, 's, 'r, 'f) kinstr | ISelf_address : diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 45b3b3ce6cc8..4582c952e656 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -42,7 +42,7 @@ type step_constants = { type never = | -type address = Contract.t * string +type address = Contract.t * Entrypoint.t type ('a, 'b) pair = 'a * 'b @@ -770,7 +770,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = | IContract : (address, 's) kinfo * 'a ty - * string + * Entrypoint.t * ('a typed_contract option, 's, 'r, 'f) kinstr -> (address, 's, 'r, 'f) kinstr | IView : @@ -837,7 +837,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = | ISelf : ('a, 's) kinfo * 'b ty - * string + * Entrypoint.t * ('b typed_contract, 'a * 's, 'r, 'f) kinstr -> ('a, 's, 'r, 'f) kinstr | ISelf_address : diff --git a/src/proto_alpha/lib_protocol/test/helpers/cpmm_repr.ml b/src/proto_alpha/lib_protocol/test/helpers/cpmm_repr.ml index 5689833772b4..deb7fdd42a42 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/cpmm_repr.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/cpmm_repr.ml @@ -278,7 +278,7 @@ module Parameter = struct | XtzToToken p -> Format.asprintf "XtzToToken (%s)" (xtz_to_token_to_string p) - let entrypoint_of_parameter : t -> string = function + let entrypoint_of_parameter : t -> Entrypoint.t = function | AddLiquidity _ -> "addLiquidity" | Default _ -> "default" | RemoveLiquidity _ -> "removeLiquidity" diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.mli b/src/proto_alpha/lib_protocol/test/helpers/op.mli index 3c99d37601a1..fc460753cf28 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/op.mli @@ -62,7 +62,7 @@ val transaction : ?gas_limit:Gas.Arith.integral -> ?storage_limit:Z.t -> ?parameters:Script.lazy_expr -> - ?entrypoint:string -> + ?entrypoint:Entrypoint.t -> Context.t -> Contract.t -> Contract.t -> -- GitLab From 37a151ac6b05c0f178767eaf2972b787fd33f93f Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Tue, 19 Oct 2021 18:26:39 +0200 Subject: [PATCH 03/28] Proto: add Entrypoint.default/is_default and use them MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- .../lib_benchmark/michelson_samplers.ml | 2 +- .../interpreter_benchmarks.ml | 4 +- .../lib_client/client_proto_context.ml | 9 +- .../lib_client/client_proto_multisig.ml | 2 +- .../lib_client/managed_contract.ml | 6 +- .../lib_client/michelson_v1_entrypoints.ml | 14 ++- .../lib_client/operation_result.ml | 5 +- .../client_proto_multisig_commands.ml | 12 +- .../client_proto_stresstest_commands.ml | 2 +- src/proto_alpha/lib_plugin/plugin.ml | 18 +-- src/proto_alpha/lib_protocol/apply.ml | 10 +- .../lib_protocol/entrypoint_repr.ml | 4 + .../lib_protocol/entrypoint_repr.mli | 6 + .../lib_protocol/operation_repr.ml | 4 +- .../lib_protocol/script_interpreter.ml | 27 +++-- .../lib_protocol/script_ir_translator.ml | 107 +++++++++--------- .../test/helpers/contract_helpers.ml | 2 +- .../test/helpers/liquidity_baking_machine.ml | 4 +- .../test/helpers/lqt_fa12_repr.ml | 2 +- .../lib_protocol/test/helpers/op.ml | 4 +- .../lib_protocol/test/test_typechecking.ml | 4 +- .../lib_protocol/ticket_balance_key.ml | 4 +- 22 files changed, 139 insertions(+), 113 deletions(-) diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index 16014d6df65a..41980dd4fd07 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -490,7 +490,7 @@ end) if Base_samplers.uniform_bool rng_state then ( Alpha_context.Contract.implicit_contract (Crypto_samplers.pkh rng_state), - "default" ) + Alpha_context.Entrypoint.default ) else (* For a description of the format, see tezos-codec describe alpha.contract binary encoding *) diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml index 961cf576e78f..b7570a634a91 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml @@ -2157,7 +2157,7 @@ module Registration_section = struct (IContract ( kinfo (address @$ bot), unit, - "default", + Alpha_context.Entrypoint.default, halt (option (contract unit) @$ bot) )) () @@ -2383,7 +2383,7 @@ module Registration_section = struct (ISelf ( kinfo (unit @$ bot), unit, - "default", + Alpha_context.Entrypoint.default, halt (contract unit @$ unit @$ bot) )) () diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 6324b12c4e74..f4aec8fa3f2d 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -94,8 +94,9 @@ let parse_arg_transfer arg = return (Option.fold ~some:Script.lazy_expr ~none:Script.unit_parameter parameters) -let build_transaction_operation ~amount ~parameters ?(entrypoint = "default") - ?fee ?gas_limit ?storage_limit destination = +let build_transaction_operation ~amount ~parameters + ?(entrypoint = Entrypoint.default) ?fee ?gas_limit ?storage_limit + destination = let operation = Transaction {amount; parameters; destination; entrypoint} in Injection.prepare_manager_operation ~fee:(Limit.of_option fee) @@ -105,8 +106,8 @@ let build_transaction_operation ~amount ~parameters ?(entrypoint = "default") let transfer (cctxt : #full) ~chain ~block ?confirmations ?dry_run ?verbose_signing ?simulation ?branch ~source ~src_pk ~src_sk ~destination - ?(entrypoint = "default") ?arg ~amount ?fee ?gas_limit ?storage_limit - ?counter ~fee_parameter ?replace_by_fees () = + ?(entrypoint = Entrypoint.default) ?arg ~amount ?fee ?gas_limit + ?storage_limit ?counter ~fee_parameter ?replace_by_fees () = parse_arg_transfer arg >>=? fun parameters -> let contents = build_transaction_operation diff --git a/src/proto_alpha/lib_client/client_proto_multisig.ml b/src/proto_alpha/lib_client/client_proto_multisig.ml index 6e73014211fe..21f574df9ef4 100644 --- a/src/proto_alpha/lib_client/client_proto_multisig.ml +++ b/src/proto_alpha/lib_client/client_proto_multisig.ml @@ -738,7 +738,7 @@ let action_of_expr_not_generic e = amount; destination = Data_encoding.Binary.of_bytes_exn Contract.encoding s; - entrypoint = "default"; + entrypoint = Entrypoint.default; parameter_type = Tezos_micheline.Micheline.strip_locations @@ unit_t ~loc:(); parameter = diff --git a/src/proto_alpha/lib_client/managed_contract.ml b/src/proto_alpha/lib_client/managed_contract.ml index 29bb3d976b63..5a1815e4131a 100644 --- a/src/proto_alpha/lib_client/managed_contract.ml +++ b/src/proto_alpha/lib_client/managed_contract.ml @@ -220,10 +220,10 @@ let build_lambda_for_transfer_to_originated ~destination ~entrypoint ~amount parameter let build_transaction_operation (cctxt : #full) ~chain ~block ~contract - ~destination ?(entrypoint = "default") ?arg ~amount ?fee ?gas_limit + ~destination ?(entrypoint = Entrypoint.default) ?arg ~amount ?fee ?gas_limit ?storage_limit () = (match Alpha_context.Contract.is_implicit destination with - | Some destination when entrypoint = "default" -> + | Some destination when Entrypoint.is_default entrypoint -> return @@ build_lambda_for_transfer_to_implicit ~destination ~amount | Some _ -> cctxt#error @@ -278,7 +278,7 @@ let build_transaction_operation (cctxt : #full) ~chain ~block ~contract let transfer (cctxt : #full) ~chain ~block ?confirmations ?dry_run ?verbose_signing ?simulation ?branch ~source ~src_pk ~src_sk ~contract - ~destination ?(entrypoint = "default") ?arg ~amount ?fee ?gas_limit + ~destination ?(entrypoint = Entrypoint.default) ?arg ~amount ?fee ?gas_limit ?storage_limit ?counter ~fee_parameter () : (Kind.transaction Kind.manager Injection.result * Contract.t list) tzresult Lwt.t = diff --git a/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml b/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml index 9d6f08221e8b..915ff5a078a0 100644 --- a/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml @@ -113,7 +113,12 @@ let list_contract_entrypoints cctxt ~chain ~block ~contract = list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract >>=? fun (_, entrypoints) -> if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then - contract_entrypoint_type cctxt ~chain ~block ~contract ~entrypoint:"default" + contract_entrypoint_type + cctxt + ~chain + ~block + ~contract + ~entrypoint:Entrypoint.default >>= function | Ok (Some ty) -> return (("default", ty) :: entrypoints) | Ok None -> return entrypoints @@ -128,7 +133,12 @@ let list_entrypoints cctxt ~chain ~block (program : Script.expr) = Plugin.RPC.Scripts.list_entrypoints cctxt (chain, block) ~script:program >>=? fun (_, entrypoints) -> if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then - script_entrypoint_type cctxt ~chain ~block program ~entrypoint:"default" + script_entrypoint_type + cctxt + ~chain + ~block + program + ~entrypoint:Entrypoint.default >>= function | Ok (Some ty) -> return (("default", ty) :: entrypoints) | Ok None -> return entrypoints diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index f369037cd823..9fa016a871ca 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -43,9 +43,8 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf source Contract.pp destination ; - (match entrypoint with - | "default" -> () - | _ -> Format.fprintf ppf "@,Entrypoint: %s" entrypoint) ; + if not (Entrypoint.is_default entrypoint) then + Format.fprintf ppf "@,Entrypoint: %s" entrypoint ; (if not (Script_repr.is_unit_parameter parameters) then let expr = WithExceptions.Option.to_exn diff --git a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml index db58555539ee..f22377a67b44 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml @@ -332,7 +332,9 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = (_, destination) sk (cctxt : #Protocol_client_context.full) -> - let entrypoint = Option.value ~default:"default" entrypoint in + let entrypoint = + Option.value ~default:Entrypoint.default entrypoint + in let parameter = Option.value ~default:"Unit" parameter in Lwt.return @@ Micheline_parser.no_parsing_error @@ Michelson_v1_parser.parse_expression parameter @@ -514,7 +516,9 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = (_, source) signatures (cctxt : #Protocol_client_context.full) -> - let entrypoint = Option.value ~default:"default" entrypoint in + let entrypoint = + Option.value ~default:Entrypoint.default entrypoint + in let parameter = Option.value ~default:"Unit" parameter in Lwt.return @@ Micheline_parser.no_parsing_error @@ Michelson_v1_parser.parse_expression parameter @@ -1000,7 +1004,9 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = amount (_, destination) (cctxt : #Protocol_client_context.full) -> - let entrypoint = Option.value ~default:"default" entrypoint in + let entrypoint = + Option.value ~default:Entrypoint.default entrypoint + in let parameter = Option.value ~default:"Unit" parameter in Lwt.return @@ Micheline_parser.no_parsing_error @@ Michelson_v1_parser.parse_expression parameter diff --git a/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml index ca6a60096a9a..1af3ee99aea1 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml @@ -389,7 +389,7 @@ let manager_op_of_transfer parameters @@ Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], [])) in - let entrypoint = "default" in + let entrypoint = Entrypoint.default in let destination = Contract.implicit_contract dst in Transaction {amount; parameters; entrypoint; destination} in diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 1b07411b7357..00b6eeb6e36d 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -1187,7 +1187,7 @@ module RPC = struct (opt "source" Contract.encoding) (opt "payer" Contract.encoding) (opt "gas" Gas.Arith.z_integral_encoding) - (dft "entrypoint" string "default")) + (dft "entrypoint" string Entrypoint.default)) (obj3 (opt "unparsing_mode" unparsing_mode_encoding) (opt "now" Script_timestamp.encoding) @@ -1406,7 +1406,7 @@ module RPC = struct ~input: (obj2 (req "script" Script.expr_encoding) - (dft "entrypoint" string "default")) + (dft "entrypoint" string Entrypoint.default)) ~output:(obj1 (req "entrypoint_type" Script.expr_encoding)) RPC_path.(path / "entrypoint") @@ -2176,9 +2176,9 @@ module RPC = struct map [] ) )) - let run_code ?unparsing_mode ?gas ?(entrypoint = "default") ~script ~storage - ~input ~amount ~balance ~chain_id ~source ~payer ~now ~level ctxt block - = + let run_code ?unparsing_mode ?gas ?(entrypoint = Entrypoint.default) ~script + ~storage ~input ~amount ~balance ~chain_id ~source ~payer ~now ~level + ctxt block = RPC_context.make_call0 S.run_code ctxt @@ -2196,9 +2196,9 @@ module RPC = struct entrypoint ), (unparsing_mode, now, level) ) - let trace_code ?unparsing_mode ?gas ?(entrypoint = "default") ~script - ~storage ~input ~amount ~balance ~chain_id ~source ~payer ~now ~level - ctxt block = + let trace_code ?unparsing_mode ?gas ?(entrypoint = Entrypoint.default) + ~script ~storage ~input ~amount ~balance ~chain_id ~source ~payer ~now + ~level ctxt block = RPC_context.make_call0 S.trace_code ctxt @@ -2574,7 +2574,7 @@ module RPC = struct [] let transaction ctxt block ~branch ~source ?sourcePubKey ~counter ~amount - ~destination ?(entrypoint = "default") ?parameters ~gas_limit + ~destination ?(entrypoint = Entrypoint.default) ?parameters ~gas_limit ~storage_limit ~fee () = let parameters = Option.fold diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 45476fc836f0..7c10d7e1be9d 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -904,10 +904,8 @@ let apply_manager_operation_content : match script with | None -> Lwt.return - ( ( (match entrypoint with - | "default" -> Result.return_unit - | entrypoint -> - error (Script_tc_errors.No_such_entrypoint entrypoint)) + ( ( (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, [], _) -> @@ -2381,7 +2379,7 @@ let apply_liquidity_baking_subsidy ctxt ~escape_vote = Script_cache.find ctxt liquidity_baking_cpmm_contract >>=? fun (ctxt, cache_key, script) -> match script with - | None -> fail (Script_tc_errors.No_such_entrypoint "default") + | None -> fail (Script_tc_errors.No_such_entrypoint Entrypoint.default) | Some (script, script_ir) -> ( let now = Script_timestamp.now ctxt in let level = @@ -2425,7 +2423,7 @@ let apply_liquidity_baking_subsidy ctxt ~escape_vote = ~script ~parameter ~cached_script:(Some script_ir) - ~entrypoint:"default" + ~entrypoint:Entrypoint.default ~internal:false >>=? fun ( {ctxt; storage; lazy_storage_diff; operations}, (updated_cached_script, updated_size) ) -> diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 4fcf7bcf728b..349191a5f053 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -24,3 +24,7 @@ (*****************************************************************************) include Compare.String + +let default = "default" + +let is_default name = name = default diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 0a9af70777e8..8cd55e2aab60 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -25,3 +25,9 @@ (** An entrypoint is a string of at most 31 characters *) type t = string + +(** Default entrypoint "default" *) +val default : t + +(** Checks whether an entrypoint is the default entrypoint *) +val is_default : t -> bool diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index e9cab67ae27c..8adba4d30fd9 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -427,7 +427,7 @@ module Encoding = struct let parameters = if Script_repr.is_unit_parameter parameters - && Compare.String.(entrypoint = "default") + && Entrypoint_repr.is_default entrypoint then None else Some (entrypoint, parameters) in @@ -436,7 +436,7 @@ module Encoding = struct (fun (amount, destination, parameters) -> let (entrypoint, parameters) = match parameters with - | None -> ("default", Script_repr.unit_parameter) + | None -> (Entrypoint_repr.default, Script_repr.unit_parameter) | Some (entrypoint, value) -> (entrypoint, value) in Transaction {amount; destination; parameters; entrypoint}); diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 345f96684530..72247a79db88 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -987,10 +987,15 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let (_, address) = accu in (step [@ocaml.tailcall]) g gas k ks address stack | IContract (kinfo, t, entrypoint, k) -> ( - let contract = accu in - match (contract, entrypoint) with - | ((contract, "default"), entrypoint) - | ((contract, entrypoint), "default") -> + let (contract, contract_entrypoint) = accu in + let entrypoint_opt = + if Entrypoint.is_default contract_entrypoint then Some entrypoint + else if Entrypoint.is_default entrypoint then + Some contract_entrypoint + else (* both entrypoints are non-default *) None + in + match entrypoint_opt with + | Some entrypoint -> let ctxt = update_context gas ctxt in Script_ir_translator.parse_contract_for_script ctxt @@ -1003,7 +1008,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let ctxt = outdated ctxt in let accu = maybe_contract in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | _ -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) + | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) | ITransfer_tokens (_, k) -> let p = accu in let (amount, ((tp, (destination, entrypoint)), stack)) = stack in @@ -1013,7 +1018,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | IImplicit_account (_, k) -> let key = accu in let contract = Contract.implicit_contract key in - let res = (unit_t ~annot:None, (contract, "default")) in + let res = (unit_t ~annot:None, (contract, Entrypoint.default)) in (step [@ocaml.tailcall]) g gas k ks res stack | IView (_, View_signature {name; input_ty; output_ty}, k) -> ( let input = accu in @@ -1137,7 +1142,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = credit init >>=? fun (res, contract, ctxt, gas) -> - let stack = ((contract, "default"), stack) in + let stack = ((contract, Entrypoint.default), stack) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack | ISet_delegate (_, k) -> let delegate = accu in @@ -1182,16 +1187,16 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let hash = Raw_hashes.sha512 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack | ISource (_, k) -> - let res = (sc.payer, "default") in + let res = (sc.payer, Entrypoint.default) in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) | ISender (_, k) -> - let res = (sc.source, "default") in + let res = (sc.source, Entrypoint.default) in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) | ISelf (_, ty, entrypoint, k) -> let res = (ty, (sc.self, entrypoint)) in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) | ISelf_address (_, k) -> - let res = (sc.self, "default") in + let res = (sc.self, Entrypoint.default) in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) | IAmount (_, k) -> let accu = sc.amount and stack = (accu, stack) in @@ -1418,7 +1423,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | IRead_ticket (_, k) -> let {ticketer; contents; amount} = accu in let stack = (accu, stack) in - let accu = ((ticketer, "default"), (contents, amount)) in + let accu = ((ticketer, Entrypoint.default), (contents, amount)) in (step [@ocaml.tailcall]) g gas k ks accu stack | ISplit_ticket (_, k) -> let ticket = accu and ((amount_a, amount_b), stack) = stack in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 826aeed5b243..02a1886fcbcc 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1977,15 +1977,15 @@ let find_entrypoint (type full error_trace) | _ -> ( match find_entrypoint full entrypoint with | Some result -> ok result - | None -> ( - match entrypoint with - | "default" -> ok ((fun e -> e), Ex_ty full) - | _ -> - Error - (match error_details with - | Fast -> (Inconsistent_types_fast : error_trace) - | Informative -> - trace_of_error @@ No_such_entrypoint entrypoint))) + | None -> + if Entrypoint.is_default entrypoint then + ok ((fun e -> e), Ex_ty full) + else + Error + (match error_details with + | Fast -> (Inconsistent_types_fast : error_trace) + | Informative -> trace_of_error @@ No_such_entrypoint entrypoint) + ) let find_entrypoint_for_type (type full exp error_trace) ~legacy ~error_details ~(full : full ty) ~(expected : exp ty) ~root_name entrypoint loc : @@ -1994,11 +1994,12 @@ let find_entrypoint_for_type (type full exp error_trace) ~legacy ~error_details match find_entrypoint ~error_details full ~root_name entrypoint with | Error _ as err -> of_result err | Ok (_, Ex_ty ty) -> ( - match (entrypoint, root_name) with - | ("default", Some (Field_annot fa)) - when Compare.String.((fa :> string) = "root") -> ( + match root_name with + | Some (Field_annot fa) + when Compare.String.((fa :> string) = "root") + && Entrypoint.is_default entrypoint -> ( merge_types ~legacy ~error_details:Fast loc ty expected >??$ function - | Ok (Eq, ty) -> return ("default", (ty : exp ty)) + | Ok (Eq, ty) -> return (Entrypoint.default, (ty : exp ty)) | Error Inconsistent_types_fast -> merge_types ~legacy ~error_details loc full expected >?$ fun (Eq, full) -> ok ("root", (full : exp ty))) @@ -2060,7 +2061,7 @@ let well_formed_entrypoints (type full) (full : full ty) ~root_name = | Some (Field_annot name) -> (Entrypoints.singleton (name :> string), true) in check full [] reachable (None, init) >>? fun (first_unreachable, all) -> - if not (Entrypoints.mem "default" all) then Result.return_unit + if not (Entrypoints.mem Entrypoint.default all) then Result.return_unit else match first_unreachable with | None -> Result.return_unit @@ -2297,7 +2298,7 @@ let parse_address ctxt : Script.node -> (address * context) tzresult = function | String (loc, s) (* As unparsed with [Readable]. *) -> Gas.consume ctxt Typecheck_costs.contract >>? fun ctxt -> (match String.index_opt s '%' with - | None -> ok (s, "default") + | None -> ok (s, Entrypoint.default) | Some pos -> ( let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in @@ -4790,7 +4791,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ~default:(gen_access_annot addr_annot default_contract_annot) >>?= fun (annot, entrypoint) -> (match entrypoint with - | None -> Ok "default" + | None -> Ok Entrypoint.default | Some (Field_annot entrypoint) -> let entrypoint = (entrypoint :> string) in if Compare.String.(entrypoint = "default") then @@ -4996,7 +4997,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let entrypoint = Option.fold ~some:(fun (Field_annot annot) -> (annot :> string)) - ~none:"default" + ~none:Entrypoint.default entrypoint in let open Tc_context in @@ -5441,18 +5442,15 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra (context * arg typed_contract) tzresult Lwt.t = fun ~stack_depth ~legacy ctxt loc arg contract ~entrypoint -> match Contract.is_implicit contract with - | Some _ -> ( - match entrypoint with - | "default" -> - (* An implicit account on the "default" entrypoint always exists and has type unit. *) - Lwt.return - ( ty_eq ~legacy:true ctxt loc arg (unit_t ~annot:None) - >|? fun (Eq, ctxt) -> - let contract : arg typed_contract = - (arg, (contract, entrypoint)) - in - (ctxt, contract) ) - | _ -> fail (No_such_entrypoint entrypoint)) + | Some _ -> + if Entrypoint.is_default entrypoint then + (* An implicit account on the "default" entrypoint always exists and has type unit. *) + Lwt.return + ( ty_eq ~legacy:true ctxt loc arg (unit_t ~annot:None) + >|? fun (Eq, ctxt) -> + let contract : arg typed_contract = (arg, (contract, entrypoint)) in + (ctxt, contract) ) + else fail (No_such_entrypoint entrypoint) | None -> ( (* Originated account *) trace (Invalid_contract (loc, contract)) @@ -5624,31 +5622,30 @@ let parse_contract_for_script : (context * arg typed_contract option) tzresult Lwt.t = fun ctxt loc arg contract ~entrypoint -> match Contract.is_implicit contract with - | Some _ -> ( - match entrypoint with - | "default" -> - (* An implicit account on the "default" entrypoint always exists and has type unit. *) - Lwt.return - ( Gas_monad.run ctxt - @@ merge_types - ~legacy:true - ~error_details:Fast - loc - arg - (unit_t ~annot:None) - >|? fun (eq_ty, ctxt) -> - match eq_ty with - | Ok (Eq, _ty) -> - let contract : arg typed_contract = - (arg, (contract, entrypoint)) - in - (ctxt, Some contract) - | Error Inconsistent_types_fast -> (ctxt, None) ) - | _ -> - Lwt.return - ( Gas.consume ctxt Typecheck_costs.parse_instr_cycle >|? fun ctxt -> - (* An implicit account on any other entrypoint is not a valid contract. *) - (ctxt, None) )) + | Some _ -> + if Entrypoint.is_default entrypoint then + (* An implicit account on the "default" entrypoint always exists and has type unit. *) + Lwt.return + ( Gas_monad.run ctxt + @@ merge_types + ~legacy:true + ~error_details:Fast + loc + arg + (unit_t ~annot:None) + >|? fun (eq_ty, ctxt) -> + match eq_ty with + | Ok (Eq, _ty) -> + let contract : arg typed_contract = + (arg, (contract, entrypoint)) + in + (ctxt, Some contract) + | Error Inconsistent_types_fast -> (ctxt, None) ) + else + Lwt.return + ( Gas.consume ctxt Typecheck_costs.parse_instr_cycle >|? fun ctxt -> + (* An implicit account on any other entrypoint is not a valid contract. *) + (ctxt, None) ) | None -> ( (* Originated account *) trace (Invalid_contract (loc, contract)) @@ -6039,7 +6036,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ~stack_depth mode t - ((ticketer, "default"), (contents, amount)) + ((ticketer, Entrypoint.default), (contents, amount)) | (Set_t (t, _), set) -> List.fold_left_es (fun (l, ctxt) item -> 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 deec7b0af8e8..ad37f1aa039d 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml @@ -82,7 +82,7 @@ let default_step_constants = parameters from strings. It then executes the typed script with the storage and parameter and returns the result. *) let run_script ctx ?(step_constants = default_step_constants) contract - ?(entrypoint = "default") ~storage ~parameter () = + ?(entrypoint = Entrypoint.default) ~storage ~parameter () = let contract_expr = Expr.from_string contract in let storage_expr = Expr.from_string storage in let parameter_expr = Expr.from_string parameter in diff --git a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml index aeb81ede82e7..00561546aac2 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml @@ -737,7 +737,7 @@ module ConcreteBaseMachine : Lqt_fa12_repr.Storage.getBalance_opt (B blk) ~contract:env.tzbtc_contract - (contract, "default") + (contract, Entrypoint.default) >>=? fun mamount -> pure (Option.value (Option.map Z.to_int mamount) ~default:0) @@ -745,7 +745,7 @@ module ConcreteBaseMachine : Lqt_fa12_repr.Storage.getBalance_opt (B blk) ~contract:env.liquidity_contract - (contract, "default") + (contract, Entrypoint.default) >>=? fun mamount -> pure (Option.value (Option.map Z.to_int mamount) ~default:0) diff --git a/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml b/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml index 937dfb8297b2..216dff3768be 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml @@ -69,7 +69,7 @@ module Parameter = struct | Approve p -> Format.asprintf "Approve %s" (approve_to_string p) | MintOrBurn p -> Format.asprintf "MintOrBurn %s" (mint_or_burn_to_string p) - let entrypoint_of_parameter : t -> string = function + let entrypoint_of_parameter : t -> Entrypoint.t = function | Approve _ -> "approve" | MintOrBurn _ -> "mintOrBurn" diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index 9ba41cfb7c98..eac7739aedcf 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -355,8 +355,8 @@ let miss_signed_endorsement ?level ~endorsed_block ctxt = endorsement ~delegate:(delegate.pkh, slots) ~level ~endorsed_block ctxt () let transaction ?counter ?fee ?gas_limit ?storage_limit - ?(parameters = Script.unit_parameter) ?(entrypoint = "default") ctxt - (src : Contract.t) (dst : Contract.t) (amount : Tez.t) = + ?(parameters = Script.unit_parameter) ?(entrypoint = Entrypoint.default) + ctxt (src : Contract.t) (dst : Contract.t) (amount : Tez.t) = let top = Transaction {amount; parameters; destination = dst; entrypoint} in manager_operation ?counter ?fee ?gas_limit ?storage_limit ~source:src ctxt top >>=? fun sop -> diff --git a/src/proto_alpha/lib_protocol/test/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/test_typechecking.ml index 7ff1b6ab63b2..7f2f15455ee7 100644 --- a/src/proto_alpha/lib_protocol/test/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/test_typechecking.ml @@ -682,7 +682,7 @@ let test_parse_address () = ctxt (address_t ~annot:None) (String (-1, "KT1FAKEFAKEFAKEFAKEFAKEFAKEFAKGGSE2x%")) - (kt1fake, "default") + (kt1fake, Entrypoint.default) >>=? fun ctxt -> (* tz1% (empty entrypoint) *) wrap_error_lwt @@ -693,7 +693,7 @@ let test_parse_address () = ctxt (address_t ~annot:None) (String (-1, "tz1fakefakefakefakefakefakefakcphLA5%")) - (tz1fake, "default") + (tz1fake, Entrypoint.default) >|=? fun _ctxt -> () let test_unparse_data loc ctxt ty x ~expected_readable ~expected_optimized = diff --git a/src/proto_alpha/lib_protocol/ticket_balance_key.ml b/src/proto_alpha/lib_protocol/ticket_balance_key.ml index 8546d3a221b8..186b5c762372 100644 --- a/src/proto_alpha/lib_protocol/ticket_balance_key.ml +++ b/src/proto_alpha/lib_protocol/ticket_balance_key.ml @@ -44,8 +44,8 @@ let ticket_balance_key_and_amount ctxt ~owner Gas.consume ctxt (Script.strip_annotations_cost cont_ty_unstripped) >>?= fun ctxt -> let typ = Script.strip_annotations cont_ty_unstripped in - let ticketer_address = (ticketer, "default") in - let owner_address = (owner, "default") in + let ticketer_address = (ticketer, Entrypoint.default) in + let owner_address = (owner, Entrypoint.default) in let address_t = Script_typed_ir.address_t ~annot:None in Script_ir_translator.unparse_data ctxt -- GitLab From 71a7583dd6c576f370e391058e1a4af5bd5fd650 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 20 Oct 2021 21:13:24 +0200 Subject: [PATCH 04/28] Proto: add Entrypoint.root and use it MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 2 ++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 3 +++ src/proto_alpha/lib_protocol/script_ir_translator.ml | 2 +- 3 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 349191a5f053..a622320f61e8 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -28,3 +28,5 @@ include Compare.String let default = "default" let is_default name = name = default + +let root = "root" diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 8cd55e2aab60..6b2fd758073a 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -31,3 +31,6 @@ val default : t (** Checks whether an entrypoint is the default entrypoint *) val is_default : t -> bool + +(** Root entrypoint "root" *) +val root : t diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 02a1886fcbcc..94fa7d297b46 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2002,7 +2002,7 @@ let find_entrypoint_for_type (type full exp error_trace) ~legacy ~error_details | Ok (Eq, ty) -> return (Entrypoint.default, (ty : exp ty)) | Error Inconsistent_types_fast -> merge_types ~legacy ~error_details loc full expected - >?$ fun (Eq, full) -> ok ("root", (full : exp ty))) + >?$ fun (Eq, full) -> ok (Entrypoint.root, (full : exp ty))) | _ -> merge_types ~legacy ~error_details loc ty expected >|$ fun (Eq, ty) -> (entrypoint, (ty : exp ty))) -- GitLab From 90bec3f14d6d6d6d2360d5ca3439c8857c5936a6 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 18 Nov 2021 15:44:56 +0100 Subject: [PATCH 05/28] Proto: add other usual entrypoints and use them --- src/proto_alpha/lib_client/managed_contract.ml | 12 +++++++++--- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 6 ++++++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 9 +++++++++ 3 files changed, 24 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_client/managed_contract.ml b/src/proto_alpha/lib_client/managed_contract.ml index 5a1815e4131a..bcf4ddb2a56d 100644 --- a/src/proto_alpha/lib_client/managed_contract.ml +++ b/src/proto_alpha/lib_client/managed_contract.ml @@ -95,10 +95,16 @@ let build_lambda_for_set_delegate ~delegate = delegate | None -> "{ DROP ; NIL operation ; NONE key_hash ; SET_DELEGATE ; CONS }" +let entrypoint_do = Entrypoint.do_ + +let entrypoint_set_delegate = Entrypoint.set_delegate + +let entrypoint_remove_delegate = Entrypoint.remove_delegate + let build_delegate_operation (cctxt : #full) ~chain ~block ?fee contract (* the KT1 to delegate *) (delegate : Signature.public_key_hash option) = - let entrypoint = "do" in + let entrypoint = entrypoint_do in (Michelson_v1_entrypoints.contract_entrypoint_type cctxt ~chain @@ -114,8 +120,8 @@ let build_delegate_operation (cctxt : #full) ~chain ~block ?fee (* their is no "do" entrypoint trying "set/remove_delegate" *) let entrypoint = match delegate with - | Some _ -> "set_delegate" - | None -> "remove_delegate" + | Some _ -> entrypoint_set_delegate + | None -> entrypoint_remove_delegate in Michelson_v1_entrypoints.contract_entrypoint_type cctxt diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index a622320f61e8..554e1c9be530 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -30,3 +30,9 @@ let default = "default" let is_default name = name = default let root = "root" + +let do_ = "do" + +let set_delegate = "set_delegate" + +let remove_delegate = "remove_delegate" diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 6b2fd758073a..53c5992d3567 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -34,3 +34,12 @@ val is_default : t -> bool (** Root entrypoint "root" *) val root : t + +(** Entrypoint "do" *) +val do_ : t + +(** Entrypoint "set_delegate" *) +val set_delegate : t + +(** Entrypoint "remove_delegate" *) +val remove_delegate : t -- GitLab From a4667f0a5d6d2083129236df5bf87ed2bc657cfe Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 20 Oct 2021 21:17:08 +0200 Subject: [PATCH 06/28] Proto: add Entrypoint.compare and use it MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- src/proto_alpha/lib_protocol/entrypoint_repr.mli | 3 +++ src/proto_alpha/lib_protocol/script_comparable.ml | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 53c5992d3567..a9b46acfcd13 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -26,6 +26,9 @@ (** An entrypoint is a string of at most 31 characters *) type t = string +(** Total ordering of entrypoints *) +val compare : t -> t -> int + (** Default entrypoint "default" *) val default : t diff --git a/src/proto_alpha/lib_protocol/script_comparable.ml b/src/proto_alpha/lib_protocol/script_comparable.ml index ab542f4867f3..93c58db7b90f 100644 --- a/src/proto_alpha/lib_protocol/script_comparable.ml +++ b/src/proto_alpha/lib_protocol/script_comparable.ml @@ -29,7 +29,7 @@ open Script_typed_ir let compare_address (x, ex) (y, ey) = let lres = Contract.compare x y in - if Compare.Int.(lres = 0) then Compare.String.compare ex ey else lres + if Compare.Int.(lres = 0) then Entrypoint.compare ex ey else lres type compare_comparable_cont = | Compare_comparable : -- GitLab From 0428505da41c7b703a2bcc90a6fa1d279385531b Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 20 Oct 2021 21:21:12 +0200 Subject: [PATCH 07/28] Proto: add Entrypoint.Set/Map and use them --- src/proto_alpha/lib_plugin/plugin.ml | 2 +- .../lib_protocol/contract_services.ml | 2 +- .../lib_protocol/entrypoint_repr.ml | 3 ++ .../lib_protocol/entrypoint_repr.mli | 6 ++++ .../lib_protocol/script_ir_translator.ml | 32 +++++++++---------- .../lib_protocol/script_ir_translator.mli | 4 +-- 6 files changed, 27 insertions(+), 22 deletions(-) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 00b6eeb6e36d..b881826a459a 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -2170,7 +2170,7 @@ module RPC = struct Script_ir_translator.list_entrypoints ~root_name arg_type ctxt >|? fun (unreachable_entrypoint, map) -> ( unreachable_entrypoint, - Entrypoints_map.fold + Entrypoint.Map.fold (fun entry (_, ty) acc -> (entry, Micheline.strip_locations ty) :: acc) map diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index d4bb68bcff30..8ca33ddafa56 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -402,7 +402,7 @@ let[@coq_axiom_with_reason "gadt"] register () = >|? fun (unreachable_entrypoint, map) -> Some ( unreachable_entrypoint, - Entrypoints_map.fold + Entrypoint.Map.fold (fun entry (_, ty) acc -> (entry, Micheline.strip_locations ty) :: acc) map diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 554e1c9be530..ed56e1499d17 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -36,3 +36,6 @@ let do_ = "do" let set_delegate = "set_delegate" let remove_delegate = "remove_delegate" + +module Set = Set.Make (String) +module Map = Map.Make (String) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index a9b46acfcd13..db7f2749da6f 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -46,3 +46,9 @@ val set_delegate : t (** Entrypoint "remove_delegate" *) val remove_delegate : t + +(** Set of entrypoints *) +module Set : Set.S with type elt = t + +(** Map of entrypoints *) +module Map : Map.S with type key = t diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 94fa7d297b46..aea9f2d9c008 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2007,8 +2007,6 @@ let find_entrypoint_for_type (type full exp error_trace) ~legacy ~error_details merge_types ~legacy ~error_details loc ty expected >|$ fun (Eq, ty) -> (entrypoint, (ty : exp ty))) -module Entrypoints = Set.Make (String) - let well_formed_entrypoints (type full) (full : full ty) ~root_name = let merge path annot (type t) (ty : t ty) reachable ((first_unreachable, all) as acc) = @@ -2027,16 +2025,17 @@ let well_formed_entrypoints (type full) (full : full ty) ~root_name = let name = (name :> string) in if Compare.Int.(String.length name > 31) then error (Entrypoint_name_too_long name) - else if Entrypoints.mem name all then error (Duplicate_entrypoint name) - else ok (first_unreachable, Entrypoints.add name all) + else if Entrypoint.Set.mem name all then + error (Duplicate_entrypoint name) + else ok (first_unreachable, Entrypoint.Set.add name all) in let rec check : type t. t ty -> prim list -> bool -> - prim list option * Entrypoints.t -> - (prim list option * Entrypoints.t) tzresult = + prim list option * Entrypoint.Set.t -> + (prim list option * Entrypoint.Set.t) tzresult = fun t path reachable acc -> match t with | Union_t ((tl, al), (tr, ar), _) -> @@ -2057,11 +2056,12 @@ let well_formed_entrypoints (type full) (full : full ty) ~root_name = in let (init, reachable) = match root_name with - | None -> (Entrypoints.empty, false) - | Some (Field_annot name) -> (Entrypoints.singleton (name :> string), true) + | None -> (Entrypoint.Set.empty, false) + | Some (Field_annot name) -> + (Entrypoint.Set.singleton (name :> string), true) in check full [] reachable (None, init) >>? fun (first_unreachable, all) -> - if not (Entrypoints.mem Entrypoint.default all) then Result.return_unit + if not (Entrypoint.Set.mem Entrypoint.default all) then Result.return_unit else match first_unreachable with | None -> Result.return_unit @@ -5894,8 +5894,6 @@ let typecheck_code : trace (Ill_typed_contract (code, !type_map)) views_result >|=? fun ctxt -> (!type_map, ctxt) -module Entrypoints_map = Map.Make (String) - let list_entrypoints (type full) (full : full ty) ctxt ~root_name = let merge path annot (type t) (ty : t ty) reachable ((unreachables, all) as acc) = @@ -5912,13 +5910,13 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = let name = (name :> string) in if Compare.Int.(String.length name > 31) then ok (List.rev path :: unreachables, all) - else if Entrypoints_map.mem name all then + else if Entrypoint.Map.mem name all then ok (List.rev path :: unreachables, all) else unparse_ty ~loc:() ctxt ty >>? fun (unparsed_ty, _) -> ok ( unreachables, - Entrypoints_map.add name (List.rev path, unparsed_ty) all ) + Entrypoint.Map.add name (List.rev path, unparsed_ty) all ) in let rec fold_tree : type t. @@ -5926,9 +5924,9 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = prim list -> bool -> prim list list - * (prim list * Script.unlocated_michelson_node) Entrypoints_map.t -> + * (prim list * Script.unlocated_michelson_node) Entrypoint.Map.t -> (prim list list - * (prim list * Script.unlocated_michelson_node) Entrypoints_map.t) + * (prim list * Script.unlocated_michelson_node) Entrypoint.Map.t) tzresult = fun t path reachable acc -> match t with @@ -5951,9 +5949,9 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = unparse_ty ~loc:() ctxt full >>? fun (unparsed_full, _) -> let (init, reachable) = match root_name with - | None -> (Entrypoints_map.empty, false) + | None -> (Entrypoint.Map.empty, false) | Some (Field_annot name) -> - (Entrypoints_map.singleton (name :> string) ([], unparsed_full), true) + (Entrypoint.Map.singleton (name :> string) ([], unparsed_full), true) in fold_tree full [] reachable ([], init) [@@coq_axiom_with_reason "unsupported syntax"] diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index d273e04246b3..a6f906826ad4 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -414,15 +414,13 @@ val find_entrypoint : Entrypoint.t -> ((Script.node -> Script.node) * ex_ty, 'error_trace) result -module Entrypoints_map : Map.S with type key = string - val list_entrypoints : 't Script_typed_ir.ty -> context -> root_name:Script_ir_annot.field_annot option -> (Michelson_v1_primitives.prim list list * (Michelson_v1_primitives.prim list * Script.unlocated_michelson_node) - Entrypoints_map.t) + Entrypoint.Map.t) tzresult val pack_data : -- GitLab From 28a3ea26136b7a9029fd7d30da3949088ab843e9 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 20 Oct 2021 21:26:03 +0200 Subject: [PATCH 08/28] Proto: add Entrypoint.in_memory_size and use it --- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 3 +++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 3 +++ src/proto_alpha/lib_protocol/operation_repr.ml | 2 +- src/proto_alpha/lib_protocol/script_typed_ir_size.ml | 7 ++++--- 4 files changed, 11 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index ed56e1499d17..5b1635b8836e 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -37,5 +37,8 @@ let set_delegate = "set_delegate" let remove_delegate = "remove_delegate" +let in_memory_size name = + Cache_memory_helpers.string_size_gen (String.length name) + module Set = Set.Make (String) module Map = Map.Make (String) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index db7f2749da6f..ce8ac00a468d 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -47,6 +47,9 @@ val set_delegate : t (** Entrypoint "remove_delegate" *) val remove_delegate : t +(** In-memory size of an entrypoint *) +val in_memory_size : t -> Saturation_repr.may_saturate Saturation_repr.t + (** Set of entrypoints *) module Set : Set.S with type elt = t diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 8adba4d30fd9..a7a6f7beafd6 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -1179,7 +1179,7 @@ let internal_manager_operation_size (type a) (op : a manager_operation) = ret_adding (script_lazy_expr_size parameters) (h4w +! int64_size - +! string_size_gen (String.length entrypoint) + +! Entrypoint_repr.in_memory_size entrypoint +! Contract_repr.in_memory_size destination) | Origination {delegate; script; credit = _; preorigination} -> ret_adding 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 6b18c1b1f50a..8956411d673d 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -137,7 +137,8 @@ let timestamp_size x = Script_timestamp.to_zint x |> z_size let contract_size = Contract.in_memory_size -let address_size ((c, s) : address) = h2w +! contract_size c +! string_size s +let address_size ((c, s) : address) = + h2w +! contract_size c +! Entrypoint.in_memory_size s let view_signature_size (View_signature {name; input_ty; output_ty}) = ret_adding @@ -521,7 +522,7 @@ and kinstr_size : | IContract (kinfo, ty, s, _) -> ret_succ_adding (accu ++ ty_size ty) - (base kinfo +! string_size s +! (word_size *? 2)) + (base kinfo +! Entrypoint.in_memory_size s +! (word_size *? 2)) | IView (kinfo, s, _) -> ret_succ_adding (accu ++ view_signature_size s) (base kinfo +! word_size) | ITransfer_tokens (kinfo, _) -> ret_succ_adding accu (base kinfo) @@ -553,7 +554,7 @@ and kinstr_size : | ISelf (kinfo, ty, s, _) -> ret_succ_adding (accu ++ ty_size ty) - (base kinfo +! (word_size *? 2) +! string_size s) + (base kinfo +! (word_size *? 2) +! Entrypoint.in_memory_size s) | ISelf_address (kinfo, _) -> ret_succ_adding accu (base kinfo) | IAmount (kinfo, _) -> ret_succ_adding accu (base kinfo) | ISapling_empty_state (kinfo, _m, _) -> -- GitLab From dfdeae2be35771245272ac3bfacd28abe76ebe48 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 20 Oct 2021 21:30:18 +0200 Subject: [PATCH 09/28] Proto: add Entrypoint.pp and use it --- src/proto_alpha/lib_client/client_proto_fa12.ml | 6 +++++- src/proto_alpha/lib_client/client_proto_multisig.ml | 3 ++- src/proto_alpha/lib_client/managed_contract.ml | 6 ++++-- .../lib_client/michelson_v1_entrypoints.ml | 9 ++++++--- .../lib_client/michelson_v1_error_reporter.ml | 12 ++++++++++-- src/proto_alpha/lib_client/operation_result.ml | 2 +- .../client_proto_multisig_commands.ml | 3 ++- src/proto_alpha/lib_plugin/plugin.ml | 9 ++++++--- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 2 ++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 3 +++ 10 files changed, 41 insertions(+), 14 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_fa12.ml b/src/proto_alpha/lib_client/client_proto_fa12.ml index ec9546e9d863..ca0ad9028841 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.ml +++ b/src/proto_alpha/lib_client/client_proto_fa12.ml @@ -135,7 +135,11 @@ let () = "A transaction made a call on an entrypoint expecting it to implement \ the 'view' type." ~pp:(fun ppf entrypoint -> - Format.fprintf ppf "Entrypoint %s is not viewable." entrypoint) + Format.fprintf + ppf + "Entrypoint %a is not viewable." + Entrypoint.pp + entrypoint) Data_encoding.(obj1 (req "entrypoint" string)) (function Not_a_viewable_entrypoint e -> Some e | _ -> None) (fun e -> Not_a_viewable_entrypoint e) ; diff --git a/src/proto_alpha/lib_client/client_proto_multisig.ml b/src/proto_alpha/lib_client/client_proto_multisig.ml index 21f574df9ef4..0eba5605f8cb 100644 --- a/src/proto_alpha/lib_client/client_proto_multisig.ml +++ b/src/proto_alpha/lib_client/client_proto_multisig.ml @@ -307,8 +307,9 @@ let () = ~pp:(fun ppf (destination, entrypoint, parameter_ty, parameter) -> Format.fprintf ppf - "The entrypoint %s of contract %a called from a multisig contract is \ + "The entrypoint %a of contract %a called from a multisig contract is \ of type %a; the provided parameter %a is ill-typed." + Entrypoint.pp entrypoint Contract.pp destination diff --git a/src/proto_alpha/lib_client/managed_contract.ml b/src/proto_alpha/lib_client/managed_contract.ml index bcf4ddb2a56d..c32f65aed841 100644 --- a/src/proto_alpha/lib_client/managed_contract.ml +++ b/src/proto_alpha/lib_client/managed_contract.ml @@ -233,8 +233,9 @@ let build_transaction_operation (cctxt : #full) ~chain ~block ~contract return @@ build_lambda_for_transfer_to_implicit ~destination ~amount | Some _ -> cctxt#error - "Implicit accounts have no entrypoints. (targeted entrypoint %%%s on \ + "Implicit accounts have no entrypoints. (targeted entrypoint %%%a on \ contract %a)" + Entrypoint.pp entrypoint Contract.pp destination @@ -248,9 +249,10 @@ let build_transaction_operation (cctxt : #full) ~chain ~block ~contract >>=? function | None -> cctxt#error - "Contract %a has no entrypoint named %s" + "Contract %a has no entrypoint named %a" Contract.pp destination + Entrypoint.pp entrypoint | Some parameter_type -> return parameter_type) >>=? fun parameter_type -> diff --git a/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml b/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml index 915ff5a078a0..190b42bfb515 100644 --- a/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml @@ -79,20 +79,23 @@ let print_entrypoint_type (cctxt : #Client_context.printer) | Ok (Some ty) -> (if emacs then cctxt#message - "@[((entrypoint . %s) (type . %a))@]@." + "@[((entrypoint . %a) (type . %a))@]@." + Entrypoint.pp entrypoint Michelson_v1_emacs.print_expr ty else cctxt#message - "@[Entrypoint %s: %a@]@." + "@[Entrypoint %a: %a@]@." + Entrypoint.pp entrypoint Michelson_v1_printer.print_expr ty) >>= fun () -> return_unit | Ok None -> cctxt#message - "@[No entrypoint named %s%a%a@]@." + "@[No entrypoint named %a%a%a@]@." + Entrypoint.pp entrypoint (Format.pp_print_option (fun ppf -> Format.fprintf ppf " for contract %a" Contract.pp)) 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 a4c218288a9b..88250bf7bf38 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -209,11 +209,19 @@ let report_errors ~details ~show_source ?parsed ppf errs = if rest <> [] then Format.fprintf ppf "@," ; print_trace (parsed_locations parsed) rest | Environment.Ecoproto_error (No_such_entrypoint entrypoint) :: rest -> - Format.fprintf ppf "Contract has no entrypoint named %s" entrypoint ; + Format.fprintf + ppf + "Contract has no entrypoint named %a" + Entrypoint.pp + entrypoint ; if rest <> [] then Format.fprintf ppf "@," ; print_trace locations rest | Environment.Ecoproto_error (Duplicate_entrypoint entrypoint) :: rest -> - Format.fprintf ppf "Contract has two entrypoints named %s" entrypoint ; + Format.fprintf + ppf + "Contract has two entrypoints named %a" + Entrypoint.pp + entrypoint ; if rest <> [] then Format.fprintf ppf "@," ; print_trace locations rest | Environment.Ecoproto_error (Unreachable_entrypoint path) :: rest -> diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index 9fa016a871ca..6bcf9302da40 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -44,7 +44,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf Contract.pp destination ; if not (Entrypoint.is_default entrypoint) then - Format.fprintf ppf "@,Entrypoint: %s" entrypoint ; + Format.fprintf ppf "@,Entrypoint: %a" Entrypoint.pp entrypoint ; (if not (Script_repr.is_unit_parameter parameters) then let expr = WithExceptions.Option.to_exn diff --git a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml index f22377a67b44..a03e5a04c396 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml @@ -156,9 +156,10 @@ let get_parameter_type (cctxt : #Protocol_client_context.full) ~destination >>=? function | None -> cctxt#error - "Contract %a has no entrypoint named %s" + "Contract %a has no entrypoint named %a" Contract.pp destination + Entrypoint.pp entrypoint | Some parameter_type -> return parameter_type) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index b881826a459a..60ab0e429095 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -949,8 +949,9 @@ module View_helpers = struct ~pp:(fun ppf (entrypoint, typ) -> Format.fprintf ppf - "The view %s has type %a, it is not compatible with a TZIP-4 view \ + "The view %a has type %a, it is not compatible with a TZIP-4 view \ type." + Entrypoint.pp entrypoint Micheline_printer.print_expr (Micheline_printer.printable @@ -970,8 +971,9 @@ module View_helpers = struct ~pp:(fun ppf (entrypoint, callback) -> Format.fprintf ppf - "The view %s never initiated a transaction to the given callback \ + "The view %a never initiated a transaction to the given callback \ contract %a." + Entrypoint.pp entrypoint Contract.pp callback) @@ -989,9 +991,10 @@ module View_helpers = struct ~pp:(fun ppf (entrypoint, callback) -> Format.fprintf ppf - "The view %s initiated a list of operations while the TZIP-4 \ + "The view %a initiated a list of operations while the TZIP-4 \ standard expects only a transaction to the given callback contract \ %a." + Entrypoint.pp entrypoint Contract.pp callback) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 5b1635b8836e..a4cde3884da5 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -37,6 +37,8 @@ let set_delegate = "set_delegate" let remove_delegate = "remove_delegate" +let pp = Format.pp_print_string + let in_memory_size name = Cache_memory_helpers.string_size_gen (String.length name) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index ce8ac00a468d..6be1cb962226 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -47,6 +47,9 @@ val set_delegate : t (** Entrypoint "remove_delegate" *) val remove_delegate : t +(** Pretty-print an entrypoint *) +val pp : Format.formatter -> t -> unit + (** In-memory size of an entrypoint *) val in_memory_size : t -> Saturation_repr.may_saturate Saturation_repr.t -- GitLab From fdf81cc38ab5e4ffc1c3c354180e80e7130dc7b6 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 18 Nov 2021 15:50:17 +0100 Subject: [PATCH 10/28] Proto: add Entrypoint.to_address_suffix and use it --- src/proto_alpha/lib_client/managed_contract.ml | 2 +- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 2 ++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 5 +++++ src/proto_alpha/lib_protocol/script_ir_translator.ml | 4 +--- 4 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_client/managed_contract.ml b/src/proto_alpha/lib_client/managed_contract.ml index c32f65aed841..714f36861bbb 100644 --- a/src/proto_alpha/lib_client/managed_contract.ml +++ b/src/proto_alpha/lib_client/managed_contract.ml @@ -201,7 +201,7 @@ let build_lambda_for_transfer_to_originated ~destination ~entrypoint ~amount in let amount = Tez.to_mutez amount in let (`Hex destination) = Hex.of_bytes destination in - let entrypoint = match entrypoint with "default" -> "" | s -> "%" ^ s in + let entrypoint = Entrypoint.to_address_suffix entrypoint in if parameter_type = t_unit then Format.asprintf "{ DROP ; NIL operation ;PUSH address 0x%s; CONTRACT %s %a; \ diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index a4cde3884da5..037a0cce38b7 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -37,6 +37,8 @@ let set_delegate = "set_delegate" let remove_delegate = "remove_delegate" +let to_address_suffix name = if is_default name then "" else "%" ^ name + let pp = Format.pp_print_string let in_memory_size name = diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 6be1cb962226..7b15cf6146f8 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -47,6 +47,11 @@ val set_delegate : t (** Entrypoint "remove_delegate" *) val remove_delegate : t +(** Converts an entrypoint to a string used as an address suffix. + For the default entrypoint, the result is the empty string. + Otherwise it is "%" followed by the entrypoint. *) +val to_address_suffix : t -> string + (** Pretty-print an entrypoint *) val pp : Format.formatter -> t -> unit diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index aea9f2d9c008..cae5fa5abed5 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -485,9 +485,7 @@ let unparse_address ~loc ctxt mode (c, entrypoint) = (Bytes (loc, bytes), ctxt) | Readable -> let notation = - match entrypoint with - | "default" -> Contract.to_b58check c - | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint + Contract.to_b58check c ^ Entrypoint.to_address_suffix entrypoint in (String (loc, notation), ctxt) -- GitLab From 93300b3c736dc21a8c3d3b548371ba6451879425 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 20 Oct 2021 22:15:34 +0200 Subject: [PATCH 11/28] Proto: add Entrypoint.of_string_strict_exn and use it --- .../lib_benchmark/michelson_samplers.ml | 5 +++- .../lib_client/client_proto_fa12.ml | 18 +++++++++----- .../lib_client/client_proto_multisig.ml | 4 +++- .../lib_client/managed_contract.ml | 2 +- .../test/test_client_proto_context.ml | 3 ++- .../lib_protocol/entrypoint_repr.ml | 24 +++++++++++++++++++ .../lib_protocol/entrypoint_repr.mli | 5 ++++ .../lib_protocol/test/helpers/cpmm_repr.ml | 12 +++++----- .../test/helpers/lqt_fa12_repr.ml | 4 ++-- .../lib_protocol/test/test_transfer.ml | 4 ++-- 10 files changed, 61 insertions(+), 20 deletions(-) diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index 41980dd4fd07..de8979d2abe2 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -502,7 +502,10 @@ end) Alpha_context.Contract.encoding string in - let ep = Base_samplers.string ~size:{min = 1; max = 31} rng_state in + let ep = + Alpha_context.Entrypoint.of_string_strict_exn + @@ Base_samplers.string ~size:{min = 1; max = 31} rng_state + in (contract, ep) let chain_id rng_state = diff --git a/src/proto_alpha/lib_client/client_proto_fa12.ml b/src/proto_alpha/lib_client/client_proto_fa12.ml index ca0ad9028841..5403011c778b 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.ml +++ b/src/proto_alpha/lib_client/client_proto_fa12.ml @@ -695,12 +695,18 @@ let check_entrypoint entrypoints (name, (expected_ty, check)) = (name, Some (ty, Micheline.strip_locations expected_ty))) else Ok () -let action_to_entrypoint = function - | Transfer (_, _, _) -> "transfer" - | Approve (_, _) -> "approve" - | Get_allowance (_, _, _) -> "getAllowance" - | Get_balance (_, _) -> "getBalance" - | Get_total_supply _ -> "getTotalSupply" +let action_to_entrypoint = + let transfer = Entrypoint.of_string_strict_exn "transfer" in + let approve = Entrypoint.of_string_strict_exn "approve" in + let get_allowance = Entrypoint.of_string_strict_exn "getAllowance" in + let get_balance = Entrypoint.of_string_strict_exn "getBalance" in + let get_total_supply = Entrypoint.of_string_strict_exn "getTotalSupply" in + function + | Transfer (_, _, _) -> transfer + | Approve (_, _) -> approve + | Get_allowance (_, _, _) -> get_allowance + | Get_balance (_, _) -> get_balance + | Get_total_supply _ -> get_total_supply let contract_has_fa12_interface : #Protocol_client_context.rpc_context -> diff --git a/src/proto_alpha/lib_client/client_proto_multisig.ml b/src/proto_alpha/lib_client/client_proto_multisig.ml index 0eba5605f8cb..35d489c37999 100644 --- a/src/proto_alpha/lib_client/client_proto_multisig.ml +++ b/src/proto_alpha/lib_client/client_proto_multisig.ml @@ -481,6 +481,8 @@ type multisig_contract_description = { (list operation)). *) } +let entrypoint_main = Entrypoint.of_string_strict_exn "main" + (* List of known multisig contracts hashes with their kinds *) let known_multisig_contracts : multisig_contract_description list = [ @@ -492,7 +494,7 @@ let known_multisig_contracts : multisig_contract_description list = See docs/user/multisig.rst for more details. *) hash = multisig_script_hash; requires_chain_id = true; - main_entrypoint = Some "main"; + main_entrypoint = Some entrypoint_main; generic = true; }; { diff --git a/src/proto_alpha/lib_client/managed_contract.ml b/src/proto_alpha/lib_client/managed_contract.ml index 714f36861bbb..676a7d95b03b 100644 --- a/src/proto_alpha/lib_client/managed_contract.ml +++ b/src/proto_alpha/lib_client/managed_contract.ml @@ -273,7 +273,7 @@ let build_transaction_operation (cctxt : #full) ~chain ~block ~contract ~parameter) >>=? fun lambda -> parse lambda >>=? fun parameters -> - let entrypoint = "do" in + let entrypoint = entrypoint_do in return (Client_proto_context.build_transaction_operation ~amount:Tez.zero diff --git a/src/proto_alpha/lib_client/test/test_client_proto_context.ml b/src/proto_alpha/lib_client/test/test_client_proto_context.ml index ee5786be4739..b970b0491dca 100644 --- a/src/proto_alpha/lib_client/test/test_client_proto_context.ml +++ b/src/proto_alpha/lib_client/test/test_client_proto_context.ml @@ -53,7 +53,8 @@ let arb_batch_transfer_operation_encoding : let* storage_limit = opt gen_z in let* amount = string ?gen:None in let* arg = opt string in - let* entrypoint = opt string in + let* entrypoint = opt (string_size (1 -- 31)) in + let entrypoint = Option.map Entrypoint.of_string_strict_exn entrypoint in return Client_proto_context. {destination; fee; gas_limit; storage_limit; amount; arg; entrypoint} diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 037a0cce38b7..2245d7cef77e 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -23,12 +23,36 @@ (* *) (*****************************************************************************) +(** Invariants on the string: 1 <= length <= 31 *) include Compare.String let default = "default" let is_default name = name = default +type of_string_result = + | Ok of t + | Too_long (** length > 31 *) + | Got_default + (** Got exactly "default", which can be an error in some cases or OK in others *) + +let of_string str = + if str = "" then + (* The empty string always means the default entrypoint *) + Ok default + else if Compare.Int.(String.length str > 31) then Too_long + else if is_default str then Got_default + else Ok str + +let of_string_strict' str = + match of_string str with + | Too_long -> Error "Entrypoint name too long" + | Got_default -> Error "Unexpected annotation: default" + | Ok name -> Ok name + +let of_string_strict_exn str = + match of_string_strict' str with Ok v -> v | Error err -> invalid_arg err + let root = "root" let do_ = "do" diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 7b15cf6146f8..f3153c20b7e9 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -47,6 +47,11 @@ val set_delegate : t (** Entrypoint "remove_delegate" *) val remove_delegate : t +(** Converts a string to an entrypoint. + Fails with [Invalid_arg] if the string is too long or is "default". + Converts "" to "default". *) +val of_string_strict_exn : string -> t + (** Converts an entrypoint to a string used as an address suffix. For the default entrypoint, the result is the empty string. Otherwise it is "%" followed by the entrypoint. *) diff --git a/src/proto_alpha/lib_protocol/test/helpers/cpmm_repr.ml b/src/proto_alpha/lib_protocol/test/helpers/cpmm_repr.ml index deb7fdd42a42..0af1c8c6e29f 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/cpmm_repr.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/cpmm_repr.ml @@ -279,12 +279,12 @@ module Parameter = struct Format.asprintf "XtzToToken (%s)" (xtz_to_token_to_string p) let entrypoint_of_parameter : t -> Entrypoint.t = function - | AddLiquidity _ -> "addLiquidity" - | Default _ -> "default" - | RemoveLiquidity _ -> "removeLiquidity" - | TokenToToken _ -> "tokenToToken" - | TokenToXtz _ -> "tokenToXtz" - | XtzToToken _ -> "xtzToToken" + | AddLiquidity _ -> Entrypoint.of_string_strict_exn "addLiquidity" + | Default _ -> Entrypoint.default + | RemoveLiquidity _ -> Entrypoint.of_string_strict_exn "removeLiquidity" + | TokenToToken _ -> Entrypoint.of_string_strict_exn "tokenToToken" + | TokenToXtz _ -> Entrypoint.of_string_strict_exn "tokenToXtz" + | XtzToToken _ -> Entrypoint.of_string_strict_exn "xtzToToken" let pp fmt s = Format.fprintf fmt "%s" (to_string s) diff --git a/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml b/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml index 216dff3768be..43c9dab4a1c5 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml @@ -70,8 +70,8 @@ module Parameter = struct | MintOrBurn p -> Format.asprintf "MintOrBurn %s" (mint_or_burn_to_string p) let entrypoint_of_parameter : t -> Entrypoint.t = function - | Approve _ -> "approve" - | MintOrBurn _ -> "mintOrBurn" + | Approve _ -> Entrypoint.of_string_strict_exn "approve" + | MintOrBurn _ -> Entrypoint.of_string_strict_exn "mintOrBurn" let pp fmt s = Format.fprintf fmt "%s" (to_string s) diff --git a/src/proto_alpha/lib_protocol/test/test_transfer.ml b/src/proto_alpha/lib_protocol/test/test_transfer.ml index a5d14baa5254..8a6f0f2f96c1 100644 --- a/src/proto_alpha/lib_protocol/test/test_transfer.ml +++ b/src/proto_alpha/lib_protocol/test/test_transfer.ml @@ -632,7 +632,7 @@ let test_bad_entrypoint () = let ctxt = Incremental.alpha_ctxt v in let storage = "Unit" in let parameter = "Unit" in - let entrypoint = "bad entrypoint" in + let entrypoint = Entrypoint.of_string_strict_exn "bad entrypoint" in (* bad entrypoint *) Contract_helpers.run_script ctxt @@ -680,7 +680,7 @@ let test_bad_parameter () = Alcotest.failf "Unexpected error: %a" Error_monad.pp_print_trace errs let transfer_to_itself_with_no_such_entrypoint () = - let entrypoint = "bad entrypoint" in + let entrypoint = Entrypoint.of_string_strict_exn "bad entrypoint" in Context.init 1 >>=? fun (b, contract) -> Incremental.begin_construction b >>=? fun i -> let addr = match contract with [hd] -> hd | _ -> assert false in -- GitLab From a9ba62887569d2ed7c0f0edbccd41cb5a41a5b95 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 20 Oct 2021 22:25:24 +0200 Subject: [PATCH 12/28] Proto: move Entrypoint_name_too_long to Entrypoint module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 14 ++++++++++++++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 2 ++ .../lib_protocol/script_ir_translator.ml | 10 +++++----- src/proto_alpha/lib_protocol/script_tc_errors.ml | 2 -- .../lib_protocol/script_tc_errors_registration.ml | 11 ----------- 5 files changed, 21 insertions(+), 18 deletions(-) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 2245d7cef77e..fddfc87e3310 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -26,6 +26,20 @@ (** Invariants on the string: 1 <= length <= 31 *) include Compare.String +type error += Name_too_long of string + +let () = + (* Entrypoint name too long *) + register_error_kind + `Permanent + ~id:"michelson_v1.entrypoint_name_too_long" + ~title:"Entrypoint name too long (type error)" + ~description: + "An entrypoint name exceeds the maximum length of 31 characters." + Data_encoding.(obj1 (req "name" string)) + (function Name_too_long entrypoint -> Some entrypoint | _ -> None) + (fun entrypoint -> Name_too_long entrypoint) + let default = "default" let is_default name = name = default diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index f3153c20b7e9..3179d4c52016 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -47,6 +47,8 @@ val set_delegate : t (** Entrypoint "remove_delegate" *) val remove_delegate : t +type error += Name_too_long of string + (** Converts a string to an entrypoint. Fails with [Invalid_arg] if the string is too long or is "default". Converts "" to "default". *) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index cae5fa5abed5..8bbecd90905d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1966,7 +1966,7 @@ let find_entrypoint (type full error_trace) Error (match error_details with | Fast -> (Inconsistent_types_fast : error_trace) - | Informative -> trace_of_error @@ Entrypoint_name_too_long entrypoint) + | Informative -> trace_of_error @@ Entrypoint.Name_too_long entrypoint) else match root_name with | Some (Field_annot root_name) @@ -2022,7 +2022,7 @@ let well_formed_entrypoints (type full) (full : full ty) ~root_name = | Some (Field_annot name) -> let name = (name :> string) in if Compare.Int.(String.length name > 31) then - error (Entrypoint_name_too_long name) + error (Entrypoint.Name_too_long name) else if Entrypoint.Set.mem name all then error (Duplicate_entrypoint name) else ok (first_unreachable, Entrypoint.Set.add name all) @@ -2283,7 +2283,7 @@ let parse_address ctxt : Script.node -> (address * context) tzresult = function with | Some (c, entrypoint) -> ( if Compare.Int.(String.length entrypoint > 31) then - error (Entrypoint_name_too_long entrypoint) + error (Entrypoint.Name_too_long entrypoint) else match entrypoint with | "" -> ok ((c, "default"), ctxt) @@ -2300,7 +2300,7 @@ let parse_address ctxt : Script.node -> (address * context) tzresult = function | Some pos -> ( let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in - if Compare.Int.(len > 31) then error (Entrypoint_name_too_long name) + if Compare.Int.(len > 31) then error (Entrypoint.Name_too_long name) else match (String.sub s 0 pos, name) with | (addr, "") -> ok (addr, "default") @@ -4795,7 +4795,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : if Compare.String.(entrypoint = "default") then error (Unexpected_annotation loc) else if Compare.Int.(String.length entrypoint > 31) then - error (Entrypoint_name_too_long entrypoint) + error (Entrypoint.Name_too_long entrypoint) else Ok entrypoint) >>?= fun entrypoint -> let instr = diff --git a/src/proto_alpha/lib_protocol/script_tc_errors.ml b/src/proto_alpha/lib_protocol/script_tc_errors.ml index bed34f3a951b..42037e726835 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors.ml @@ -68,8 +68,6 @@ type error += Duplicate_entrypoint of Entrypoint.t type error += Unreachable_entrypoint of prim list -type error += Entrypoint_name_too_long of string - (* Instruction typing errors *) type error += Fail_not_in_tail_position of Script.location diff --git a/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml b/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml index 6766bdc3dac1..2d3daa5309a7 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml @@ -241,17 +241,6 @@ let () = (obj1 (req "path" string)) (function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None) (fun entrypoint -> Duplicate_entrypoint entrypoint) ; - (* Entrypoint name too long *) - register_error_kind - `Permanent - ~id:"michelson_v1.entrypoint_name_too_long" - ~title:"Entrypoint name too long (type error)" - ~description: - "An entrypoint name exceeds the maximum length of 31 characters." - (obj1 (req "name" string)) - (function - | Entrypoint_name_too_long entrypoint -> Some entrypoint | _ -> None) - (fun entrypoint -> Entrypoint_name_too_long entrypoint) ; (* Unexpected contract *) register_error_kind `Permanent -- GitLab From 0b6cf58436f78f9be23db82f599b0af98272c46c Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 21 Oct 2021 10:08:39 +0200 Subject: [PATCH 13/28] Proto: add Entrypoint.of_string_strict and use it --- .../lib_protocol/entrypoint_repr.ml | 21 +++++++++++++++++++ .../lib_protocol/entrypoint_repr.mli | 5 +++++ .../lib_protocol/script_ir_translator.ml | 10 +++------ 3 files changed, 29 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index fddfc87e3310..67eac752181f 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -40,6 +40,21 @@ let () = (function Name_too_long entrypoint -> Some entrypoint | _ -> None) (fun entrypoint -> Name_too_long entrypoint) +type error += Unexpected_default of Script_repr.location + +let () = + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_default_entrypoint" + ~title: + "The annotation 'default' was encountered where an entrypoint is expected" + ~description: + "A node in the syntax tree was improperly annotated. An annotation used \ + to designate an entrypoint cannot be exactly 'default'." + Data_encoding.(obj1 (req "location" Script_repr.location_encoding)) + (function Unexpected_default loc -> Some loc | _ -> None) + (fun loc -> Unexpected_default loc) + let default = "default" let is_default name = name = default @@ -58,6 +73,12 @@ let of_string str = else if is_default str then Got_default else Ok str +let of_string_strict ~loc str = + match of_string str with + | Too_long -> error (Name_too_long str) + | Got_default -> error (Unexpected_default loc) + | Ok name -> Ok name + let of_string_strict' str = match of_string str with | Too_long -> Error "Entrypoint name too long" diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 3179d4c52016..a80b0c024615 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -49,6 +49,11 @@ val remove_delegate : t type error += Name_too_long of string +(** Converts a string to an entrypoint. + Returns an error if the string is too long or is "default". + Converts "" to "default". *) +val of_string_strict : loc:Script_repr.location -> string -> t tzresult + (** Converts a string to an entrypoint. Fails with [Invalid_arg] if the string is too long or is "default". Converts "" to "default". *) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 8bbecd90905d..88061eb41c8b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2297,15 +2297,11 @@ let parse_address ctxt : Script.node -> (address * context) tzresult = function Gas.consume ctxt Typecheck_costs.contract >>? fun ctxt -> (match String.index_opt s '%' with | None -> ok (s, Entrypoint.default) - | Some pos -> ( + | Some pos -> let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in - if Compare.Int.(len > 31) then error (Entrypoint.Name_too_long name) - else - match (String.sub s 0 pos, name) with - | (addr, "") -> ok (addr, "default") - | (_, "default") -> error @@ Unexpected_annotation loc - | addr_and_name -> ok addr_and_name)) + Entrypoint.of_string_strict ~loc name >|? fun entrypoint -> + (String.sub s 0 pos, entrypoint)) >>? fun (addr, entrypoint) -> Contract.of_b58check addr >|? fun c -> ((c, entrypoint), ctxt) | expr -> -- GitLab From 9310b15dbf9c619cb53d06d2eff480dfa2cc12c9 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 15 Dec 2021 11:21:34 +0100 Subject: [PATCH 14/28] Tests: adapt error message accordingly --- tests_python/tests_alpha/test_contract.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests_python/tests_alpha/test_contract.py b/tests_python/tests_alpha/test_contract.py index 5941681eeb8e..ba6df8aba777 100644 --- a/tests_python/tests_alpha/test_contract.py +++ b/tests_python/tests_alpha/test_contract.py @@ -2123,9 +2123,10 @@ class TestContractTypeChecking: client.typecheck_data(f'{address_opt}', 'address') client.typecheck_data(f'{address_opt_a}', 'address') + unexpected_default_error = "unexpected_default_entrypoint" unexpected_annotation_error = "unexpected annotation." - with utils.assert_run_failure(unexpected_annotation_error): + with utils.assert_run_failure(unexpected_default_error): client.typecheck_data(f'"{address}%default"', 'address') # 64656661756c74 is "default" in hexa -- GitLab From 530c58481334567532b04d4b4d41a31e32e69b4a Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 21 Oct 2021 10:18:03 +0200 Subject: [PATCH 15/28] Proto: add Entrypoint.of_annot_strict and use it --- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 3 +++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 5 +++++ src/proto_alpha/lib_protocol/script_ir_annot.ml | 4 ++++ src/proto_alpha/lib_protocol/script_ir_annot.mli | 7 +++++++ src/proto_alpha/lib_protocol/script_ir_translator.ml | 10 +--------- 5 files changed, 20 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 67eac752181f..a8982f79049f 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -88,6 +88,9 @@ let of_string_strict' str = let of_string_strict_exn str = match of_string_strict' str with Ok v -> v | Error err -> invalid_arg err +let of_annot_strict ~loc (a : Non_empty_string.t) = + of_string_strict ~loc (a :> string) + let root = "root" let do_ = "do" diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index a80b0c024615..e1f07ff55f6c 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -49,6 +49,11 @@ val remove_delegate : t type error += Name_too_long of string +(** Converts an annot to an entrypoint. + Returns an error if the string is too long or is "default". *) +val of_annot_strict : + loc:Script_repr.location -> Non_empty_string.t -> t tzresult + (** Converts a string to an entrypoint. Returns an error if the string is too long or is "default". Converts "" to "default". *) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 5891d6dae4c1..10fa04a4188e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -129,6 +129,10 @@ let var_to_field_annot : var_annot option -> field_annot option = function | None -> None | Some (Var_annot s) -> Some (Field_annot s) +let field_annot_opt_to_entrypoint_strict ~loc = function + | None -> Ok Entrypoint.default + | Some (Field_annot a) -> Entrypoint.of_annot_strict ~loc a + let default_annot ~default = function None -> default | annot -> annot let gen_access_annot : diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index da53c5071c03..cbb80492287d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -111,6 +111,13 @@ val type_to_var_annot : type_annot option -> var_annot option val var_to_field_annot : var_annot option -> field_annot option +(** Converts a field annot option to an entrypoint. + An error is returned if the field annot is too long or is "default". + [None] is converted to [Some default]. +*) +val field_annot_opt_to_entrypoint_strict : + loc:Script.location -> field_annot option -> Entrypoint.t tzresult + (** Replace an annotation by its default value if it is [None] *) val default_annot : default:'a option -> 'a option -> 'a option diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 88061eb41c8b..ba96cce9ba33 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -4784,15 +4784,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : annot ~default:(gen_access_annot addr_annot default_contract_annot) >>?= fun (annot, entrypoint) -> - (match entrypoint with - | None -> Ok Entrypoint.default - | Some (Field_annot entrypoint) -> - let entrypoint = (entrypoint :> string) in - if Compare.String.(entrypoint = "default") then - error (Unexpected_annotation loc) - else if Compare.Int.(String.length entrypoint > 31) then - error (Entrypoint.Name_too_long entrypoint) - else Ok entrypoint) + Script_ir_annot.field_annot_opt_to_entrypoint_strict ~loc entrypoint >>?= fun entrypoint -> let instr = {apply = (fun kinfo k -> IContract (kinfo, t, entrypoint, k))} -- GitLab From 38496987792f98c2e176cf802295c2cfcc24397f Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 15 Dec 2021 11:47:00 +0100 Subject: [PATCH 16/28] Tests: adapt error message accordingly --- tests_python/tests_alpha/test_contract.py | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tests_python/tests_alpha/test_contract.py b/tests_python/tests_alpha/test_contract.py index ba6df8aba777..25095b8b1108 100644 --- a/tests_python/tests_alpha/test_contract.py +++ b/tests_python/tests_alpha/test_contract.py @@ -506,7 +506,10 @@ class TestContracts: "invalid_self_entrypoint.tz", r'Contract has no entrypoint named D', ), - ("contract_annotation_default.tz", r'unexpected annotation'), + ( + "contract_annotation_default.tz", + r'unexpected_default_entrypoint', + ), # Missing field ( "missing_only_storage_field.tz", -- GitLab From ebe2dc69105f73a3d2f8d51fc3f8e3d6423216ac Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 21 Oct 2021 10:34:09 +0200 Subject: [PATCH 17/28] Proto: add Entrypoint.of_string_lax and use it in client parameters --- src/proto_alpha/lib_client/client_proto_args.ml | 8 ++++++-- src/proto_alpha/lib_client/client_proto_args.mli | 2 ++ .../client_proto_context_commands.ml | 5 ++++- .../client_proto_programs_commands.ml | 10 ++++++++-- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 6 ++++++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 5 +++++ 6 files changed, 31 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_args.ml b/src/proto_alpha/lib_client/client_proto_args.ml index af7d3bbf076d..f933269bc855 100644 --- a/src/proto_alpha/lib_client/client_proto_args.ml +++ b/src/proto_alpha/lib_client/client_proto_args.ml @@ -147,6 +147,10 @@ let data_parameter = Lwt.return @@ Tezos_micheline.Micheline_parser.no_parsing_error @@ Michelson_v1_parser.parse_expression data) +let entrypoint_parameter = + parameter (fun _ str -> + Lwt.return @@ Environment.wrap_tzresult @@ Entrypoint.of_string_lax str) + let init_arg = default_arg ~long:"init" @@ -191,14 +195,14 @@ let entrypoint_arg = ~long:"entrypoint" ~placeholder:"name" ~doc:"entrypoint of the smart contract" - string_parameter + entrypoint_parameter let default_entrypoint_arg = arg ~long:"default-entrypoint" ~placeholder:"name" ~doc:"default entrypoint of the smart contracts" - string_parameter + entrypoint_parameter let force_switch = switch diff --git a/src/proto_alpha/lib_client/client_proto_args.mli b/src/proto_alpha/lib_client/client_proto_args.mli index 35dea2912f35..3b1a2aac0594 100644 --- a/src/proto_alpha/lib_client/client_proto_args.mli +++ b/src/proto_alpha/lib_client/client_proto_args.mli @@ -30,6 +30,8 @@ open Protocol_client_context val tez_sym : string +val entrypoint_parameter : (Entrypoint.t, full) Clic.parameter + val init_arg : (string, full) Clic.arg val fee_arg : (Tez.t option, full) Clic.arg diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 3ed17a5fde5b..9fa5e21205dc 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -330,7 +330,10 @@ let commands_ro () = ~desc:"Get the type of an entrypoint of a contract." no_options (prefixes ["get"; "contract"; "entrypoint"; "type"; "of"] - @@ Clic.string ~name:"entrypoint" ~desc:"the entrypoint to describe" + @@ Clic.param + ~name:"entrypoint" + ~desc:"the entrypoint to describe" + entrypoint_parameter @@ prefixes ["for"] @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) diff --git a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml index e0bc75fb83ab..18048c5e4f08 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml @@ -694,7 +694,10 @@ let commands () = ~desc:"Ask the type of an entrypoint of a script." (args2 emacs_mode_switch no_print_source_flag) (prefixes ["get"; "script"; "entrypoint"; "type"; "of"] - @@ string ~name:"entrypoint" ~desc:"the entrypoint to describe" + @@ param + ~name:"entrypoint" + ~desc:"the entrypoint to describe" + entrypoint_parameter @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun ((emacs_mode, no_print_source) as setup) entrypoint program cctxt -> @@ -937,7 +940,10 @@ let commands () = now_arg level_arg) (prefixes ["run"; "tzip4"; "view"] - @@ param ~name:"entrypoint" ~desc:"the name of the view" string_parameter + @@ param + ~name:"entrypoint" + ~desc:"the name of the view" + entrypoint_parameter @@ prefixes ["on"; "contract"] @@ ContractAlias.destination_param ~name:"contract" diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index a8982f79049f..d3598d311afb 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -91,6 +91,12 @@ let of_string_strict_exn str = let of_annot_strict ~loc (a : Non_empty_string.t) = of_string_strict ~loc (a :> string) +let of_string_lax str = + match of_string str with + | Too_long -> error (Name_too_long str) + | Got_default -> Ok default + | Ok name -> Ok name + let root = "root" let do_ = "do" diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index e1f07ff55f6c..20fbe44e9efe 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -64,6 +64,11 @@ val of_string_strict : loc:Script_repr.location -> string -> t tzresult Converts "" to "default". *) val of_string_strict_exn : string -> t +(** Converts a string to an entrypoint. + Returns an error if the string is too long. + Accepts "default" and converts "" to "default". *) +val of_string_lax : string -> t tzresult + (** Converts an entrypoint to a string used as an address suffix. For the default entrypoint, the result is the empty string. Otherwise it is "%" followed by the entrypoint. *) -- GitLab From ed502d4680620f9954dc2d29486f0d981a22274d Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 29 Oct 2021 19:42:11 +0200 Subject: [PATCH 18/28] Proto: add Entrypoint.of_annot_lax(_opt) and use them --- .../lib_protocol/entrypoint_repr.ml | 17 +++- .../lib_protocol/entrypoint_repr.mli | 10 +++ .../lib_protocol/script_ir_annot.ml | 8 ++ .../lib_protocol/script_ir_annot.mli | 5 ++ .../lib_protocol/script_ir_translator.ml | 87 +++++++++---------- 5 files changed, 75 insertions(+), 52 deletions(-) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index d3598d311afb..97f7868b698a 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -91,11 +91,20 @@ let of_string_strict_exn str = let of_annot_strict ~loc (a : Non_empty_string.t) = of_string_strict ~loc (a :> string) -let of_string_lax str = +let of_string_lax_opt str = match of_string str with - | Too_long -> error (Name_too_long str) - | Got_default -> Ok default - | Ok name -> Ok name + | Too_long -> None + | Got_default -> Some default + | Ok name -> Some name + +let of_annot_lax_opt (a : Non_empty_string.t) = of_string_lax_opt (a :> string) + +let of_string_lax str = + match of_string_lax_opt str with + | None -> error (Name_too_long str) + | Some name -> Ok name + +let of_annot_lax (a : Non_empty_string.t) = of_string_lax (a :> string) let root = "root" diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 20fbe44e9efe..7038cfdb5238 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -64,6 +64,16 @@ val of_string_strict : loc:Script_repr.location -> string -> t tzresult Converts "" to "default". *) val of_string_strict_exn : string -> t +(** Converts an annot to an entrypoint. + Returns an error if the string is too long. + Accepts "default". *) +val of_annot_lax : Non_empty_string.t -> t tzresult + +(** Converts an annot to an entrypoint. + Returns [None] if the string is too long. + Accepts "default". *) +val of_annot_lax_opt : Non_empty_string.t -> t option + (** Converts a string to an entrypoint. Returns an error if the string is too long. Accepts "default" and converts "" to "default". *) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 10fa04a4188e..be5a079c01fe 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -133,6 +133,14 @@ let field_annot_opt_to_entrypoint_strict ~loc = function | None -> Ok Entrypoint.default | Some (Field_annot a) -> Entrypoint.of_annot_strict ~loc a +let field_annot_opt_eq_entrypoint_lax field_annot_opt entrypoint = + match field_annot_opt with + | None -> false + | Some (Field_annot a) -> ( + match Entrypoint.of_annot_lax_opt a with + | None -> false + | Some a' -> Compare.String.(a' = entrypoint)) + let default_annot ~default = function None -> default | annot -> annot let gen_access_annot : diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index cbb80492287d..302bb9917b11 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -118,6 +118,11 @@ val var_to_field_annot : var_annot option -> field_annot option val field_annot_opt_to_entrypoint_strict : loc:Script.location -> field_annot option -> Entrypoint.t tzresult +(** Checks whether a field annot option equals an entrypoint. + When the field annot option is [None], the result is always [false]. *) +val field_annot_opt_eq_entrypoint_lax : + field_annot option -> Entrypoint.t -> bool + (** Replace an annotation by its default value if it is [None] *) val default_annot : default:'a option -> 'a option -> 'a option diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index ba96cce9ba33..d5067024b2fb 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1934,10 +1934,6 @@ type 'before dup_n_proof_argument = let find_entrypoint (type full error_trace) ~(error_details : error_trace error_details) (full : full ty) ~root_name entrypoint : ((Script.node -> Script.node) * ex_ty, error_trace) result = - let annot_is_entrypoint entrypoint = function - | None -> false - | Some (Field_annot l) -> Compare.String.((l :> string) = entrypoint) - in let loc = Micheline.dummy_location in let rec find_entrypoint : type t. @@ -1945,9 +1941,9 @@ let find_entrypoint (type full error_trace) fun t entrypoint -> match t with | Union_t ((tl, al), (tr, ar), _) -> ( - if annot_is_entrypoint entrypoint al then + if field_annot_opt_eq_entrypoint_lax al entrypoint then Some ((fun e -> Prim (loc, D_Left, [e], [])), Ex_ty tl) - else if annot_is_entrypoint entrypoint ar then + else if field_annot_opt_eq_entrypoint_lax ar entrypoint then Some ((fun e -> Prim (loc, D_Right, [e], [])), Ex_ty tr) else match find_entrypoint tl entrypoint with @@ -1967,23 +1963,18 @@ let find_entrypoint (type full error_trace) (match error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative -> trace_of_error @@ Entrypoint.Name_too_long entrypoint) + else if field_annot_opt_eq_entrypoint_lax root_name entrypoint then + ok ((fun e -> e), Ex_ty full) else - match root_name with - | Some (Field_annot root_name) - when Compare.String.(entrypoint = (root_name :> string)) -> - ok ((fun e -> e), Ex_ty full) - | _ -> ( - match find_entrypoint full entrypoint with - | Some result -> ok result - | None -> - if Entrypoint.is_default entrypoint then - ok ((fun e -> e), Ex_ty full) - else - Error - (match error_details with - | Fast -> (Inconsistent_types_fast : error_trace) - | Informative -> trace_of_error @@ No_such_entrypoint entrypoint) - ) + match find_entrypoint full entrypoint with + | Some result -> ok result + | None -> + if Entrypoint.is_default entrypoint then ok ((fun e -> e), Ex_ty full) + else + Error + (match error_details with + | Fast -> (Inconsistent_types_fast : error_trace) + | Informative -> trace_of_error @@ No_such_entrypoint entrypoint) let find_entrypoint_for_type (type full exp error_trace) ~legacy ~error_details ~(full : full ty) ~(expected : exp ty) ~root_name entrypoint loc : @@ -2020,11 +2011,8 @@ let well_formed_entrypoints (type full) (full : full ty) ~root_name = | None -> (Some (List.rev path), all) | Some _ -> acc)) | Some (Field_annot name) -> - let name = (name :> string) in - if Compare.Int.(String.length name > 31) then - error (Entrypoint.Name_too_long name) - else if Entrypoint.Set.mem name all then - error (Duplicate_entrypoint name) + Entrypoint.of_annot_lax name >>? fun name -> + if Entrypoint.Set.mem name all then error (Duplicate_entrypoint name) else ok (first_unreachable, Entrypoint.Set.add name all) in let rec check : @@ -2055,8 +2043,10 @@ let well_formed_entrypoints (type full) (full : full ty) ~root_name = let (init, reachable) = match root_name with | None -> (Entrypoint.Set.empty, false) - | Some (Field_annot name) -> - (Entrypoint.Set.singleton (name :> string), true) + | Some (Field_annot name) -> ( + match Entrypoint.of_annot_lax_opt name with + | None -> (Entrypoint.Set.empty, false) + | Some name -> (Entrypoint.Set.singleton name, true)) in check full [] reachable (None, init) >>? fun (first_unreachable, all) -> if not (Entrypoint.Set.mem Entrypoint.default all) then Result.return_unit @@ -4980,12 +4970,10 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Lwt.return ( parse_entrypoint_annot loc annot ~default:default_self_annot >>? fun (annot, entrypoint) -> - let entrypoint = - Option.fold - ~some:(fun (Field_annot annot) -> (annot :> string)) - ~none:Entrypoint.default - entrypoint - in + (match entrypoint with + | None -> Ok Entrypoint.default + | Some (Field_annot annot) -> Entrypoint.of_annot_lax annot) + >>? fun entrypoint -> let open Tc_context in match tc_context.callsite with | _ when is_in_lambda tc_context -> @@ -5892,17 +5880,17 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = match ty with | Union_t _ -> acc | _ -> (List.rev path :: unreachables, all)) - | Some (Field_annot name) -> - let name = (name :> string) in - if Compare.Int.(String.length name > 31) then - ok (List.rev path :: unreachables, all) - else if Entrypoint.Map.mem name all then - ok (List.rev path :: unreachables, all) - else - unparse_ty ~loc:() ctxt ty >>? fun (unparsed_ty, _) -> - ok - ( unreachables, - Entrypoint.Map.add name (List.rev path, unparsed_ty) all ) + | Some (Field_annot name) -> ( + match Entrypoint.of_annot_lax_opt name with + | None -> ok (List.rev path :: unreachables, all) + | Some name -> + if Entrypoint.Map.mem name all then + ok (List.rev path :: unreachables, all) + else + unparse_ty ~loc:() ctxt ty >>? fun (unparsed_ty, _) -> + ok + ( unreachables, + Entrypoint.Map.add name (List.rev path, unparsed_ty) all )) in let rec fold_tree : type t. @@ -5936,8 +5924,11 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = let (init, reachable) = match root_name with | None -> (Entrypoint.Map.empty, false) - | Some (Field_annot name) -> - (Entrypoint.Map.singleton (name :> string) ([], unparsed_full), true) + | Some (Field_annot name) -> ( + match Entrypoint.of_annot_lax_opt name with + | None -> (Entrypoint.Map.empty, false) + | Some name -> (Entrypoint.Map.singleton name ([], unparsed_full), true) + ) in fold_tree full [] reachable ([], init) [@@coq_axiom_with_reason "unsupported syntax"] -- GitLab From 648c241f75d89fba58ae30b4cafcb13c137b29a7 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 29 Oct 2021 20:11:00 +0200 Subject: [PATCH 19/28] Proto: add Entrypoint.simple_encoding and use it MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- .../lib_client/client_proto_context.ml | 2 +- .../lib_client/client_proto_fa12.ml | 2 +- .../lib_client/client_proto_multisig.ml | 2 +- src/proto_alpha/lib_plugin/plugin.ml | 18 ++++++++++++------ .../lib_protocol/entrypoint_repr.ml | 12 ++++++++++++ .../lib_protocol/entrypoint_repr.mli | 5 +++++ .../script_tc_errors_registration.ml | 4 ++-- 7 files changed, 34 insertions(+), 11 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index f4aec8fa3f2d..97b2768cf793 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -503,7 +503,7 @@ let batch_transfer_operation_encoding = (opt "storage-limit" z) (req "amount" string) (opt "arg" string) - (opt "entrypoint" string)) + (opt "entrypoint" Entrypoint.simple_encoding)) let read_key key = match Bip39.of_words key.mnemonic with diff --git a/src/proto_alpha/lib_client/client_proto_fa12.ml b/src/proto_alpha/lib_client/client_proto_fa12.ml index 5403011c778b..e200354baeea 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.ml +++ b/src/proto_alpha/lib_client/client_proto_fa12.ml @@ -140,7 +140,7 @@ let () = "Entrypoint %a is not viewable." Entrypoint.pp entrypoint) - Data_encoding.(obj1 (req "entrypoint" string)) + Data_encoding.(obj1 (req "entrypoint" Entrypoint.simple_encoding)) (function Not_a_viewable_entrypoint e -> Some e | _ -> None) (fun e -> Not_a_viewable_entrypoint e) ; register_error_kind diff --git a/src/proto_alpha/lib_client/client_proto_multisig.ml b/src/proto_alpha/lib_client/client_proto_multisig.ml index 35d489c37999..6dabed72e1c9 100644 --- a/src/proto_alpha/lib_client/client_proto_multisig.ml +++ b/src/proto_alpha/lib_client/client_proto_multisig.ml @@ -320,7 +320,7 @@ let () = Data_encoding.( obj4 (req "destination" Contract.encoding) - (req "entrypoint" string) + (req "entrypoint" Entrypoint.simple_encoding) (req "parameter_ty" Script.expr_encoding) (req "parameter" Script.expr_encoding)) (function diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 60ab0e429095..118996409471 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -958,7 +958,9 @@ module View_helpers = struct (fun x -> x) (Michelson_v1_primitives.strings_of_prims typ))) Data_encoding.( - obj2 (req "entrypoint" string) (req "type" Script.expr_encoding)) + obj2 + (req "entrypoint" Entrypoint.simple_encoding) + (req "type" Script.expr_encoding)) (function Illformed_view_type (etp, exp) -> Some (etp, exp) | _ -> None) (fun (etp, exp) -> Illformed_view_type (etp, exp)) ; Environment.Error_monad.register_error_kind @@ -978,7 +980,9 @@ module View_helpers = struct Contract.pp callback) Data_encoding.( - obj2 (req "entrypoint" string) (req "callback" Contract.encoding)) + obj2 + (req "entrypoint" Entrypoint.simple_encoding) + (req "callback" Contract.encoding)) (function View_never_returns (e, c) -> Some (e, c) | _ -> None) (fun (e, c) -> View_never_returns (e, c)) ; Environment.Error_monad.register_error_kind @@ -999,7 +1003,9 @@ module View_helpers = struct Contract.pp callback) Data_encoding.( - obj2 (req "entrypoint" string) (req "callback" Contract.encoding)) + obj2 + (req "entrypoint" Entrypoint.simple_encoding) + (req "callback" Contract.encoding)) (function View_never_returns (e, c) -> Some (e, c) | _ -> None) (fun (e, c) -> View_never_returns (e, c)) @@ -1190,7 +1196,7 @@ module RPC = struct (opt "source" Contract.encoding) (opt "payer" Contract.encoding) (opt "gas" Gas.Arith.z_integral_encoding) - (dft "entrypoint" string Entrypoint.default)) + (dft "entrypoint" Entrypoint.simple_encoding Entrypoint.default)) (obj3 (opt "unparsing_mode" unparsing_mode_encoding) (opt "now" Script_timestamp.encoding) @@ -1248,7 +1254,7 @@ module RPC = struct let open Data_encoding in obj10 (req "contract" Contract.encoding) - (req "entrypoint" string) + (req "entrypoint" Entrypoint.simple_encoding) (req "input" Script.expr_encoding) (req "chain_id" Chain_id.encoding) (opt "source" Contract.encoding) @@ -1409,7 +1415,7 @@ module RPC = struct ~input: (obj2 (req "script" Script.expr_encoding) - (dft "entrypoint" string Entrypoint.default)) + (dft "entrypoint" Entrypoint.simple_encoding Entrypoint.default)) ~output:(obj1 (req "entrypoint_type" Script.expr_encoding)) RPC_path.(path / "entrypoint") diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 97f7868b698a..56fc02211c3b 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -106,6 +106,11 @@ let of_string_lax str = let of_annot_lax (a : Non_empty_string.t) = of_string_lax (a :> string) +let of_string_lax' str = + match of_string_lax_opt str with + | None -> Error ("Entrypoint name too long \"" ^ str ^ "\"") + | Some name -> Ok name + let root = "root" let do_ = "do" @@ -118,6 +123,13 @@ let to_address_suffix name = if is_default name then "" else "%" ^ name let pp = Format.pp_print_string +let simple_encoding = + let open Data_encoding in + conv_with_guard + (function "" -> assert false (* invariant violated *) | s -> s) + of_string_lax' + string + let in_memory_size name = Cache_memory_helpers.string_size_gen (String.length name) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 7038cfdb5238..af2ecd1c7f8d 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -87,6 +87,11 @@ val to_address_suffix : t -> string (** Pretty-print an entrypoint *) val pp : Format.formatter -> t -> unit +(** An encoding of entrypoints reusing the lax semantics, + i.e. accepts "default" and converts "" to "default". + Decoding fails if the string is too long. *) +val simple_encoding : t Data_encoding.t + (** In-memory size of an entrypoint *) val in_memory_size : t -> Saturation_repr.may_saturate Saturation_repr.t diff --git a/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml b/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml index 2d3daa5309a7..e63e9c5f764a 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml @@ -220,7 +220,7 @@ let () = ~id:"michelson_v1.no_such_entrypoint" ~title:"No such entrypoint (type error)" ~description:"An entrypoint was not found when calling a contract." - (obj1 (req "entrypoint" string)) + (obj1 (req "entrypoint" Entrypoint.simple_encoding)) (function No_such_entrypoint entrypoint -> Some entrypoint | _ -> None) (fun entrypoint -> No_such_entrypoint entrypoint) ; (* Unreachable entrypoint *) @@ -238,7 +238,7 @@ let () = ~id:"michelson_v1.duplicate_entrypoint" ~title:"Duplicate entrypoint (type error)" ~description:"Two entrypoints have the same name." - (obj1 (req "path" string)) + (obj1 (req "path" Entrypoint.simple_encoding)) (function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None) (fun entrypoint -> Duplicate_entrypoint entrypoint) ; (* Unexpected contract *) -- GitLab From 0d128a67a89e88b98197211daae6fa4e167407f4 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 29 Oct 2021 20:21:53 +0200 Subject: [PATCH 20/28] Proto: add Entrypoint.value_encoding and use it --- .../lib_client/client_proto_multisig.ml | 3 +-- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 8 ++++++++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 12 +++++++++--- .../lib_protocol/script_ir_translator.ml | 14 +++----------- 4 files changed, 21 insertions(+), 16 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_multisig.ml b/src/proto_alpha/lib_client/client_proto_multisig.ml index 6dabed72e1c9..4ed8635c4e45 100644 --- a/src/proto_alpha/lib_client/client_proto_multisig.ml +++ b/src/proto_alpha/lib_client/client_proto_multisig.ml @@ -587,11 +587,10 @@ let optimized_key_hash ~loc (key_hash : Signature.Public_key_hash.t) = let optimized_address ~loc ~(address : Contract.t) ~(entrypoint : Entrypoint.t) = - let entrypoint = match entrypoint with "default" -> "" | name -> name in bytes ~loc (Data_encoding.Binary.to_bytes_exn - Data_encoding.(tup2 Contract.encoding Variable.string) + Data_encoding.(tup2 Contract.encoding Entrypoint.value_encoding) (address, entrypoint)) let optimized_key ~loc (key : Signature.Public_key.t) = diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 56fc02211c3b..8efad2b72a8c 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -130,6 +130,14 @@ let simple_encoding = of_string_lax' string +let value_encoding = + let open Data_encoding in + conv_with_guard + (function + | "" -> assert false (* invariant violated*) | "default" -> "" | s -> s) + of_string_strict' + Variable.string + let in_memory_size name = Cache_memory_helpers.string_size_gen (String.length name) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index af2ecd1c7f8d..d1728e68f211 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -87,11 +87,17 @@ val to_address_suffix : t -> string (** Pretty-print an entrypoint *) val pp : Format.formatter -> t -> unit -(** An encoding of entrypoints reusing the lax semantics, - i.e. accepts "default" and converts "" to "default". - Decoding fails if the string is too long. *) +(** An encoding of entrypoints reusing the lax semantics. + Decoding fails if the string is too long. "" is decoded into "default". + "default" is encoded into "default". *) val simple_encoding : t Data_encoding.t +(** An encoding of entrypoints reusing the strict semantics. + Decoding fails if the string is too long or is "default". + "" is decoded into "default". + "default" is encoded into "". *) +val value_encoding : t Data_encoding.t + (** In-memory size of an entrypoint *) val in_memory_size : t -> Saturation_repr.may_saturate Saturation_repr.t diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index d5067024b2fb..add36785557f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -476,10 +476,9 @@ let unparse_address ~loc ctxt mode (c, entrypoint) = >|? fun () -> match mode with | Optimized | Optimized_legacy -> - let entrypoint = match entrypoint with "default" -> "" | name -> name in let bytes = Data_encoding.Binary.to_bytes_exn - Data_encoding.(tup2 Contract.encoding Variable.string) + Data_encoding.(tup2 Contract.encoding Entrypoint.value_encoding) (c, entrypoint) in (Bytes (loc, bytes), ctxt) @@ -2268,17 +2267,10 @@ let parse_address ctxt : Script.node -> (address * context) tzresult = function Gas.consume ctxt Typecheck_costs.contract >>? fun ctxt -> match Data_encoding.Binary.of_bytes_opt - Data_encoding.(tup2 Contract.encoding Variable.string) + Data_encoding.(tup2 Contract.encoding Entrypoint.value_encoding) bytes with - | Some (c, entrypoint) -> ( - if Compare.Int.(String.length entrypoint > 31) then - error (Entrypoint.Name_too_long entrypoint) - else - match entrypoint with - | "" -> ok ((c, "default"), ctxt) - | "default" -> error (Unexpected_annotation loc) - | name -> ok ((c, name), ctxt)) + | Some addr -> Ok (addr, ctxt) | None -> error @@ Invalid_syntactic_constant -- GitLab From 6c05c206abd5e8445b7e6026663801436b9c995c Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 15 Dec 2021 12:11:17 +0100 Subject: [PATCH 21/28] Tests: adapt error message accordingly --- tests_python/tests_alpha/test_contract.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests_python/tests_alpha/test_contract.py b/tests_python/tests_alpha/test_contract.py index 25095b8b1108..06c0e745c423 100644 --- a/tests_python/tests_alpha/test_contract.py +++ b/tests_python/tests_alpha/test_contract.py @@ -2127,13 +2127,13 @@ class TestContractTypeChecking: client.typecheck_data(f'{address_opt_a}', 'address') unexpected_default_error = "unexpected_default_entrypoint" - unexpected_annotation_error = "unexpected annotation." + not_an_address_error = "not an expression of type address" with utils.assert_run_failure(unexpected_default_error): client.typecheck_data(f'"{address}%default"', 'address') # 64656661756c74 is "default" in hexa - with utils.assert_run_failure(unexpected_annotation_error): + with utils.assert_run_failure(not_an_address_error): client.typecheck_data(address_opt + '64656661756c74', 'address') def check_contract_ok(self, client, address, entrypoint, typ): -- GitLab From 914d16be42c5e45111a20c3e87657236708540b9 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 29 Oct 2021 20:29:50 +0200 Subject: [PATCH 22/28] Proto: add Entrypoint.smart_encoding and use it MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- .../lib_protocol/entrypoint_repr.ml | 34 +++++++++++++++++++ .../lib_protocol/entrypoint_repr.mli | 3 ++ .../lib_protocol/operation_repr.ml | 31 +---------------- 3 files changed, 38 insertions(+), 30 deletions(-) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 8efad2b72a8c..8512a57aaa03 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -121,6 +121,9 @@ let remove_delegate = "remove_delegate" let to_address_suffix name = if is_default name then "" else "%" ^ name +let of_string_lax_exn str = + match of_string_lax' str with Ok name -> name | Error err -> invalid_arg err + let pp = Format.pp_print_string let simple_encoding = @@ -138,6 +141,37 @@ let value_encoding = of_string_strict' Variable.string +let smart_encoding = + let open Data_encoding in + def + ~title:"entrypoint" + ~description:"Named entrypoint to a Michelson smart contract" + "entrypoint" + @@ + let builtin_case tag name = + case + (Tag tag) + ~title:name + (constant name) + (fun n -> if n = name then Some () else None) + (fun () -> name) + in + union + [ + builtin_case 0 "default"; + builtin_case 1 "root"; + builtin_case 2 "do"; + builtin_case 3 "set_delegate"; + builtin_case 4 "remove_delegate"; + case + (Tag 255) + ~title:"named" + (Bounded.string 31) + (function + | "" -> assert false (* invariant violated *) | name -> Some name) + of_string_lax_exn; + ] + let in_memory_size name = Cache_memory_helpers.string_size_gen (String.length name) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index d1728e68f211..e2e5d7fd290f 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -98,6 +98,9 @@ val simple_encoding : t Data_encoding.t "default" is encoded into "". *) val value_encoding : t Data_encoding.t +(** An optimized encoding of entrypoints, used for operations. *) +val smart_encoding : t Data_encoding.t + (** In-memory size of an entrypoint *) val in_memory_size : t -> Saturation_repr.may_saturate Saturation_repr.t diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index a7a6f7beafd6..15a222a67560 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -376,35 +376,6 @@ module Encoding = struct inj = (fun pkh -> Reveal pkh); } - let entrypoint_encoding = - def - ~title:"entrypoint" - ~description:"Named entrypoint to a Michelson smart contract" - "entrypoint" - @@ - let builtin_case tag name = - Data_encoding.case - (Tag tag) - ~title:name - (constant name) - (fun n -> if Compare.String.(n = name) then Some () else None) - (fun () -> name) - in - union - [ - builtin_case 0 "default"; - builtin_case 1 "root"; - builtin_case 2 "do"; - builtin_case 3 "set_delegate"; - builtin_case 4 "remove_delegate"; - Data_encoding.case - (Tag 255) - ~title:"named" - (Bounded.string 31) - (fun s -> Some s) - (fun s -> s); - ] - let[@coq_axiom_with_reason "gadt"] transaction_case = MCase { @@ -417,7 +388,7 @@ module Encoding = struct (opt "parameters" (obj2 - (req "entrypoint" entrypoint_encoding) + (req "entrypoint" Entrypoint_repr.smart_encoding) (req "value" Script_repr.lazy_expr_encoding))); select = (function Manager (Transaction _ as op) -> Some op | _ -> None); -- GitLab From 810a9b359a2a30ffb868be936a70791094bd88e2 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 29 Oct 2021 20:34:17 +0200 Subject: [PATCH 23/28] Proto: add Entrypoint.rpc_arg and use it MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- src/proto_alpha/lib_protocol/contract_services.ml | 2 +- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 8 ++++++++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 3 +++ 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 8ca33ddafa56..9417f0b917c6 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -105,7 +105,7 @@ module S = struct ~query:RPC_query.empty ~output:Script.expr_encoding RPC_path.( - custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string) + custom_root /: Contract.rpc_arg / "entrypoints" /: Entrypoint.rpc_arg) let list_entrypoints = RPC_service.get_service diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 8512a57aaa03..0ec179bd50b0 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -172,6 +172,14 @@ let smart_encoding = of_string_lax_exn; ] +let rpc_arg = + RPC_arg.make + ~descr:"A Michelson entrypoint (string of length < 32)" + ~name:"entrypoint" + ~construct:(function "" -> assert false (* invariant violated*) | s -> s) + ~destruct:of_string_lax' + () + let in_memory_size name = Cache_memory_helpers.string_size_gen (String.length name) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index e2e5d7fd290f..818c332a4f92 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -101,6 +101,9 @@ val value_encoding : t Data_encoding.t (** An optimized encoding of entrypoints, used for operations. *) val smart_encoding : t Data_encoding.t +(** Entrypoint RPC arg. *) +val rpc_arg : t RPC_arg.t + (** In-memory size of an entrypoint *) val in_memory_size : t -> Saturation_repr.may_saturate Saturation_repr.t -- GitLab From f99f04d2b2d1c7903b8028b03c6525773c75f509 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 29 Oct 2021 23:34:18 +0200 Subject: [PATCH 24/28] Proto: make Entrypoint.t private MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- src/proto_alpha/lib_benchmarks_proto/size.ml | 2 +- src/proto_alpha/lib_plugin/plugin.ml | 2 +- src/proto_alpha/lib_protocol/contract_services.ml | 2 +- src/proto_alpha/lib_protocol/entrypoint_repr.mli | 6 ++---- src/proto_alpha/lib_protocol/script_ir_annot.ml | 4 +++- src/proto_alpha/lib_protocol/script_ir_translator.ml | 12 ++---------- 6 files changed, 10 insertions(+), 18 deletions(-) diff --git a/src/proto_alpha/lib_benchmarks_proto/size.ml b/src/proto_alpha/lib_benchmarks_proto/size.ml index 5549702e9aa9..447969742363 100644 --- a/src/proto_alpha/lib_benchmarks_proto/size.ml +++ b/src/proto_alpha/lib_benchmarks_proto/size.ml @@ -140,7 +140,7 @@ let chain_id (_chain_id : Chain_id.t) : t = Chain_id.size let address (addr : Script_typed_ir.address) : t = let (_contract, entrypoint) = addr in - Signature.Public_key_hash.size + String.length entrypoint + Signature.Public_key_hash.size + String.length (entrypoint :> string) let list (list : 'a Script_typed_ir.boxed_list) : t = list.Script_typed_ir.length diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 118996409471..a4e4b6a20dec 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -2181,7 +2181,7 @@ module RPC = struct ( unreachable_entrypoint, Entrypoint.Map.fold (fun entry (_, ty) acc -> - (entry, Micheline.strip_locations ty) :: acc) + ((entry :> string), Micheline.strip_locations ty) :: acc) map [] ) )) diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 9417f0b917c6..e946499bef6e 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -404,7 +404,7 @@ let[@coq_axiom_with_reason "gadt"] register () = ( unreachable_entrypoint, Entrypoint.Map.fold (fun entry (_, ty) acc -> - (entry, Micheline.strip_locations ty) :: acc) + ((entry :> string), Micheline.strip_locations ty) :: acc) map [] ) )) ; opt_register1 diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 818c332a4f92..bd71540d504e 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -23,8 +23,8 @@ (* *) (*****************************************************************************) -(** An entrypoint is a string of at most 31 characters *) -type t = string +(** An entrypoint is a non-empty string of at most 31 characters *) +type t = private string (** Total ordering of entrypoints *) val compare : t -> t -> int @@ -47,8 +47,6 @@ val set_delegate : t (** Entrypoint "remove_delegate" *) val remove_delegate : t -type error += Name_too_long of string - (** Converts an annot to an entrypoint. Returns an error if the string is too long or is "default". *) val of_annot_strict : diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index be5a079c01fe..73d8ff883c54 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -139,7 +139,9 @@ let field_annot_opt_eq_entrypoint_lax field_annot_opt entrypoint = | Some (Field_annot a) -> ( match Entrypoint.of_annot_lax_opt a with | None -> false - | Some a' -> Compare.String.(a' = entrypoint)) + | Some a' -> + Compare.String.( + (a' :> string) = (entrypoint : Entrypoint.t :> string))) let default_annot ~default = function None -> default | annot -> annot diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index add36785557f..43d5065a839c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -469,7 +469,7 @@ let unparse_timestamp ~loc ctxt mode t = let unparse_address ~loc ctxt mode (c, entrypoint) = Gas.consume ctxt Unparse_costs.contract >>? fun ctxt -> - (match entrypoint with + (match (entrypoint : Entrypoint.t :> string) with (* given parse_address, this should not happen *) | "" -> error Unparsing_invariant_violated | _ -> ok ()) @@ -1954,15 +1954,7 @@ let find_entrypoint (type full error_trace) | None -> None)) | _ -> None in - let entrypoint = - if Compare.String.(entrypoint = "") then "default" else entrypoint - in - if Compare.Int.(String.length entrypoint > 31) then - Error - (match error_details with - | Fast -> (Inconsistent_types_fast : error_trace) - | Informative -> trace_of_error @@ Entrypoint.Name_too_long entrypoint) - else if field_annot_opt_eq_entrypoint_lax root_name entrypoint then + if field_annot_opt_eq_entrypoint_lax root_name entrypoint then ok ((fun e -> e), Ex_ty full) else match find_entrypoint full entrypoint with -- GitLab From f50aafaef096ff8319ee23fac7176b231d422670 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 29 Oct 2021 20:00:03 +0200 Subject: [PATCH 25/28] Proto: use Non_empty_string for entrypoints --- .../lib_protocol/entrypoint_repr.ml | 100 ++++++++++-------- .../lib_protocol/entrypoint_repr.mli | 5 +- .../lib_protocol/script_ir_annot.ml | 4 +- .../lib_protocol/script_ir_translator.ml | 7 +- .../lib_protocol/script_tc_errors.ml | 3 - 5 files changed, 64 insertions(+), 55 deletions(-) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 0ec179bd50b0..92b4cd575b70 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -24,7 +24,11 @@ (*****************************************************************************) (** Invariants on the string: 1 <= length <= 31 *) -include Compare.String +type t = Non_empty_string.t + +let compare = Non_empty_string.compare + +let ( = ) = Non_empty_string.( = ) type error += Name_too_long of string @@ -55,7 +59,7 @@ let () = (function Unexpected_default loc -> Some loc | _ -> None) (fun loc -> Unexpected_default loc) -let default = "default" +let default = Non_empty_string.of_string_exn "default" let is_default name = name = default @@ -65,14 +69,18 @@ type of_string_result = | Got_default (** Got exactly "default", which can be an error in some cases or OK in others *) -let of_string str = - if str = "" then - (* The empty string always means the default entrypoint *) - Ok default - else if Compare.Int.(String.length str > 31) then Too_long +let of_non_empty_string (str : Non_empty_string.t) = + if Compare.Int.(String.length (str :> string) > 31) then Too_long else if is_default str then Got_default else Ok str +let of_string str = + match Non_empty_string.of_string str with + | None (* empty string *) -> + (* The empty string always means the default entrypoint *) + Ok default + | Some str -> of_non_empty_string str + let of_string_strict ~loc str = match of_string str with | Too_long -> error (Name_too_long str) @@ -88,8 +96,17 @@ let of_string_strict' str = let of_string_strict_exn str = match of_string_strict' str with Ok v -> v | Error err -> invalid_arg err -let of_annot_strict ~loc (a : Non_empty_string.t) = - of_string_strict ~loc (a :> string) +let of_annot_strict ~loc a = + match of_non_empty_string a with + | Too_long -> error (Name_too_long (a :> string)) + | Got_default -> error (Unexpected_default loc) + | Ok name -> Ok name + +let of_annot_lax_opt a = + match of_non_empty_string a with + | Too_long -> None + | Got_default -> Some default + | Ok name -> Some name let of_string_lax_opt str = match of_string str with @@ -97,49 +114,49 @@ let of_string_lax_opt str = | Got_default -> Some default | Ok name -> Some name -let of_annot_lax_opt (a : Non_empty_string.t) = of_string_lax_opt (a :> string) - let of_string_lax str = match of_string_lax_opt str with | None -> error (Name_too_long str) | Some name -> Ok name -let of_annot_lax (a : Non_empty_string.t) = of_string_lax (a :> string) +let of_annot_lax a = + match of_non_empty_string a with + | Too_long -> error (Name_too_long (a :> string)) + | Got_default -> Ok default + | Ok name -> Ok name let of_string_lax' str = match of_string_lax_opt str with | None -> Error ("Entrypoint name too long \"" ^ str ^ "\"") | Some name -> Ok name -let root = "root" +let root = Non_empty_string.of_string_exn "root" -let do_ = "do" +let do_ = Non_empty_string.of_string_exn "do" -let set_delegate = "set_delegate" +let set_delegate = Non_empty_string.of_string_exn "set_delegate" -let remove_delegate = "remove_delegate" +let remove_delegate = Non_empty_string.of_string_exn "remove_delegate" -let to_address_suffix name = if is_default name then "" else "%" ^ name +let to_address_suffix (name : t) = + if is_default name then "" else "%" ^ (name :> string) let of_string_lax_exn str = match of_string_lax' str with Ok name -> name | Error err -> invalid_arg err -let pp = Format.pp_print_string +let pp fmt (name : t) = Format.pp_print_string fmt (name :> string) let simple_encoding = - let open Data_encoding in - conv_with_guard - (function "" -> assert false (* invariant violated *) | s -> s) + Data_encoding.conv_with_guard + (fun (name : t) -> (name :> string)) of_string_lax' - string + Data_encoding.string let value_encoding = - let open Data_encoding in - conv_with_guard - (function - | "" -> assert false (* invariant violated*) | "default" -> "" | s -> s) + Data_encoding.conv_with_guard + (fun name -> if is_default name then "" else (name :> string)) of_string_strict' - Variable.string + Data_encoding.Variable.string let smart_encoding = let open Data_encoding in @@ -148,27 +165,26 @@ let smart_encoding = ~description:"Named entrypoint to a Michelson smart contract" "entrypoint" @@ - let builtin_case tag name = + let builtin_case tag (name : Non_empty_string.t) = case (Tag tag) - ~title:name - (constant name) + ~title:(name :> string) + (constant (name :> string)) (fun n -> if n = name then Some () else None) (fun () -> name) in union [ - builtin_case 0 "default"; - builtin_case 1 "root"; - builtin_case 2 "do"; - builtin_case 3 "set_delegate"; - builtin_case 4 "remove_delegate"; + builtin_case 0 default; + builtin_case 1 root; + builtin_case 2 do_; + builtin_case 3 set_delegate; + builtin_case 4 remove_delegate; case (Tag 255) ~title:"named" (Bounded.string 31) - (function - | "" -> assert false (* invariant violated *) | name -> Some name) + (fun (name : Non_empty_string.t) -> Some (name :> string)) of_string_lax_exn; ] @@ -176,12 +192,12 @@ let rpc_arg = RPC_arg.make ~descr:"A Michelson entrypoint (string of length < 32)" ~name:"entrypoint" - ~construct:(function "" -> assert false (* invariant violated*) | s -> s) + ~construct:(fun (name : t) -> (name :> string)) ~destruct:of_string_lax' () -let in_memory_size name = - Cache_memory_helpers.string_size_gen (String.length name) +let in_memory_size (name : t) = + Cache_memory_helpers.string_size_gen (String.length (name :> string)) -module Set = Set.Make (String) -module Map = Map.Make (String) +module Set = Set.Make (Non_empty_string) +module Map = Map.Make (Non_empty_string) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index bd71540d504e..18cd6f53e1c4 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -24,11 +24,14 @@ (*****************************************************************************) (** An entrypoint is a non-empty string of at most 31 characters *) -type t = private string +type t = private Non_empty_string.t (** Total ordering of entrypoints *) val compare : t -> t -> int +(** Equality of entrypoints *) +val ( = ) : t -> t -> bool + (** Default entrypoint "default" *) val default : t diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 73d8ff883c54..cadc17dbc6f5 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -139,9 +139,7 @@ let field_annot_opt_eq_entrypoint_lax field_annot_opt entrypoint = | Some (Field_annot a) -> ( match Entrypoint.of_annot_lax_opt a with | None -> false - | Some a' -> - Compare.String.( - (a' :> string) = (entrypoint : Entrypoint.t :> string))) + | Some a' -> Entrypoint.(a' = entrypoint)) let default_annot ~default = function None -> default | annot -> annot diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 43d5065a839c..4a2973a8b4ea 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -468,12 +468,7 @@ let unparse_timestamp ~loc ctxt mode t = | Some s -> ok (String (loc, s), ctxt)) let unparse_address ~loc ctxt mode (c, entrypoint) = - Gas.consume ctxt Unparse_costs.contract >>? fun ctxt -> - (match (entrypoint : Entrypoint.t :> string) with - (* given parse_address, this should not happen *) - | "" -> error Unparsing_invariant_violated - | _ -> ok ()) - >|? fun () -> + Gas.consume ctxt Unparse_costs.contract >|? fun ctxt -> match mode with | Optimized | Optimized_legacy -> let bytes = diff --git a/src/proto_alpha/lib_protocol/script_tc_errors.ml b/src/proto_alpha/lib_protocol/script_tc_errors.ml index 42037e726835..7b334cb5bf04 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors.ml @@ -198,9 +198,6 @@ type error += Unexpected_forged_value of Script.location type error += Non_dupable_type of Script.location * Script.expr -(* Impossible errors *) -type error += Unparsing_invariant_violated - (* Merge type errors *) type inconsistent_types_fast_error = -- GitLab From 84c6f0cdb74c4ebb3552b2de27f7a1032e032e2e Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Tue, 16 Nov 2021 15:35:24 +0100 Subject: [PATCH 26/28] Proto: more local invariant on size of entrypoints --- .../lib_protocol/entrypoint_repr.ml | 57 +++++++++++++------ 1 file changed, 41 insertions(+), 16 deletions(-) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 92b4cd575b70..2a8a1f2a2aac 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -23,12 +23,25 @@ (* *) (*****************************************************************************) -(** Invariants on the string: 1 <= length <= 31 *) -type t = Non_empty_string.t +module Pre_entrypoint : sig + (** Invariants on the string: 1 <= length <= 31 *) + type t = private Non_empty_string.t -let compare = Non_empty_string.compare + val of_non_empty_string : Non_empty_string.t -> t option +end = struct + type t = Non_empty_string.t -let ( = ) = Non_empty_string.( = ) + let of_non_empty_string (str : Non_empty_string.t) = + if Compare.Int.(String.length (str :> string) > 31) then None else Some str +end + +type t = Pre_entrypoint.t + +let compare (x : t) (y : t) = + Non_empty_string.compare (x :> Non_empty_string.t) (y :> Non_empty_string.t) + +let ( = ) (x : t) (y : t) = + Non_empty_string.( = ) (x :> Non_empty_string.t) (y :> Non_empty_string.t) type error += Name_too_long of string @@ -59,7 +72,13 @@ let () = (function Unexpected_default loc -> Some loc | _ -> None) (fun loc -> Unexpected_default loc) -let default = Non_empty_string.of_string_exn "default" +let default = + match + Pre_entrypoint.of_non_empty_string + @@ Non_empty_string.of_string_exn "default" + with + | None -> assert false + | Some res -> res let is_default name = name = default @@ -70,9 +89,9 @@ type of_string_result = (** Got exactly "default", which can be an error in some cases or OK in others *) let of_non_empty_string (str : Non_empty_string.t) = - if Compare.Int.(String.length (str :> string) > 31) then Too_long - else if is_default str then Got_default - else Ok str + match Pre_entrypoint.of_non_empty_string str with + | None -> Too_long + | Some str -> if is_default str then Got_default else Ok str let of_string str = match Non_empty_string.of_string str with @@ -130,13 +149,13 @@ let of_string_lax' str = | None -> Error ("Entrypoint name too long \"" ^ str ^ "\"") | Some name -> Ok name -let root = Non_empty_string.of_string_exn "root" +let root = of_string_strict_exn "root" -let do_ = Non_empty_string.of_string_exn "do" +let do_ = of_string_strict_exn "do" -let set_delegate = Non_empty_string.of_string_exn "set_delegate" +let set_delegate = of_string_strict_exn "set_delegate" -let remove_delegate = Non_empty_string.of_string_exn "remove_delegate" +let remove_delegate = of_string_strict_exn "remove_delegate" let to_address_suffix (name : t) = if is_default name then "" else "%" ^ (name :> string) @@ -165,7 +184,7 @@ let smart_encoding = ~description:"Named entrypoint to a Michelson smart contract" "entrypoint" @@ - let builtin_case tag (name : Non_empty_string.t) = + let builtin_case tag (name : Pre_entrypoint.t) = case (Tag tag) ~title:(name :> string) @@ -184,7 +203,7 @@ let smart_encoding = (Tag 255) ~title:"named" (Bounded.string 31) - (fun (name : Non_empty_string.t) -> Some (name :> string)) + (fun (name : Pre_entrypoint.t) -> Some (name :> string)) of_string_lax_exn; ] @@ -199,5 +218,11 @@ let rpc_arg = let in_memory_size (name : t) = Cache_memory_helpers.string_size_gen (String.length (name :> string)) -module Set = Set.Make (Non_empty_string) -module Map = Map.Make (Non_empty_string) +module T = struct + type nonrec t = t + + let compare = compare +end + +module Set = Set.Make (T) +module Map = Map.Make (T) -- GitLab From a3ed5748ad4310c85b4d68c7cad0f8b601c64e20 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 18 Nov 2021 17:20:36 +0100 Subject: [PATCH 27/28] Proto: add Entrypoint.to_string and use it MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- src/proto_alpha/lib_benchmarks_proto/size.ml | 3 ++- src/proto_alpha/lib_plugin/plugin.ml | 3 ++- src/proto_alpha/lib_protocol/contract_services.ml | 3 ++- src/proto_alpha/lib_protocol/entrypoint_repr.ml | 2 ++ src/proto_alpha/lib_protocol/entrypoint_repr.mli | 4 ++++ 5 files changed, 12 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_benchmarks_proto/size.ml b/src/proto_alpha/lib_benchmarks_proto/size.ml index 447969742363..e3a3e0c14a61 100644 --- a/src/proto_alpha/lib_benchmarks_proto/size.ml +++ b/src/proto_alpha/lib_benchmarks_proto/size.ml @@ -140,7 +140,8 @@ let chain_id (_chain_id : Chain_id.t) : t = Chain_id.size let address (addr : Script_typed_ir.address) : t = let (_contract, entrypoint) = addr in - Signature.Public_key_hash.size + String.length (entrypoint :> string) + Signature.Public_key_hash.size + + String.length (Alpha_context.Entrypoint.to_string entrypoint) let list (list : 'a Script_typed_ir.boxed_list) : t = list.Script_typed_ir.length diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index a4e4b6a20dec..20690a00aaf7 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -2181,7 +2181,8 @@ module RPC = struct ( unreachable_entrypoint, Entrypoint.Map.fold (fun entry (_, ty) acc -> - ((entry :> string), Micheline.strip_locations ty) :: acc) + (Entrypoint.to_string entry, Micheline.strip_locations ty) + :: acc) map [] ) )) diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index e946499bef6e..239121808a6e 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -404,7 +404,8 @@ let[@coq_axiom_with_reason "gadt"] register () = ( unreachable_entrypoint, Entrypoint.Map.fold (fun entry (_, ty) acc -> - ((entry :> string), Micheline.strip_locations ty) :: acc) + (Entrypoint.to_string entry, Micheline.strip_locations ty) + :: acc) map [] ) )) ; opt_register1 diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.ml b/src/proto_alpha/lib_protocol/entrypoint_repr.ml index 2a8a1f2a2aac..49d59d036623 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.ml +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -157,6 +157,8 @@ let set_delegate = of_string_strict_exn "set_delegate" let remove_delegate = of_string_strict_exn "remove_delegate" +let to_string (name : t) = (name :> string) + let to_address_suffix (name : t) = if is_default name then "" else "%" ^ (name :> string) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 18cd6f53e1c4..6f9594bb46cb 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -80,6 +80,10 @@ val of_annot_lax_opt : Non_empty_string.t -> t option Accepts "default" and converts "" to "default". *) val of_string_lax : string -> t tzresult +(** Converts an entrypoint to a string. + "default" is kept as is. *) +val to_string : t -> string + (** Converts an entrypoint to a string used as an address suffix. For the default entrypoint, the result is the empty string. Otherwise it is "%" followed by the entrypoint. *) -- GitLab From c190ace547f95d646141e1d1d2fd2b5a932dc09b Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 18 Nov 2021 17:20:44 +0100 Subject: [PATCH 28/28] Proto: make Entrypoint.t abstract MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored by: Mehdi Bouaziz Co-Authored by: Raphaël Cauderlier --- src/proto_alpha/lib_protocol/entrypoint_repr.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/entrypoint_repr.mli b/src/proto_alpha/lib_protocol/entrypoint_repr.mli index 6f9594bb46cb..8a0d9e997eb1 100644 --- a/src/proto_alpha/lib_protocol/entrypoint_repr.mli +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -24,7 +24,7 @@ (*****************************************************************************) (** An entrypoint is a non-empty string of at most 31 characters *) -type t = private Non_empty_string.t +type t (** Total ordering of entrypoints *) val compare : t -> t -> int -- GitLab