From 3ba332f2002163bf722d80cd09dcca8c8f63a84d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 30 Jun 2023 15:48:14 +0200 Subject: [PATCH 1/4] Proto/AI: expand matching on parameter --- src/proto_alpha/lib_protocol/apply.ml | 80 ++++++++++++++++----------- 1 file changed, 49 insertions(+), 31 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 908409e22774..d8c491264d0f 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -991,22 +991,37 @@ let apply_manager_operation : ctxt parameters >>?= fun (parameters, ctxt) -> - (match (Entrypoint.to_string entrypoint, Micheline.root parameters) with - | "default", Prim (_, D_Unit, [], _) -> + (match Entrypoint.to_string entrypoint with + | "default" -> + (match Micheline.root parameters with + | Prim (_, D_Unit, [], _) -> return_unit + | _ -> + tzfail (Script_interpreter.Bad_contract_parameter source_contract)) + >>=? fun () -> apply_transaction_to_implicit ~ctxt ~sender:source_contract ~amount ~pkh ~before_operation:ctxt_before_op - | "stake", Prim (_, D_Unit, [], _) -> + | "stake" -> + (match Micheline.root parameters with + | Prim (_, D_Unit, [], _) -> return_unit + | _ -> + tzfail (Script_interpreter.Bad_contract_parameter source_contract)) + >>=? fun () -> apply_stake ~ctxt ~sender:source ~amount ~destination:pkh ~before_operation:ctxt_before_op - | "unstake", Int (_, requested_amount) -> + | "unstake" -> + (match Micheline.root parameters with + | Int (_, requested_amount) -> return requested_amount + | _ -> + tzfail (Script_interpreter.Bad_contract_parameter source_contract)) + >>=? fun requested_amount -> apply_unstake ~ctxt ~sender:source @@ -1014,29 +1029,42 @@ let apply_manager_operation : ~requested_amount ~destination:pkh ~before_operation:ctxt_before_op - | "finalize_unstake", Prim (_, D_Unit, [], _) -> + | "finalize_unstake" -> + (match Micheline.root parameters with + | Prim (_, D_Unit, [], _) -> return_unit + | _ -> + tzfail (Script_interpreter.Bad_contract_parameter source_contract)) + >>=? fun () -> apply_finalize_unstake ~ctxt ~sender:source ~amount ~destination:pkh ~before_operation:ctxt_before_op - | ( "set_delegate_parameters", - Prim - ( _, - D_Pair, - [ - Int (_, staking_over_baking_limit_millionth); - Prim - ( _, - D_Pair, - [ - Int (_, baking_over_staking_edge_billionth); - Prim (_, D_Unit, [], []); - ], - [] ); - ], - [] ) ) -> + | "set_delegate_parameters" -> + (match Micheline.root parameters with + | Prim + ( _, + D_Pair, + [ + Int (_, staking_over_baking_limit_millionth); + Prim + ( _, + D_Pair, + [ + Int (_, baking_over_staking_edge_billionth); + Prim (_, D_Unit, [], []); + ], + [] ); + ], + [] ) -> + return + ( staking_over_baking_limit_millionth, + baking_over_staking_edge_billionth ) + | _ -> + tzfail (Script_interpreter.Bad_contract_parameter source_contract)) + >>=? fun ( staking_over_baking_limit_millionth, + baking_over_staking_edge_billionth ) -> apply_set_delegate_parameters ~ctxt ~sender:source @@ -1044,16 +1072,6 @@ let apply_manager_operation : ~staking_over_baking_limit_millionth ~baking_over_staking_edge_billionth ~before_operation:ctxt_before_op - | ( ( "default" | "stake" | "unstake" | "finalize_unstake" - | "set_delegate_parameters" ), - _ ) -> - (* Only allow: - - [unit] parameter to implicit accounts' default, stake, - and finalize_unstake entrypoints; - - [nat] parameter to implicit accounts' unstake entrypoint; - - [pair nat nat unit] parameter to implicit accounts' - set_delegate_parameters entrypoint.*) - tzfail (Script_interpreter.Bad_contract_parameter source_contract) | _ -> tzfail (Script_tc_errors.No_such_entrypoint entrypoint)) >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops) | Transaction -- GitLab From 7a7588529cf590e30f942312201fd2bddc239475 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 3 Jul 2023 14:54:07 +0200 Subject: [PATCH 2/4] Proto/Michelson: export Script.is_unit --- src/proto_alpha/lib_protocol/alpha_context.mli | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index e3ecc5ff833b..2175134b8691 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -758,6 +758,8 @@ module Script : sig val unit_parameter : lazy_expr + val is_unit : expr -> bool + val strip_locations_cost : _ michelson_node -> Gas.cost val strip_annotations_cost : node -> Gas.cost -- GitLab From 39b2b57465bacd9addd6b3262535bf27afac9178 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 30 Jun 2023 16:08:20 +0200 Subject: [PATCH 3/4] Proto/AI: use is_unit and parse_data --- src/proto_alpha/lib_protocol/apply.ml | 78 ++++++++++++--------------- 1 file changed, 35 insertions(+), 43 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index d8c491264d0f..a5f120e2acec 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -991,12 +991,12 @@ let apply_manager_operation : ctxt parameters >>?= fun (parameters, ctxt) -> + let elab_conf = Script_ir_translator_config.make ~legacy:false () in (match Entrypoint.to_string entrypoint with | "default" -> - (match Micheline.root parameters with - | Prim (_, D_Unit, [], _) -> return_unit - | _ -> - tzfail (Script_interpreter.Bad_contract_parameter source_contract)) + fail_unless + (Script.is_unit parameters) + (Script_interpreter.Bad_contract_parameter source_contract) >>=? fun () -> apply_transaction_to_implicit ~ctxt @@ -1005,10 +1005,9 @@ let apply_manager_operation : ~pkh ~before_operation:ctxt_before_op | "stake" -> - (match Micheline.root parameters with - | Prim (_, D_Unit, [], _) -> return_unit - | _ -> - tzfail (Script_interpreter.Bad_contract_parameter source_contract)) + fail_unless + (Script.is_unit parameters) + (Script_interpreter.Bad_contract_parameter source_contract) >>=? fun () -> apply_stake ~ctxt @@ -1017,23 +1016,24 @@ let apply_manager_operation : ~destination:pkh ~before_operation:ctxt_before_op | "unstake" -> - (match Micheline.root parameters with - | Int (_, requested_amount) -> return requested_amount - | _ -> - tzfail (Script_interpreter.Bad_contract_parameter source_contract)) - >>=? fun requested_amount -> + Script_ir_translator.parse_data + ~elab_conf + ctxt + ~allow_forged:false + Script_typed_ir.int_t + (Micheline.root parameters) + >>=? fun (requested_amount, ctxt) -> apply_unstake ~ctxt ~sender:source ~amount - ~requested_amount + ~requested_amount:(Script_int.to_zint requested_amount) ~destination:pkh ~before_operation:ctxt_before_op | "finalize_unstake" -> - (match Micheline.root parameters with - | Prim (_, D_Unit, [], _) -> return_unit - | _ -> - tzfail (Script_interpreter.Bad_contract_parameter source_contract)) + fail_unless + (Script.is_unit parameters) + (Script_interpreter.Bad_contract_parameter source_contract) >>=? fun () -> apply_finalize_unstake ~ctxt @@ -1042,35 +1042,27 @@ let apply_manager_operation : ~destination:pkh ~before_operation:ctxt_before_op | "set_delegate_parameters" -> - (match Micheline.root parameters with - | Prim - ( _, - D_Pair, - [ - Int (_, staking_over_baking_limit_millionth); - Prim - ( _, - D_Pair, - [ - Int (_, baking_over_staking_edge_billionth); - Prim (_, D_Unit, [], []); - ], - [] ); - ], - [] ) -> - return - ( staking_over_baking_limit_millionth, - baking_over_staking_edge_billionth ) - | _ -> - tzfail (Script_interpreter.Bad_contract_parameter source_contract)) - >>=? fun ( staking_over_baking_limit_millionth, - baking_over_staking_edge_billionth ) -> + Script_typed_ir.(pair_t Micheline.dummy_location int_t unit_t) + >>?= fun (Ty_ex_c ty) -> + Script_typed_ir.(pair_t Micheline.dummy_location int_t ty) + >>?= fun (Ty_ex_c ty) -> + Script_ir_translator.parse_data + ~elab_conf + ctxt + ~allow_forged:false + ty + (Micheline.root parameters) + >>=? fun ( ( staking_over_baking_limit_millionth, + (baking_over_staking_edge_billionth, ()) ), + ctxt ) -> apply_set_delegate_parameters ~ctxt ~sender:source ~destination:pkh - ~staking_over_baking_limit_millionth - ~baking_over_staking_edge_billionth + ~staking_over_baking_limit_millionth: + (Script_int.to_zint staking_over_baking_limit_millionth) + ~baking_over_staking_edge_billionth: + (Script_int.to_zint baking_over_staking_edge_billionth) ~before_operation:ctxt_before_op | _ -> tzfail (Script_tc_errors.No_such_entrypoint entrypoint)) >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops) -- GitLab From b94bc392c5267775aafb570c91fd977e77e9180b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 3 Jul 2023 15:11:03 +0200 Subject: [PATCH 4/4] Proto/Michelson: pre-compute `pair int int unit` --- src/proto_alpha/lib_protocol/apply.ml | 6 +----- src/proto_alpha/lib_protocol/script_typed_ir.ml | 6 ++++++ src/proto_alpha/lib_protocol/script_typed_ir.mli | 2 ++ 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index a5f120e2acec..030e52fc4654 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1042,15 +1042,11 @@ let apply_manager_operation : ~destination:pkh ~before_operation:ctxt_before_op | "set_delegate_parameters" -> - Script_typed_ir.(pair_t Micheline.dummy_location int_t unit_t) - >>?= fun (Ty_ex_c ty) -> - Script_typed_ir.(pair_t Micheline.dummy_location int_t ty) - >>?= fun (Ty_ex_c ty) -> Script_ir_translator.parse_data ~elab_conf ctxt ~allow_forged:false - ty + Script_typed_ir.pair_int_int_unit_t (Micheline.root parameters) >>=? fun ( ( staking_over_baking_limit_millionth, (baking_over_staking_edge_billionth, ()) ), diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index eacc421362bf..098caa4d2e27 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1949,6 +1949,12 @@ let comparable_pair_t loc l r = let comparable_pair_3_t loc l m r = comparable_pair_t loc m r >>? fun r -> comparable_pair_t loc l r +let pair_int_int_unit_t = + let iu_metadata = assert_ok2 pair_metadata int_metadata unit_metadata in + let iiu_metadata = assert_ok2 pair_metadata int_metadata iu_metadata in + Pair_t + (int_t, Pair_t (int_t, unit_t, iu_metadata, YesYes), iiu_metadata, YesYes) + let or_t : type a ac b bc. Script.location -> (a, ac) ty -> (b, bc) ty -> (a, b) or_ ty_ex_c tzresult = diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 834641ddf2b5..b5889288a17b 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1743,6 +1743,8 @@ val comparable_pair_3_t : 'c comparable_ty -> ('a, ('b, 'c) pair) pair comparable_ty tzresult +val pair_int_int_unit_t : (z num, (z num, unit) pair) pair comparable_ty + val or_t : Script.location -> ('a, _) ty -> ('b, _) ty -> ('a, 'b) or_ ty_ex_c tzresult -- GitLab