From e78d817336cd2e84f38a61e70074049c15e76d0c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 11:25:27 +0200 Subject: [PATCH 01/11] Proto/Michelson: more consistent error traces in parse_data This commit improves the regularity of the error outputs of Michelson data elaboration; it adds Invalid_syntactic_constant errors at the end of parse_data traces in a few cases. --- .../lib_protocol/script_ir_translator.ml | 52 ++++++++++++++----- 1 file changed, 38 insertions(+), 14 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index f1f22087c124..9279d6e506db 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2322,25 +2322,34 @@ let rec parse_data : (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt) | Never_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_never expr (* Bls12_381 types *) - | Bls12_381_g1_t, Bytes (_, bs) -> ( + | Bls12_381_g1_t, (Bytes (loc, bs) as expr) -> ( let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g1 in match Script_bls.G1.of_bytes_opt bs with | Some pt -> return (pt, ctxt) - | None -> fail_parse_data ()) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid BLS12-381 G1 element"))) | Bls12_381_g1_t, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | Bls12_381_g2_t, Bytes (_, bs) -> ( + | Bls12_381_g2_t, (Bytes (loc, bs) as expr) -> ( let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g2 in match Script_bls.G2.of_bytes_opt bs with | Some pt -> return (pt, ctxt) - | None -> fail_parse_data ()) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid BLS12-381 G2 element"))) | Bls12_381_g2_t, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | Bls12_381_fr_t, Bytes (_, bs) -> ( + | Bls12_381_fr_t, (Bytes (loc, bs) as expr) -> ( let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in match Script_bls.Fr.of_bytes_opt bs with | Some pt -> return (pt, ctxt) - | None -> fail_parse_data ()) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid BLS12-381 field element"))) | Bls12_381_fr_t, Int (_, v) -> let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in return (Script_bls.Fr.of_z v, ctxt) @@ -2351,7 +2360,7 @@ let rec parse_data : of identifiers with [allow_forged]. *) (* Sapling *) - | Sapling_transaction_t memo_size, Bytes (_, bytes) -> ( + | Sapling_transaction_t memo_size, (Bytes (loc, bytes) as expr) -> ( match Data_encoding.Binary.of_bytes_opt Sapling.transaction_encoding bytes with @@ -2366,10 +2375,14 @@ let rec parse_data : transac_memo_size in return (transaction, ctxt)) - | None -> fail_parse_data ()) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid Sapling transaction"))) | Sapling_transaction_t _, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes) -> ( + | Sapling_transaction_deprecated_t memo_size, (Bytes (loc, bytes) as expr) + -> ( match Data_encoding.Binary.of_bytes_opt Sapling.Legacy.transaction_encoding @@ -2386,7 +2399,12 @@ let rec parse_data : transac_memo_size in return (transaction, ctxt)) - | None -> fail_parse_data ()) + | None -> + traced_fail + (Invalid_syntactic_constant + ( loc, + strip_locations expr, + "a valid Sapling transaction (deprecated format)" ))) | Sapling_transaction_deprecated_t _, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Sapling_state_t memo_size, Int (loc, id) -> @@ -2410,7 +2428,7 @@ let rec parse_data : traced_fail (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) - | Chest_key_t, Bytes (_, bytes) -> ( + | Chest_key_t, (Bytes (loc, bytes) as expr) -> ( let*? ctxt = Gas.consume ctxt Typecheck_costs.chest_key in match Data_encoding.Binary.of_bytes_opt @@ -2418,10 +2436,13 @@ let rec parse_data : bytes with | Some chest_key -> return (chest_key, ctxt) - | None -> fail_parse_data ()) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid time-lock chest key"))) | Chest_key_t, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | Chest_t, Bytes (_, bytes) -> ( + | Chest_t, (Bytes (loc, bytes) as expr) -> ( let*? ctxt = Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) in @@ -2429,7 +2450,10 @@ let rec parse_data : Data_encoding.Binary.of_bytes_opt Script_timelock.chest_encoding bytes with | Some chest -> return (chest, ctxt) - | None -> fail_parse_data ()) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid time-lock chest"))) | Chest_t, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) -- GitLab From 2246fb0fda19b2653033ef43dcde0c6dcca2c505 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 11:37:19 +0200 Subject: [PATCH 02/11] Proto/Michelson: regroup parse_data patterns by type --- .../lib_protocol/script_ir_translator.ml | 232 ++++++++++-------- 1 file changed, 124 insertions(+), 108 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 9279d6e506db..f19d71397f1c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2322,91 +2322,101 @@ let rec parse_data : (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt) | Never_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_never expr (* Bls12_381 types *) - | Bls12_381_g1_t, (Bytes (loc, bs) as expr) -> ( - let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g1 in - match Script_bls.G1.of_bytes_opt bs with - | Some pt -> return (pt, ctxt) - | None -> - traced_fail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid BLS12-381 G1 element"))) - | Bls12_381_g1_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | Bls12_381_g2_t, (Bytes (loc, bs) as expr) -> ( - let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g2 in - match Script_bls.G2.of_bytes_opt bs with - | Some pt -> return (pt, ctxt) - | None -> - traced_fail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid BLS12-381 G2 element"))) - | Bls12_381_g2_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | Bls12_381_fr_t, (Bytes (loc, bs) as expr) -> ( - let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in - match Script_bls.Fr.of_bytes_opt bs with - | Some pt -> return (pt, ctxt) - | None -> - traced_fail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid BLS12-381 field element"))) - | Bls12_381_fr_t, Int (_, v) -> - let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in - return (Script_bls.Fr.of_z v, ctxt) - | Bls12_381_fr_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + | Bls12_381_g1_t, expr -> ( + match expr with + | Bytes (loc, bs) as expr -> ( + let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g1 in + match Script_bls.G1.of_bytes_opt bs with + | Some pt -> return (pt, ctxt) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid BLS12-381 G1 element"))) + | expr -> + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | Bls12_381_g2_t, expr -> ( + match expr with + | Bytes (loc, bs) as expr -> ( + let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g2 in + match Script_bls.G2.of_bytes_opt bs with + | Some pt -> return (pt, ctxt) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid BLS12-381 G2 element"))) + | expr -> + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | Bls12_381_fr_t, expr -> ( + match expr with + | Bytes (loc, bs) as expr -> ( + let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in + match Script_bls.Fr.of_bytes_opt bs with + | Some pt -> return (pt, ctxt) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid BLS12-381 field element")) + ) + | Int (_, v) -> + let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in + return (Script_bls.Fr.of_z v, ctxt) + | expr -> + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) (* /!\ When adding new lazy storage kinds, you may want to guard the parsing of identifiers with [allow_forged]. *) (* Sapling *) - | Sapling_transaction_t memo_size, (Bytes (loc, bytes) as expr) -> ( - match - Data_encoding.Binary.of_bytes_opt Sapling.transaction_encoding bytes - with - | Some transaction -> ( - match Sapling.transaction_get_memo_size transaction with - | None -> return (transaction, ctxt) - | Some transac_memo_size -> - let*? () = - memo_size_eq - ~error_details:(Informative ()) - memo_size - transac_memo_size - in - return (transaction, ctxt)) - | None -> - traced_fail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid Sapling transaction"))) - | Sapling_transaction_t _, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | Sapling_transaction_deprecated_t memo_size, (Bytes (loc, bytes) as expr) - -> ( - match - Data_encoding.Binary.of_bytes_opt - Sapling.Legacy.transaction_encoding - bytes - with - | Some transaction -> ( - match Sapling.Legacy.transaction_get_memo_size transaction with - | None -> return (transaction, ctxt) - | Some transac_memo_size -> - let*? () = - memo_size_eq - ~error_details:(Informative ()) - memo_size - transac_memo_size - in - return (transaction, ctxt)) - | None -> - traced_fail - (Invalid_syntactic_constant - ( loc, - strip_locations expr, - "a valid Sapling transaction (deprecated format)" ))) - | Sapling_transaction_deprecated_t _, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + | Sapling_transaction_t memo_size, expr -> ( + match expr with + | Bytes (loc, bytes) as expr -> ( + match + Data_encoding.Binary.of_bytes_opt Sapling.transaction_encoding bytes + with + | Some transaction -> ( + match Sapling.transaction_get_memo_size transaction with + | None -> return (transaction, ctxt) + | Some transac_memo_size -> + let*? () = + memo_size_eq + ~error_details:(Informative ()) + memo_size + transac_memo_size + in + return (transaction, ctxt)) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid Sapling transaction"))) + | expr -> + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | Sapling_transaction_deprecated_t memo_size, expr -> ( + match expr with + | Bytes (loc, bytes) as expr -> ( + match + Data_encoding.Binary.of_bytes_opt + Sapling.Legacy.transaction_encoding + bytes + with + | Some transaction -> ( + match Sapling.Legacy.transaction_get_memo_size transaction with + | None -> return (transaction, ctxt) + | Some transac_memo_size -> + let*? () = + memo_size_eq + ~error_details:(Informative ()) + memo_size + transac_memo_size + in + return (transaction, ctxt)) + | None -> + traced_fail + (Invalid_syntactic_constant + ( loc, + strip_locations expr, + "a valid Sapling transaction (deprecated format)" ))) + | expr -> + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) | Sapling_state_t memo_size, Int (loc, id) -> if allow_forged then let id = Sapling.Id.parse_z id in @@ -2428,34 +2438,40 @@ let rec parse_data : traced_fail (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) - | Chest_key_t, (Bytes (loc, bytes) as expr) -> ( - let*? ctxt = Gas.consume ctxt Typecheck_costs.chest_key in - match - Data_encoding.Binary.of_bytes_opt - Script_timelock.chest_key_encoding - bytes - with - | Some chest_key -> return (chest_key, ctxt) - | None -> - traced_fail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid time-lock chest key"))) - | Chest_key_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | Chest_t, (Bytes (loc, bytes) as expr) -> ( - let*? ctxt = - Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) - in - match - Data_encoding.Binary.of_bytes_opt Script_timelock.chest_encoding bytes - with - | Some chest -> return (chest, ctxt) - | None -> - traced_fail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid time-lock chest"))) - | Chest_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + | Chest_key_t, expr -> ( + match expr with + | Bytes (loc, bytes) as expr -> ( + let*? ctxt = Gas.consume ctxt Typecheck_costs.chest_key in + match + Data_encoding.Binary.of_bytes_opt + Script_timelock.chest_key_encoding + bytes + with + | Some chest_key -> return (chest_key, ctxt) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid time-lock chest key"))) + | expr -> + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | Chest_t, expr -> ( + match expr with + | Bytes (loc, bytes) as expr -> ( + let*? ctxt = + Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) + in + match + Data_encoding.Binary.of_bytes_opt + Script_timelock.chest_encoding + bytes + with + | Some chest -> return (chest, ctxt) + | None -> + traced_fail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid time-lock chest"))) + | expr -> + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) and parse_view : type storage storagec. -- GitLab From 266c958886df397b4cdd39cfd8ceffbadebc2851 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 11:46:00 +0200 Subject: [PATCH 03/11] Proto/Michelson: simplify monads and tracing in parse_data --- .../lib_protocol/script_ir_translator.ml | 72 +++++++++++-------- 1 file changed, 43 insertions(+), 29 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index f19d71397f1c..b89c45d70ff1 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2323,51 +2323,60 @@ let rec parse_data : | Never_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_never expr (* Bls12_381 types *) | Bls12_381_g1_t, expr -> ( + Lwt.return @@ traced_no_lwt + @@ + let open Result_syntax in match expr with | Bytes (loc, bs) as expr -> ( - let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g1 in + let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g1 in match Script_bls.G1.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> - traced_fail + tzfail (Invalid_syntactic_constant (loc, strip_locations expr, "a valid BLS12-381 G1 element"))) - | expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) | Bls12_381_g2_t, expr -> ( + Lwt.return @@ traced_no_lwt + @@ + let open Result_syntax in match expr with | Bytes (loc, bs) as expr -> ( - let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g2 in + let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g2 in match Script_bls.G2.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> - traced_fail + tzfail (Invalid_syntactic_constant (loc, strip_locations expr, "a valid BLS12-381 G2 element"))) - | expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) | Bls12_381_fr_t, expr -> ( + Lwt.return @@ traced_no_lwt + @@ + let open Result_syntax in match expr with | Bytes (loc, bs) as expr -> ( - let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in + let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in match Script_bls.Fr.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> - traced_fail + tzfail (Invalid_syntactic_constant (loc, strip_locations expr, "a valid BLS12-381 field element")) ) | Int (_, v) -> - let*? ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in + let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in return (Script_bls.Fr.of_z v, ctxt) - | expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) (* /!\ When adding new lazy storage kinds, you may want to guard the parsing of identifiers with [allow_forged]. *) (* Sapling *) | Sapling_transaction_t memo_size, expr -> ( + Lwt.return @@ traced_no_lwt + @@ + let open Result_syntax in match expr with | Bytes (loc, bytes) as expr -> ( match @@ -2377,7 +2386,7 @@ let rec parse_data : match Sapling.transaction_get_memo_size transaction with | None -> return (transaction, ctxt) | Some transac_memo_size -> - let*? () = + let* () = memo_size_eq ~error_details:(Informative ()) memo_size @@ -2385,12 +2394,14 @@ let rec parse_data : in return (transaction, ctxt)) | None -> - traced_fail + tzfail (Invalid_syntactic_constant (loc, strip_locations expr, "a valid Sapling transaction"))) - | expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) | Sapling_transaction_deprecated_t memo_size, expr -> ( + Lwt.return @@ traced_no_lwt + @@ + let open Result_syntax in match expr with | Bytes (loc, bytes) as expr -> ( match @@ -2402,7 +2413,7 @@ let rec parse_data : match Sapling.Legacy.transaction_get_memo_size transaction with | None -> return (transaction, ctxt) | Some transac_memo_size -> - let*? () = + let* () = memo_size_eq ~error_details:(Informative ()) memo_size @@ -2410,13 +2421,12 @@ let rec parse_data : in return (transaction, ctxt)) | None -> - traced_fail + tzfail (Invalid_syntactic_constant ( loc, strip_locations expr, "a valid Sapling transaction (deprecated format)" ))) - | expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) | Sapling_state_t memo_size, Int (loc, id) -> if allow_forged then let id = Sapling.Id.parse_z id in @@ -2439,9 +2449,12 @@ let rec parse_data : (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) | Chest_key_t, expr -> ( + Lwt.return @@ traced_no_lwt + @@ + let open Result_syntax in match expr with | Bytes (loc, bytes) as expr -> ( - let*? ctxt = Gas.consume ctxt Typecheck_costs.chest_key in + let* ctxt = Gas.consume ctxt Typecheck_costs.chest_key in match Data_encoding.Binary.of_bytes_opt Script_timelock.chest_key_encoding @@ -2449,15 +2462,17 @@ let rec parse_data : with | Some chest_key -> return (chest_key, ctxt) | None -> - traced_fail + tzfail (Invalid_syntactic_constant (loc, strip_locations expr, "a valid time-lock chest key"))) - | expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) | Chest_t, expr -> ( + Lwt.return @@ traced_no_lwt + @@ + let open Result_syntax in match expr with | Bytes (loc, bytes) as expr -> ( - let*? ctxt = + let* ctxt = Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) in match @@ -2467,11 +2482,10 @@ let rec parse_data : with | Some chest -> return (chest, ctxt) | None -> - traced_fail + tzfail (Invalid_syntactic_constant (loc, strip_locations expr, "a valid time-lock chest"))) - | expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) and parse_view : type storage storagec. -- GitLab From 32008ebfbd32c36fe5f9019a7ac80442df1d43e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 11:49:32 +0200 Subject: [PATCH 04/11] Proto/Michelson: extract parse_bls12_381_g1 --- .../lib_protocol/script_ir_translator.ml | 30 ++++++++++--------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index b89c45d70ff1..3108babd2d69 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1718,6 +1718,20 @@ let parse_address ctxt : Script.node -> (address * context) tzresult = let parse_never expr : (never * context) tzresult = Result_syntax.tzfail @@ Invalid_never_expr (location expr) +let parse_bls12_381_g1 ctxt : + Script.node -> (Script_bls.G1.t * context) tzresult = + let open Result_syntax in + function + | Bytes (loc, bs) as expr -> ( + let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g1 in + match Script_bls.G1.of_bytes_opt bs with + | Some pt -> return (pt, ctxt) + | None -> + tzfail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid BLS12-381 G1 element"))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (* -- parse data of complex types -- *) let parse_pair (type r) parse_l parse_r ctxt ~legacy @@ -2322,20 +2336,8 @@ let rec parse_data : (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt) | Never_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_never expr (* Bls12_381 types *) - | Bls12_381_g1_t, expr -> ( - Lwt.return @@ traced_no_lwt - @@ - let open Result_syntax in - match expr with - | Bytes (loc, bs) as expr -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g1 in - match Script_bls.G1.of_bytes_opt bs with - | Some pt -> return (pt, ctxt) - | None -> - tzfail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid BLS12-381 G1 element"))) - | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | Bls12_381_g1_t, expr -> + Lwt.return @@ traced_no_lwt @@ parse_bls12_381_g1 ctxt expr | Bls12_381_g2_t, expr -> ( Lwt.return @@ traced_no_lwt @@ -- GitLab From 97f877d9861821a8835adaae7acc80731eccd3e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 11:51:09 +0200 Subject: [PATCH 05/11] Proto/Michelson: extract parse_bls12_381_g2 --- .../lib_protocol/script_ir_translator.ml | 30 ++++++++++--------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 3108babd2d69..a0cabcad0cde 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1732,6 +1732,20 @@ let parse_bls12_381_g1 ctxt : (loc, strip_locations expr, "a valid BLS12-381 G1 element"))) | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) +let parse_bls12_381_g2 ctxt : + Script.node -> (Script_bls.G2.t * context) tzresult = + let open Result_syntax in + function + | Bytes (loc, bs) as expr -> ( + let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g2 in + match Script_bls.G2.of_bytes_opt bs with + | Some pt -> return (pt, ctxt) + | None -> + tzfail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid BLS12-381 G2 element"))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (* -- parse data of complex types -- *) let parse_pair (type r) parse_l parse_r ctxt ~legacy @@ -2338,20 +2352,8 @@ let rec parse_data : (* Bls12_381 types *) | Bls12_381_g1_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bls12_381_g1 ctxt expr - | Bls12_381_g2_t, expr -> ( - Lwt.return @@ traced_no_lwt - @@ - let open Result_syntax in - match expr with - | Bytes (loc, bs) as expr -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g2 in - match Script_bls.G2.of_bytes_opt bs with - | Some pt -> return (pt, ctxt) - | None -> - tzfail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid BLS12-381 G2 element"))) - | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | Bls12_381_g2_t, expr -> + Lwt.return @@ traced_no_lwt @@ parse_bls12_381_g2 ctxt expr | Bls12_381_fr_t, expr -> ( Lwt.return @@ traced_no_lwt @@ -- GitLab From 3b0b377d4a3f100adc172a945378a88660c60440 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 11:52:44 +0200 Subject: [PATCH 06/11] Proto/Michelson: extract parse_bls12_381_fr --- .../lib_protocol/script_ir_translator.ml | 37 ++++++++++--------- 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a0cabcad0cde..eea2aefc3d40 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1746,6 +1746,23 @@ let parse_bls12_381_g2 ctxt : (loc, strip_locations expr, "a valid BLS12-381 G2 element"))) | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) +let parse_bls12_381_fr ctxt : + Script.node -> (Script_bls.Fr.t * context) tzresult = + let open Result_syntax in + function + | Bytes (loc, bs) as expr -> ( + let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in + match Script_bls.Fr.of_bytes_opt bs with + | Some pt -> return (pt, ctxt) + | None -> + tzfail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid BLS12-381 field element"))) + | Int (_, v) -> + let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in + return (Script_bls.Fr.of_z v, ctxt) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (* -- parse data of complex types -- *) let parse_pair (type r) parse_l parse_r ctxt ~legacy @@ -2354,24 +2371,8 @@ let rec parse_data : Lwt.return @@ traced_no_lwt @@ parse_bls12_381_g1 ctxt expr | Bls12_381_g2_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bls12_381_g2 ctxt expr - | Bls12_381_fr_t, expr -> ( - Lwt.return @@ traced_no_lwt - @@ - let open Result_syntax in - match expr with - | Bytes (loc, bs) as expr -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in - match Script_bls.Fr.of_bytes_opt bs with - | Some pt -> return (pt, ctxt) - | None -> - tzfail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid BLS12-381 field element")) - ) - | Int (_, v) -> - let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in - return (Script_bls.Fr.of_z v, ctxt) - | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | Bls12_381_fr_t, expr -> + Lwt.return @@ traced_no_lwt @@ parse_bls12_381_fr ctxt expr (* /!\ When adding new lazy storage kinds, you may want to guard the parsing of identifiers with [allow_forged]. -- GitLab From c8eb1557bd9f935d5cd598b5942988759dd61eb0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 11:57:17 +0200 Subject: [PATCH 07/11] Proto/Michelson: extract parse_sapling_transaction --- .../lib_protocol/script_ir_translator.ml | 51 ++++++++++--------- 1 file changed, 27 insertions(+), 24 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index eea2aefc3d40..d344f5b25a3d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1763,6 +1763,31 @@ let parse_bls12_381_fr ctxt : return (Script_bls.Fr.of_z v, ctxt) | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) +let parse_sapling_transaction ctxt ~memo_size : + Script.node -> (Sapling.transaction * context) tzresult = + let open Result_syntax in + function + | Bytes (loc, bytes) as expr -> ( + match + Data_encoding.Binary.of_bytes_opt Sapling.transaction_encoding bytes + with + | Some transaction -> ( + match Sapling.transaction_get_memo_size transaction with + | None -> return (transaction, ctxt) + | Some transac_memo_size -> + let* () = + memo_size_eq + ~error_details:(Informative ()) + memo_size + transac_memo_size + in + return (transaction, ctxt)) + | None -> + tzfail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid Sapling transaction"))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (* -- parse data of complex types -- *) let parse_pair (type r) parse_l parse_r ctxt ~legacy @@ -2378,31 +2403,9 @@ let rec parse_data : of identifiers with [allow_forged]. *) (* Sapling *) - | Sapling_transaction_t memo_size, expr -> ( + | Sapling_transaction_t memo_size, expr -> Lwt.return @@ traced_no_lwt - @@ - let open Result_syntax in - match expr with - | Bytes (loc, bytes) as expr -> ( - match - Data_encoding.Binary.of_bytes_opt Sapling.transaction_encoding bytes - with - | Some transaction -> ( - match Sapling.transaction_get_memo_size transaction with - | None -> return (transaction, ctxt) - | Some transac_memo_size -> - let* () = - memo_size_eq - ~error_details:(Informative ()) - memo_size - transac_memo_size - in - return (transaction, ctxt)) - | None -> - tzfail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid Sapling transaction"))) - | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + @@ parse_sapling_transaction ctxt ~memo_size expr | Sapling_transaction_deprecated_t memo_size, expr -> ( Lwt.return @@ traced_no_lwt @@ -- GitLab From eda0e5a1c567904f56755f83487ca97cd287bdb4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 12:00:54 +0200 Subject: [PATCH 08/11] Proto/Michelson: extract parse_sapling_transaction_deprecated --- .../lib_protocol/script_ir_translator.ml | 59 ++++++++++--------- 1 file changed, 31 insertions(+), 28 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index d344f5b25a3d..bdb0184d38ef 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1788,6 +1788,35 @@ let parse_sapling_transaction ctxt ~memo_size : (loc, strip_locations expr, "a valid Sapling transaction"))) | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) +let parse_sapling_transaction_deprecated ctxt ~memo_size : + Script.node -> (Sapling.Legacy.transaction * context) tzresult = + let open Result_syntax in + function + | Bytes (loc, bytes) as expr -> ( + match + Data_encoding.Binary.of_bytes_opt + Sapling.Legacy.transaction_encoding + bytes + with + | Some transaction -> ( + match Sapling.Legacy.transaction_get_memo_size transaction with + | None -> return (transaction, ctxt) + | Some transac_memo_size -> + let* () = + memo_size_eq + ~error_details:(Informative ()) + memo_size + transac_memo_size + in + return (transaction, ctxt)) + | None -> + tzfail + (Invalid_syntactic_constant + ( loc, + strip_locations expr, + "a valid Sapling transaction (deprecated format)" ))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (* -- parse data of complex types -- *) let parse_pair (type r) parse_l parse_r ctxt ~legacy @@ -2406,35 +2435,9 @@ let rec parse_data : | Sapling_transaction_t memo_size, expr -> Lwt.return @@ traced_no_lwt @@ parse_sapling_transaction ctxt ~memo_size expr - | Sapling_transaction_deprecated_t memo_size, expr -> ( + | Sapling_transaction_deprecated_t memo_size, expr -> Lwt.return @@ traced_no_lwt - @@ - let open Result_syntax in - match expr with - | Bytes (loc, bytes) as expr -> ( - match - Data_encoding.Binary.of_bytes_opt - Sapling.Legacy.transaction_encoding - bytes - with - | Some transaction -> ( - match Sapling.Legacy.transaction_get_memo_size transaction with - | None -> return (transaction, ctxt) - | Some transac_memo_size -> - let* () = - memo_size_eq - ~error_details:(Informative ()) - memo_size - transac_memo_size - in - return (transaction, ctxt)) - | None -> - tzfail - (Invalid_syntactic_constant - ( loc, - strip_locations expr, - "a valid Sapling transaction (deprecated format)" ))) - | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + @@ parse_sapling_transaction_deprecated ctxt ~memo_size expr | Sapling_state_t memo_size, Int (loc, id) -> if allow_forged then let id = Sapling.Id.parse_z id in -- GitLab From addebf3f21d4a5c3f632e3dbc862d5a7b15ed915 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 12:03:12 +0200 Subject: [PATCH 09/11] Proto/Michelson: extract parse_chest_key --- .../lib_protocol/script_ir_translator.ml | 38 ++++++++++--------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index bdb0184d38ef..c430a753436e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1817,6 +1817,24 @@ let parse_sapling_transaction_deprecated ctxt ~memo_size : "a valid Sapling transaction (deprecated format)" ))) | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) +let parse_chest_key ctxt : + Script.node -> (Script_timelock.chest_key * context) tzresult = + let open Result_syntax in + function + | Bytes (loc, bytes) as expr -> ( + let* ctxt = Gas.consume ctxt Typecheck_costs.chest_key in + match + Data_encoding.Binary.of_bytes_opt + Script_timelock.chest_key_encoding + bytes + with + | Some chest_key -> return (chest_key, ctxt) + | None -> + tzfail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid time-lock chest key"))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (* -- parse data of complex types -- *) let parse_pair (type r) parse_l parse_r ctxt ~legacy @@ -2459,24 +2477,8 @@ let rec parse_data : traced_fail (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) - | Chest_key_t, expr -> ( - Lwt.return @@ traced_no_lwt - @@ - let open Result_syntax in - match expr with - | Bytes (loc, bytes) as expr -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.chest_key in - match - Data_encoding.Binary.of_bytes_opt - Script_timelock.chest_key_encoding - bytes - with - | Some chest_key -> return (chest_key, ctxt) - | None -> - tzfail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid time-lock chest key"))) - | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | Chest_key_t, expr -> + Lwt.return @@ traced_no_lwt @@ parse_chest_key ctxt expr | Chest_t, expr -> ( Lwt.return @@ traced_no_lwt @@ -- GitLab From 1c8d264e39be52ccbb11b0b498371c06f834f2f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 12:04:33 +0200 Subject: [PATCH 10/11] Proto/Michelson: extract parse_chest --- .../lib_protocol/script_ir_translator.ml | 39 +++++++++---------- 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index c430a753436e..91fcfc55f07c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1835,6 +1835,24 @@ let parse_chest_key ctxt : (loc, strip_locations expr, "a valid time-lock chest key"))) | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) +let parse_chest ctxt : Script.node -> (Script_timelock.chest * context) tzresult + = + let open Result_syntax in + function + | Bytes (loc, bytes) as expr -> ( + let* ctxt = + Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) + in + match + Data_encoding.Binary.of_bytes_opt Script_timelock.chest_encoding bytes + with + | Some chest -> return (chest, ctxt) + | None -> + tzfail + (Invalid_syntactic_constant + (loc, strip_locations expr, "a valid time-lock chest"))) + | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (* -- parse data of complex types -- *) let parse_pair (type r) parse_l parse_r ctxt ~legacy @@ -2479,26 +2497,7 @@ let rec parse_data : (* Time lock*) | Chest_key_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_chest_key ctxt expr - | Chest_t, expr -> ( - Lwt.return @@ traced_no_lwt - @@ - let open Result_syntax in - match expr with - | Bytes (loc, bytes) as expr -> ( - let* ctxt = - Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) - in - match - Data_encoding.Binary.of_bytes_opt - Script_timelock.chest_encoding - bytes - with - | Some chest -> return (chest, ctxt) - | None -> - tzfail - (Invalid_syntactic_constant - (loc, strip_locations expr, "a valid time-lock chest"))) - | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + | Chest_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_chest ctxt expr and parse_view : type storage storagec. -- GitLab From 837716023e215a251193881071d409bda624c82f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 16:50:06 +0200 Subject: [PATCH 11/11] Changelog/Alpha: mention !10227 --- docs/protocols/alpha.rst | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/docs/protocols/alpha.rst b/docs/protocols/alpha.rst index cbb3c6d7b98e..6c70bb723342 100644 --- a/docs/protocols/alpha.rst +++ b/docs/protocols/alpha.rst @@ -99,6 +99,10 @@ Minor Changes - Arithmetic errors on Michelson ``mutez`` type have been exported so they can now be caught outside of the protocol. (MR :gl:`!9934`) +- Michelson error traces for elaboration of invalid data was made more + consistent by adding errors in some cases (BLS12-381 values, Sapling + transactions, and timelocks). (MR :gl:`!10227`) + Internal -------- -- GitLab