diff --git a/devtools/get_contracts/get_contracts_alpha.ml b/devtools/get_contracts/get_contracts_alpha.ml index 48028c8d8174b2876123ad1f345f3b4937a5d4c6..8035715ad0c1e3bd93aa0af5ce17fd902f01a4b1 100644 --- a/devtools/get_contracts/get_contracts_alpha.ml +++ b/devtools/get_contracts/get_contracts_alpha.ml @@ -167,8 +167,7 @@ module Proto = struct let open Lwt_result_syntax in let ctxt : Alpha_context.context = Obj.magic raw_ctxt in let+ toplevel, updated_ctxt = - Lwt.map wrap_tzresult - @@ Script_ir_translator.parse_toplevel ctxt ~legacy:true expr + Lwt.map wrap_tzresult @@ Script_ir_translator.parse_toplevel ctxt expr in let consumed = (Alpha_context.Gas.consumed ~since:ctxt ~until:updated_ctxt :> int) diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 265e937c9664479b06697028b20666bb1e4d4de6..128df48c1f4d33389d255d060e3b0d72b97b2488 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -1067,7 +1067,7 @@ module Scripts = struct let ctxt = Gas.set_unlimited ctxt in let legacy = false in let open Script_ir_translator in - parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) -> + parse_toplevel ctxt expr >>=? fun ({arg_type; _}, ctxt) -> Lwt.return ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type >>? fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _) -> @@ -1083,9 +1083,8 @@ module Scripts = struct in let script_view_type ctxt contract expr view = let ctxt = Gas.set_unlimited ctxt in - let legacy = false in let open Script_ir_translator in - parse_toplevel ctxt ~legacy expr >>=? fun ({views; _}, _) -> + parse_toplevel ctxt expr >>=? fun ({views; _}, _) -> Lwt.return ( Script_string.of_string view >>? fun view_name -> match Script_map.get view_name views with @@ -1607,7 +1606,7 @@ module Scripts = struct let ctxt = Gas.set_unlimited ctxt in let legacy = false in let open Script_ir_translator in - parse_toplevel ~legacy ctxt expr >>=? fun ({arg_type; _}, ctxt) -> + parse_toplevel ctxt expr >>=? fun ({arg_type; _}, ctxt) -> Lwt.return ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type >|? fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _) diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 0708612f1b4cef206c153c2ebb9c9eaa272ed928..59277e4d603b17dd0d83738d8c4a1353689a16e2 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -442,7 +442,7 @@ let register () = ctxt expr >>?= fun (expr, _) -> - parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) -> + parse_toplevel ctxt expr >>=? fun ({arg_type; _}, ctxt) -> Lwt.return ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type >>? fun ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, @@ -482,7 +482,7 @@ let register () = ctxt expr >>?= fun (expr, _) -> - parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) -> + parse_toplevel ctxt expr >>=? fun ({arg_type; _}, ctxt) -> Lwt.return ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type >>? fun ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 0a7e1b068af4750b5d7b3b45b48ab1bd30a2beb8..d3e4c0a5e79dc61b302f6c5eca5a2932361a22b4 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -738,12 +738,7 @@ let rec parse_ty : >>? fun (Ex_ty tr, ctxt) -> lambda_t loc ta tr >|? fun ty -> return ctxt ty | Prim (loc, T_option, [ut], annot) -> - (if legacy then - (* legacy semantics with (broken) field annotations *) - remove_field_annot ut >>? fun ut -> - check_composed_type_annot loc annot >>? fun () -> ok ut - else check_type_annot loc annot >>? fun () -> ok ut) - >>? fun ut -> + check_type_annot loc annot >>? fun () -> parse_ty ctxt ~stack_depth:(stack_depth + 1) @@ -1767,9 +1762,8 @@ let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = Script_string.of_string v >|? fun s -> (s, ctxt) ) | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr) -let parse_toplevel : - context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult = - fun ctxt ~legacy toplevel -> +let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = + fun ctxt toplevel -> record_trace (Ill_typed_contract (toplevel, [])) @@ match root toplevel with @@ -1834,30 +1828,10 @@ let parse_toplevel : Some (s, sloc, sannot), Some (c, cloc, cannot), views ) -> - let p_pannot = - (* root name can be attached to either the parameter - primitive or the toplevel constructor (legacy only). - - In the latter case we move it to the parameter type. - *) - Script_ir_annot.has_field_annot p >>? function - | true -> ok (p, pannot) - | false -> ( - match pannot with - | [single] when legacy -> ( - is_field_annot ploc single >|? fun is_field_annot -> - match (is_field_annot, p) with - | true, Prim (loc, prim, args, annots) -> - (Prim (loc, prim, args, single :: annots), []) - | _ -> (p, [])) - | _ -> ok (p, pannot)) - in - (* only one field annot is allowed to set the root entrypoint name *) - p_pannot >>? fun (arg_type, pannot) -> Script_ir_annot.error_unexpected_annot ploc pannot >>? fun () -> Script_ir_annot.error_unexpected_annot cloc cannot >>? fun () -> Script_ir_annot.error_unexpected_annot sloc sannot >|? fun () -> - ({code_field = c; arg_type; views; storage_type = s}, ctxt)) + ({code_field = c; arg_type = p; views; storage_type = s}, ctxt)) (* Normalize lambdas during parsing *) @@ -4025,7 +3999,7 @@ and parse_instr : contracts but then we throw away the typed version, except for the storage type which is kept for efficiency in the ticket scanner. *) let canonical_code = Micheline.strip_locations code in - parse_toplevel ctxt ~legacy canonical_code + parse_toplevel ctxt canonical_code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> record_trace (Ill_formed_type (Some "parameter", canonical_code, location arg_type)) @@ -4666,8 +4640,7 @@ and parse_contract : code >>? fun (code, ctxt) -> (* can only fail because of gas *) - parse_toplevel ctxt ~legacy:true code - >>? fun ({arg_type; _}, ctxt) -> + parse_toplevel ctxt code >>? fun ({arg_type; _}, ctxt) -> parse_parameter_ty_and_entrypoints ctxt ~stack_depth:(stack_depth + 1) @@ -4793,7 +4766,7 @@ let parse_code : >>?= fun (code, ctxt) -> let legacy = elab_conf.legacy in Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code + parse_toplevel ctxt code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> let arg_type_loc = location arg_type in record_trace @@ -4903,7 +4876,7 @@ let typecheck_code : fun ~unparse_code_rec ~legacy ~show_types ctxt code -> (* Constants need to be expanded or [parse_toplevel] may fail. *) Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code >>?= fun (toplevel, ctxt) -> + parse_toplevel ctxt code >>?= fun (toplevel, ctxt) -> let {arg_type; storage_type; code_field; views} = toplevel in let type_map = ref [] in let arg_type_loc = location arg_type in @@ -5538,9 +5511,9 @@ let unparse_code ctxt mode code = let parse_contract_data context loc arg_ty contract ~entrypoint = parse_contract_data ~stack_depth:0 context loc arg_ty contract ~entrypoint -let parse_toplevel ctxt ~legacy toplevel = +let parse_toplevel ctxt toplevel = Global_constants_storage.expand ctxt toplevel >>=? fun (ctxt, toplevel) -> - Lwt.return @@ parse_toplevel ctxt ~legacy toplevel + Lwt.return @@ parse_toplevel ctxt toplevel let parse_comparable_ty = parse_comparable_ty ~stack_depth:0 diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index b945d3347db3c794132838fae80df1cd0cbab3e0..7cb107ef2c8af2d997a897fccdb8d01824a6d0dc 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -297,7 +297,7 @@ val parse_ty : (ex_ty * context) tzresult val parse_toplevel : - context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult Lwt.t + context -> Script.expr -> (toplevel * context) tzresult Lwt.t (** High-level function to typecheck a Michelson script. This function is not used for validating operations but only for the [typecheck_code] RPC. diff --git a/tezt/tests/script_annotations.ml b/tezt/tests/script_annotations.ml index e5045f0c1ade8ea22c9d97d1cc1ed0e08dbe33f7..0da34ff388894980b16fe4f4ecaade2a110fe85a 100644 --- a/tezt/tests/script_annotations.ml +++ b/tezt/tests/script_annotations.ml @@ -31,6 +31,17 @@ Subject: Runs Michelson annotation tests using [octez-client typecheck data ...]. *) +let typecheck_wrapper ?res (f : Client.t -> Process.t) client = + match res with + | None -> Process.check @@ f client + | Some msg -> Process.check_error ~exit_code:1 ~msg @@ f client + +let typecheck_data ?res ?legacy ~data ~typ client = + typecheck_wrapper ?res (Client.spawn_typecheck_data ?legacy ~data ~typ) client + +let typecheck_script ?res ?legacy ~script client = + typecheck_wrapper ?res (Client.spawn_typecheck_script ?legacy ~script) client + let register = Protocol.register_test ~__FILE__ @@ -40,112 +51,117 @@ let register = let* client = Client.init_mockup ~protocol () in (* annotation length limit positive case *) let* () = - Client.typecheck_data - ~data:"3" - ~typ:(sf "(int :%s)" @@ String.make 254 'a') - client + typecheck_data ~data:"3" ~typ:(sf "(int :%s)" @@ String.make 254 'a') client in (* annotation length limit negative case *) let* () = - Process.check_error - ~exit_code:1 - ~msg:(rex "annotation exceeded maximum length \\(255 chars\\)") - @@ Client.spawn_typecheck_data - ~data:"3" - ~typ:(sf "(int :%s)" @@ String.make 255 'a') - client + typecheck_data + ~res:(rex "annotation exceeded maximum length \\(255 chars\\)") + ~data:"3" + ~typ:(sf "(int :%s)" @@ String.make 255 'a') + client in (* alphabetic field annotation in type positive case *) let* () = - Client.typecheck_data ~data:"Pair 0 0" ~typ:"pair (nat %x) (int %y)" client + typecheck_data ~data:"Pair 0 0" ~typ:"pair (nat %x) (int %y)" client in (* numeric field annotation in type positive case *) let* () = - Client.typecheck_data ~data:"Pair 0 0" ~typ:"pair (nat %1) (int %2)" client + typecheck_data ~data:"Pair 0 0" ~typ:"pair (nat %1) (int %2)" client in (* field annotation with invalid characters in type *) let* () = - Process.check_error ~exit_code:1 ~msg:(rex "unexpected annotation") - @@ Client.spawn_typecheck_data - ~data:"Pair 0 0" - ~typ:"pair (nat %.) (int %.)" - client + typecheck_data + ~res:(rex "unexpected annotation") + ~data:"Pair 0 0" + ~typ:"pair (nat %.) (int %.)" + client in (* alphabetic field annotation in lambda data *) let* () = - Client.typecheck_data + typecheck_data ~data:"{ CAR %x }" ~typ:"lambda (pair (nat %x) (int %y)) nat" client in (* numeric field annotation in lambda data *) let* () = - Client.typecheck_data + typecheck_data ~data:"{ CAR %1 }" ~typ:"lambda (pair (nat %1) (int %2)) nat" client in (* field annotation with invalid characters in lambda data *) let* () = - Process.check_error ~exit_code:1 ~msg:(rex "unexpected annotation") - @@ Client.spawn_typecheck_data - ~data:"{ CAR %. }" - ~typ:"lambda (pair (nat %.) (int %.)) nat" - client + typecheck_data + ~res:(rex "unexpected annotation") + ~data:"{ CAR %. }" + ~typ:"lambda (pair (nat %.) (int %.)) nat" + client in - (* LEGACY: alphabetic field annotation in parameter root *) + (* LEGACY: until Nairobi alphabetic field annotation in parameter + root was allowed in legacy mode *) let* () = - Client.typecheck_script + typecheck_script + ?res: + (if Protocol.(number protocol > number Nairobi) then + Some (rex "unexpected annotation") + else None) ~legacy:true ~script:"parameter %r unit; storage unit; code { FAILWITH }" client in - (* LEGACY: numeric field annotation in parameter root *) + (* LEGACY: until Nairobi numeric field annotation in parameter root + was allowed in legacy mode *) let* () = - Client.typecheck_script + typecheck_script + ?res: + (if Protocol.(number protocol > number Nairobi) then + Some (rex "unexpected annotation") + else None) ~legacy:true ~script:"parameter %1 unit; storage unit; code { FAILWITH }" client in (* alphabetic field annotation in parameter root *) let* () = - Process.check_error ~exit_code:1 ~msg:(rex "unexpected annotation") - @@ Client.spawn_typecheck_script - ~script:"parameter %r unit; storage unit; code { FAILWITH }" - client + typecheck_script + ~res:(rex "unexpected annotation") + ~script:"parameter %r unit; storage unit; code { FAILWITH }" + client in (* numeric field annotation in parameter root *) let* () = - Process.check_error ~exit_code:1 ~msg:(rex "unexpected annotation") - @@ Client.spawn_typecheck_script - ~script:"parameter %1 unit; storage unit; code { FAILWITH }" - client + typecheck_script + ~res:(rex "unexpected annotation") + ~script:"parameter %1 unit; storage unit; code { FAILWITH }" + client in (* field annotation with invalid characters in parameter root *) let* () = - Process.check_error ~exit_code:1 ~msg:(rex "unexpected annotation") - @@ Client.spawn_typecheck_script - ~script:"parameter %. unit; storage unit; code { FAILWITH }" - client + typecheck_script + ~res:(rex "unexpected annotation") + ~script:"parameter %. unit; storage unit; code { FAILWITH }" + client in (* alphabetic field annotation in parameter root *) let* () = - Client.typecheck_script + typecheck_script ~script:"parameter (unit %r); storage unit; code { FAILWITH }" client in (* numeric field annotation in parameter root *) let* () = - Client.typecheck_script + typecheck_script ~script:"parameter (unit %1); storage unit; code { FAILWITH }" client in (* field annotation with invalid characters in parameter root *) let* () = - Process.check_error ~exit_code:1 ~msg:(rex "unexpected annotation") - @@ Client.spawn_typecheck_script - ~script:"parameter (unit %.); storage unit; code { FAILWITH }" - client + typecheck_script + ~res:(rex "unexpected annotation") + ~script:"parameter (unit %.); storage unit; code { FAILWITH }" + client in unit