diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index 16014d6df65a382972ef1c5be591e9e0faa898bb..de8979d2abe29a137283cbb3e142fa617390fad3 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 *) @@ -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_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml index 961cf576e78fd8015c6355de2f56e859d787c296..b7570a634a91d7297eae5e0447c189b337dc12a2 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_benchmarks_proto/size.ml b/src/proto_alpha/lib_benchmarks_proto/size.ml index 5549702e9aa9dbe3616f5b1bf5bcda9b3b5e6906..e3a3e0c14a619582563723f66f8c0e1530fb2dba 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 + 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_client/client_proto_args.ml b/src/proto_alpha/lib_client/client_proto_args.ml index af7d3bbf076d5b4962b5c6a33659c68d075e1e60..f933269bc855c3d9791bb3b348880b40f4749bae 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 3bc4b659fbaf4ea9a12a02dd16e0081ac403d07c..3b1a2aac0594d90074a755fe4ac05b28bc5d017a 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 @@ -54,9 +56,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 ca8568f807086bb517b4c90dae1f23bb077d0405..97b2768cf793d5c1a183e29698d4f1719c3d7677 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 @@ -485,7 +486,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 = @@ -502,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_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index a07876950e778378849115c5794aeb4de98e931e..1d1895ad6f7130e2e8623313cf2c8d3b3aa43f05 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 fb7e31dc856b82a7983449a1c7d842513bc5987d..e200354baeea5df19b0213324892b5b8552421b4 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 @@ -135,8 +135,12 @@ 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) - Data_encoding.(obj1 (req "entrypoint" string)) + Format.fprintf + ppf + "Entrypoint %a is not viewable." + Entrypoint.pp + entrypoint) + 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 @@ -691,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 7ffb4f88300622d4228db366ad7d9b8ddb775491..4ed8635c4e456b144d1c28aa6ea521dae6436a27 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 @@ -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 @@ -319,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 @@ -472,7 +473,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 @@ -480,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 = [ @@ -491,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; }; { @@ -582,12 +585,12 @@ 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 entrypoint = match entrypoint with "default" -> "" | name -> name in +let optimized_address ~loc ~(address : Contract.t) ~(entrypoint : Entrypoint.t) + = 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) = @@ -601,7 +604,7 @@ type multisig_action = | Transfer of { amount : Tez.t; destination : Contract.t; - entrypoint : string; + entrypoint : Entrypoint.t; parameter_type : Script.expr; parameter : Script.expr; } @@ -737,7 +740,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 = @@ -953,7 +956,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 ad4a6306d60c34eda2ab76f34b3f0bc1145d09d7..909cc0b550cd9095cd44528abab6f5d76dfe9c2b 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 b0b1b295e529416725d6b33bce9a30948efe053c..a9c72dfe1dfbb266811f781cebd6654c944d5b43 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 16c9a45acfff83bc572ccd2daec90051bcb48416..dd17e04ae6d3d3a14a32ed3b2ef9ee720878669e 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.ml b/src/proto_alpha/lib_client/managed_contract.ml index 29bb3d976b631f4606eec0a36d85cfae94b22306..676a7d95b03b109847ebddcc847162c809399e0d 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 @@ -195,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; \ @@ -220,15 +226,16 @@ 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 - "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 @@ -242,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 -> @@ -265,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 @@ -278,7 +286,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/managed_contract.mli b/src/proto_alpha/lib_client/managed_contract.mli index ae532c986987df213f6d52e2c90e45c69dbf1f81..e272420913a993d4e4a5f31de4090c0eda8fb3f1 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.ml b/src/proto_alpha/lib_client/michelson_v1_entrypoints.ml index 9d6f08221e8ba3a4cc4b9494357fd83bf082c6b6..190b42bfb515551a25f88a2e6452514fcd77e409 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)) @@ -113,7 +116,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 +136,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/michelson_v1_entrypoints.mli b/src/proto_alpha/lib_client/michelson_v1_entrypoints.mli index 96d3ad82c2f004ba7635c371029d8675efa5c60d..83dfe900e3b3bbf907bbaeccbbee7245cbb9aba8 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_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index a4c218288a9b39565915f8851b632e55fa3a0103..88250bf7bf38896c81d30244450b3a9a2c19bca4 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 f369037cd823a109956e07a3c55d931c0b265ad0..6bcf9302da4031163d6b575345a77e203c93f830 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: %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/test/test_client_proto_context.ml b/src/proto_alpha/lib_client/test/test_client_proto_context.ml index ee5786be473996b146fcf0c59204275e01906349..b970b0491dcab90e22f30de7b4a05f97417fb702 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_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 3ed17a5fde5bc36743c6f840d72589d1d3d2c800..9fa5e21205dc2442536ebf81b3b5a58d346d2805 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_multisig_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml index db58555539ee01bd0c79f423df7d08d238091c15..a03e5a04c396840b0abc98e6eff98830a076ed8b 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) @@ -332,7 +333,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 +517,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 +1005,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_programs_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml index e0bc75fb83ab8a7f7930067c3d6b24bab3795932..18048c5e4f08bb860cd65e3b30e28b39065c4a01 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_client_commands/client_proto_stresstest_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml index ca6a60096a9a30c3047cca2d1a3cc62659544328..1af3ee99aea1faf63b7a2a9caa7885db456cd5f6 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 2567812a0d0b8176673664a316668235dda5acc3..20690a00aaf73f41a56ffad14e600800f13ec2d6 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 @@ -949,15 +949,18 @@ 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 (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 @@ -970,13 +973,16 @@ 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) 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 @@ -989,14 +995,17 @@ 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) 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)) @@ -1187,7 +1196,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" Entrypoint.simple_encoding Entrypoint.default)) (obj3 (opt "unparsing_mode" unparsing_mode_encoding) (opt "now" Script_timestamp.encoding) @@ -1245,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) @@ -1406,7 +1415,7 @@ module RPC = struct ~input: (obj2 (req "script" Script.expr_encoding) - (dft "entrypoint" string "default")) + (dft "entrypoint" Entrypoint.simple_encoding Entrypoint.default)) ~output:(obj1 (req "entrypoint_type" Script.expr_encoding)) RPC_path.(path / "entrypoint") @@ -2170,15 +2179,16 @@ 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) + (Entrypoint.to_string entry, Micheline.strip_locations ty) + :: acc) 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 +2206,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 +2584,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/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index ff740bead3bb1122a56a7e36f0e827e8b685d52f..5b465faf904c7da98c3a68ef24e4007ca6a2b6d1 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 d12c2727c14f4d2e9ae28ab9e35b89b9366dbf14..2307848c39db9ce4f0d90b86214e909e06eb3d72 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 01e977d92410169afa16b05d8c2c7785b995d7f8..803769294a1767de78c84572b62a064f706aec92 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 @@ -2074,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/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 45476fc836f0f7116bea7e36a8642d8c2b53c11d..7c10d7e1be9da0162a4dee0fc2ca6999534c1914 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/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index d4bb68bcff30a1832bb6f3b04c01b173b9ff8f0e..239121808a6e154ebc3d9c3df94ac0097114a5af 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 @@ -402,9 +402,10 @@ 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) + (Entrypoint.to_string entry, Micheline.strip_locations ty) + :: acc) map [] ) )) ; opt_register1 diff --git a/src/proto_alpha/lib_protocol/contract_services.mli b/src/proto_alpha/lib_protocol/contract_services.mli index 458dfbe4d6170636173bea4641ad668823851be4..58a36ba406522fb158b54a137f70f33aba9daebd 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/dune.inc b/src/proto_alpha/lib_protocol/dune.inc index b3578652efafbb66daad634fd28f132cf7d09847..f5ea20b62fa6f0c628240e60b3e50cdb32fcffa4 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 0000000000000000000000000000000000000000..49d59d0366234dc8263dfdaef3dd80bb19c23706 --- /dev/null +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.ml @@ -0,0 +1,230 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +module Pre_entrypoint : sig + (** Invariants on the string: 1 <= length <= 31 *) + type t = private Non_empty_string.t + + val of_non_empty_string : Non_empty_string.t -> t option +end = struct + type t = Non_empty_string.t + + 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 + +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) + +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 = + 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 + +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_non_empty_string (str : Non_empty_string.t) = + 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 + | 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) + | 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" + | 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 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 + | Too_long -> None + | Got_default -> Some default + | Ok name -> Some name + +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 = + 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 = of_string_strict_exn "root" + +let do_ = of_string_strict_exn "do" + +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) + +let of_string_lax_exn str = + match of_string_lax' str with Ok name -> name | Error err -> invalid_arg err + +let pp fmt (name : t) = Format.pp_print_string fmt (name :> string) + +let simple_encoding = + Data_encoding.conv_with_guard + (fun (name : t) -> (name :> string)) + of_string_lax' + Data_encoding.string + +let value_encoding = + Data_encoding.conv_with_guard + (fun name -> if is_default name then "" else (name :> string)) + of_string_strict' + Data_encoding.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 : Pre_entrypoint.t) = + case + (Tag tag) + ~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; + case + (Tag 255) + ~title:"named" + (Bounded.string 31) + (fun (name : Pre_entrypoint.t) -> Some (name :> string)) + of_string_lax_exn; + ] + +let rpc_arg = + RPC_arg.make + ~descr:"A Michelson entrypoint (string of length < 32)" + ~name:"entrypoint" + ~construct:(fun (name : t) -> (name :> string)) + ~destruct:of_string_lax' + () + +let in_memory_size (name : t) = + Cache_memory_helpers.string_size_gen (String.length (name :> string)) + +module T = struct + type nonrec t = t + + let compare = compare +end + +module Set = Set.Make (T) +module Map = Map.Make (T) 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 0000000000000000000000000000000000000000..8a0d9e997eb1b9a7f9a91fb8884965e6317e220c --- /dev/null +++ b/src/proto_alpha/lib_protocol/entrypoint_repr.mli @@ -0,0 +1,119 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** An entrypoint is a non-empty string of at most 31 characters *) +type t + +(** Total ordering of entrypoints *) +val compare : t -> t -> int + +(** Equality of entrypoints *) +val ( = ) : t -> t -> bool + +(** Default entrypoint "default" *) +val default : t + +(** Checks whether an entrypoint is the default entrypoint *) +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 + +(** 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". *) +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". *) +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". *) +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. *) +val to_address_suffix : t -> string + +(** Pretty-print an entrypoint *) +val pp : Format.formatter -> t -> unit + +(** 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 + +(** 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 + +(** 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/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 19fbd8508a6c4b7ab0c0fcc70004bded9bec2b4c..15a222a675603600c02a889be11bfe551b0ddcc7 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 @@ -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); @@ -427,7 +398,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 +407,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}); @@ -1179,7 +1150,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/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 8e83456ee89816740a8d0dae7e128701a9b6f3fd..dd279466c4d527949db9fa5587a453e01e1eda82 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_comparable.ml b/src/proto_alpha/lib_protocol/script_comparable.ml index ab542f4867f35a717c98b3a47307fd2bd333f6fc..93c58db7b90fec5ebd219c442d0d030a832b916c 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 : diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 345f96684530cb7b587790a2943b85fc1f5f03d8..72247a79db88e6a4c404abb0846989d1bf07028f 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_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli index 2f2f5b7c672bdefe5386fc924f961bd08c9aa624..0fce503243a42b375fe810862abeaa9ecb61499a 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_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 5891d6dae4c1aaed3667f05288a4dacce099222d..cadc17dbc6f521ccb7ac5e50c2c9990b0e24dd47 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -129,6 +129,18 @@ 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 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' -> Entrypoint.(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 da53c5071c0348426b4d2c0f06ad54b47685f281..302bb9917b11bb6be33d86cfd20bcfe3a8975b7b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -111,6 +111,18 @@ 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 + +(** 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 1ec20ed9f6f5cde5f47ffa96d8859e6767a54273..4a2973a8b4eaae2bd8dbbce4f532295d247d2854 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -468,26 +468,18 @@ 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 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 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) | 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) @@ -1936,19 +1928,16 @@ 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. 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), _) -> ( - 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 @@ -1960,53 +1949,39 @@ 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) + 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 -> ( - 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))) + 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 : - (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 | 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))) + >?$ fun (Eq, full) -> ok (Entrypoint.root, (full : exp ty))) | _ -> 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) = @@ -2022,19 +1997,17 @@ 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 Entrypoints.mem name all then error (Duplicate_entrypoint name) - else ok (first_unreachable, Entrypoints.add name all) + 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 : 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), _) -> @@ -2055,11 +2028,14 @@ 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) -> ( + 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 (Entrypoints.mem "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 @@ -2278,17 +2254,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 @@ -2296,16 +2265,12 @@ 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") - | Some pos -> ( + | None -> ok (s, Entrypoint.default) + | 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 -> @@ -4788,15 +4753,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 "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))} @@ -4992,12 +4949,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:"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 -> @@ -5436,22 +5391,19 @@ 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 - | 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)) @@ -5619,35 +5571,34 @@ 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 - | 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)) @@ -5896,8 +5847,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) = @@ -5910,17 +5859,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 Entrypoints_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 ) + | 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. @@ -5928,9 +5877,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 @@ -5953,9 +5902,12 @@ 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) - | Some (Field_annot name) -> - (Entrypoints_map.singleton (name :> string) ([], unparsed_full), true) + | None -> (Entrypoint.Map.empty, false) + | 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"] @@ -6038,7 +5990,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/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 44937a3459d430d3ae85d44a16323e33a425e5dd..a6f906826ad477fb9583223b6f3c498d72148a5c 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,25 +404,23 @@ 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 - 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 : diff --git a/src/proto_alpha/lib_protocol/script_tc_errors.ml b/src/proto_alpha/lib_protocol/script_tc_errors.ml index e44a47319ba5c172a05e479768d247b876599ff0..7b334cb5bf0484526bf81d5b054bace843eaded8 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors.ml @@ -62,14 +62,12 @@ 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 -type error += Entrypoint_name_too_long of string - (* Instruction typing errors *) type error += Fail_not_in_tail_position of Script.location @@ -200,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 = 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 6766bdc3dac14095330101c1fa5ff0ebfbda5890..e63e9c5f764afdb896f3233b2dada6073063d1ef 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,20 +238,9 @@ 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) ; - (* 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 diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 0872eb130b072c0b668783f5824649b82fc72131..734936c2e4cb5d6fa0d51136ba359f03316f622f 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 45b3b3ce6cc89f4d76f8c1daa4031f655a6da3d8..4582c952e65668a0bb538b59d34a90146eee4b10 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/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 6b18c1b1f50a1a2f0a968c17a2b379aa60fd7504..8956411d673d04258b5c62e18b2bbe246baebcb4 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, _) -> 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 deec7b0af8e83e59ac5155d11a1899ffedea10fa..ad37f1aa039d91bdd08ad150c9cabcf27fa6b77d 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/cpmm_repr.ml b/src/proto_alpha/lib_protocol/test/helpers/cpmm_repr.ml index 5689833772b456457c9faec33aea452ca6b689e3..0af1c8c6e29f3b488e85d611bb579f575289f073 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/cpmm_repr.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/cpmm_repr.ml @@ -278,13 +278,13 @@ module Parameter = struct | XtzToToken p -> Format.asprintf "XtzToToken (%s)" (xtz_to_token_to_string p) - let entrypoint_of_parameter : t -> string = function - | AddLiquidity _ -> "addLiquidity" - | Default _ -> "default" - | RemoveLiquidity _ -> "removeLiquidity" - | TokenToToken _ -> "tokenToToken" - | TokenToXtz _ -> "tokenToXtz" - | XtzToToken _ -> "xtzToToken" + let entrypoint_of_parameter : t -> Entrypoint.t = function + | 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/liquidity_baking_machine.ml b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml index aeb81ede82e7087b0f9ded4fdb14f945fc65b4b0..00561546aac273f342c3ca64bc8cd591d5301894 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 937dfb8297b2346572f0bd79d91484a0bf30d564..43c9dab4a1c515c903be02483a10f44097dfbb18 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,9 +69,9 @@ 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 - | Approve _ -> "approve" - | MintOrBurn _ -> "mintOrBurn" + let entrypoint_of_parameter : t -> Entrypoint.t = function + | 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/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index 9ba41cfb7c98df468448e3ada3066b2cbd18cbab..eac7739aedcf938bb43956c3600a24ec96552580 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/helpers/op.mli b/src/proto_alpha/lib_protocol/test/helpers/op.mli index 3c99d37601a1e8b34d1d990285bde49fd7c8cebe..fc460753cf28814b3314da389d8383f14f770e74 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 -> diff --git a/src/proto_alpha/lib_protocol/test/test_transfer.ml b/src/proto_alpha/lib_protocol/test/test_transfer.ml index a5d14baa5254dc0c41b3cbbb67b5cf53b8d1edeb..8a6f0f2f96c1e9b2889877829378eadef59a4f92 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 diff --git a/src/proto_alpha/lib_protocol/test/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/test_typechecking.ml index 7ff1b6ab63b242dd4bd958d33a65e2d7cf6bf44b..7f2f15455ee767a706d5751dbd9a2c4b701d6627 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 8546d3a221b89c4ae2b80e20a4396b6fa25b574b..186b5c7623720ac7c037c80c3e55a437c95a9276 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 diff --git a/tests_python/tests_alpha/test_contract.py b/tests_python/tests_alpha/test_contract.py index 5941681eeb8e5124252470f3fdd3aaca36b2e663..06c0e745c4231ce6abf362d7719b94f89988f6e9 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", @@ -2123,13 +2126,14 @@ class TestContractTypeChecking: client.typecheck_data(f'{address_opt}', 'address') client.typecheck_data(f'{address_opt_a}', 'address') - unexpected_annotation_error = "unexpected annotation." + unexpected_default_error = "unexpected_default_entrypoint" + not_an_address_error = "not an expression of type address" - 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 - 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):