From bad01f52a1056ac8a8fab8d55bf8ac10ca469cd3 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/33] 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 05e977e164f8..97e6ffc44962 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2296,25 +2296,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) @@ -2325,7 +2334,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 @@ -2340,10 +2349,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 @@ -2360,7 +2373,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) -> @@ -2384,7 +2402,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 @@ -2392,10 +2410,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 @@ -2403,7 +2424,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 f72ac47a8db6a9a724cbda65b77573e1cb1d7c63 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/33] 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 97e6ffc44962..1a754fe7071c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2296,91 +2296,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 @@ -2402,34 +2412,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 3430b890158be38b8ed0c515211508e4c7eb171e 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/33] 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 1a754fe7071c..25bd7601c553 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2297,51 +2297,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 @@ -2351,7 +2360,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 @@ -2359,12 +2368,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 @@ -2376,7 +2387,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 @@ -2384,13 +2395,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 @@ -2413,9 +2423,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 @@ -2423,15 +2436,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 @@ -2441,11 +2456,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 88321066f424142c7e7d259898496864d27027e4 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/33] 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 25bd7601c553..137a8f98aa62 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1691,6 +1691,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 @@ -2296,20 +2310,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 bcc977adc0434e9b401fba89f45a1adbc8fa6e6f 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/33] 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 137a8f98aa62..98ca9a2d2142 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1705,6 +1705,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 @@ -2312,20 +2326,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 90ce9cde9da09402139dfeb5a94efe61809c7f3e 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/33] 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 98ca9a2d2142..7e89e4488124 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1719,6 +1719,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 @@ -2328,24 +2345,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 8e21e8b1ebb6b0ca48a96f0ac59a3da2d812199e 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/33] 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 7e89e4488124..9fa12b92f5b1 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1736,6 +1736,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 @@ -2352,31 +2377,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 dbedf799dacc6b1f393db1f52410c225f1b560e2 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/33] 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 9fa12b92f5b1..f3d77e530de0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1761,6 +1761,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 @@ -2380,35 +2409,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 7f31ce85dd0485aed5ca53ec44f2c468de511e2d 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/33] 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 f3d77e530de0..840f51cabee7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1790,6 +1790,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 @@ -2433,24 +2451,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 af520d55ee74a8c3198d8d0720e96cc29bf765fe 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/33] 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 840f51cabee7..58b3b754c37f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1808,6 +1808,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 @@ -2453,26 +2471,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 af71ae96ad7d89c1b18b06ff0adf4f1696a998f1 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/33] 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 1074703f8c6d..88cf5e255e3e 100644 --- a/docs/protocols/alpha.rst +++ b/docs/protocols/alpha.rst @@ -67,6 +67,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 From 1ba634313c7e8b3b9b0a4e61fdeac1c40804a09e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 18 Sep 2023 13:05:26 +0200 Subject: [PATCH 12/33] Proto/Michelson: move parse_unit to the gas monad --- .../lib_protocol/script_ir_translator.ml | 25 +++++++++++++------ 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 58b3b754c37f..82e7f9c4715d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1435,16 +1435,17 @@ let opened_ticket_type loc ty = comparable_pair_3_t loc address_t ty nat_t (* -- parse data of primitive types -- *) -let parse_unit ctxt ~legacy = - let open Result_syntax in +let parse_unit ~legacy = + let open Gas_monad.Syntax in function | Prim (loc, D_Unit, [], annot) -> - let* () = - if legacy (* Legacy check introduced before Ithaca. *) then return_unit + let*? () = + if legacy (* Legacy check introduced before Ithaca. *) then + Result.return_unit else error_unexpected_annot loc annot in - let+ ctxt = Gas.consume ctxt Typecheck_costs.unit in - ((), ctxt) + let+$ () = Typecheck_costs.unit in + () | Prim (loc, D_Unit, l, _) -> tzfail @@ Invalid_arity (loc, D_Unit, 0, List.length l) | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Unit] @@ -2081,6 +2082,14 @@ let rec parse_data : let fail_parse_data () = tzfail (parse_data_error ()) in let traced_no_lwt body = record_trace_eval parse_data_error body in let traced body = trace_eval parse_data_error body in + let traced_from_gas_monad ctxt body = + Lwt.return @@ traced_no_lwt + @@ + let open Result_syntax in + let* res, ctxt = Gas_monad.run ctxt body in + let+ res in + (res, ctxt) + in let traced_fail err = Lwt.return @@ traced_no_lwt (Result_syntax.tzfail err) in @@ -2206,8 +2215,8 @@ let rec parse_data : let legacy = elab_conf.legacy in match (ty, script_data) with | Unit_t, expr -> - Lwt.return @@ traced_no_lwt - @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) + traced_from_gas_monad ctxt + @@ (parse_unit ~legacy expr : (a, error trace) Gas_monad.t) | Bool_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bool ctxt ~legacy expr | String_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_string ctxt expr | Bytes_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bytes ctxt expr -- GitLab From 7cbbfb18a393bf6a2f7310a757548e2113391946 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:40:29 +0200 Subject: [PATCH 13/33] Proto/Michelson: move parse_bool to the gas monad --- .../lib_protocol/script_ir_translator.ml | 24 ++++++++++--------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 82e7f9c4715d..f2d2a6342024 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1450,23 +1450,25 @@ let parse_unit ~legacy = tzfail @@ Invalid_arity (loc, D_Unit, 0, List.length l) | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Unit] -let parse_bool ctxt ~legacy = - let open Result_syntax in +let parse_bool ~legacy = + let open Gas_monad.Syntax in function | Prim (loc, D_True, [], annot) -> - let* () = - if legacy (* Legacy check introduced before Ithaca. *) then return_unit + let*? () = + if legacy (* Legacy check introduced before Ithaca. *) then + Result.return_unit else error_unexpected_annot loc annot in - let+ ctxt = Gas.consume ctxt Typecheck_costs.bool in - (true, ctxt) + let+$ () = Typecheck_costs.bool in + true | Prim (loc, D_False, [], annot) -> - let* () = - if legacy (* Legacy check introduced before Ithaca. *) then return_unit + let*? () = + if legacy (* Legacy check introduced before Ithaca. *) then + Result.return_unit else error_unexpected_annot loc annot in - let+ ctxt = Gas.consume ctxt Typecheck_costs.bool in - (false, ctxt) + let+$ () = Typecheck_costs.bool in + false | Prim (loc, ((D_True | D_False) as c), l, _) -> tzfail @@ Invalid_arity (loc, c, 0, List.length l) | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_True; D_False] @@ -2217,7 +2219,7 @@ let rec parse_data : | Unit_t, expr -> traced_from_gas_monad ctxt @@ (parse_unit ~legacy expr : (a, error trace) Gas_monad.t) - | Bool_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bool ctxt ~legacy expr + | Bool_t, expr -> traced_from_gas_monad ctxt @@ parse_bool ~legacy expr | String_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_string ctxt expr | Bytes_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bytes ctxt expr | Int_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_int ctxt expr -- GitLab From 58f763a4279d394b3c311147129349143ee1df98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:41:12 +0200 Subject: [PATCH 14/33] Proto/Michelson: move parse_string to the gas monad --- .../lib_protocol/script_ir_translator.ml | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index f2d2a6342024..2d6c1f1fcf14 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1473,16 +1473,17 @@ let parse_bool ~legacy = tzfail @@ Invalid_arity (loc, c, 0, List.length l) | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_True; D_False] -let parse_string ctxt : Script.node -> (Script_string.t * context) tzresult = - let open Result_syntax in +let parse_string : Script.node -> (Script_string.t, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | String (loc, v) as expr -> - let* ctxt = Gas.consume ctxt (Typecheck_costs.check_printable v) in - record_trace - (Invalid_syntactic_constant - (loc, strip_locations expr, "a printable ascii string")) - (let+ s = Script_string.of_string v in - (s, ctxt)) + let*$ () = Typecheck_costs.check_printable v in + Gas_monad.record_trace_eval + ~error_details:(Informative ()) + (fun () -> + Invalid_syntactic_constant + (loc, strip_locations expr, "a printable ascii string")) + (Gas_monad.of_result @@ Script_string.of_string v) | expr -> tzfail @@ Invalid_kind (location expr, [String_kind], kind expr) let parse_bytes ctxt = @@ -2220,7 +2221,7 @@ let rec parse_data : traced_from_gas_monad ctxt @@ (parse_unit ~legacy expr : (a, error trace) Gas_monad.t) | Bool_t, expr -> traced_from_gas_monad ctxt @@ parse_bool ~legacy expr - | String_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_string ctxt expr + | String_t, expr -> traced_from_gas_monad ctxt @@ parse_string expr | Bytes_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bytes ctxt expr | Int_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_int ctxt expr | Nat_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_nat ctxt expr -- GitLab From 0b420aec09b09cb09b2f614ccb6cee6ec108411d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:41:57 +0200 Subject: [PATCH 15/33] Proto/Michelson: move parse_bytes to the gas monad --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 2d6c1f1fcf14..fd81d93ca5f8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1486,10 +1486,10 @@ let parse_string : Script.node -> (Script_string.t, error trace) Gas_monad.t = (Gas_monad.of_result @@ Script_string.of_string v) | expr -> tzfail @@ Invalid_kind (location expr, [String_kind], kind expr) -let parse_bytes ctxt = - let open Result_syntax in +let parse_bytes = + let open Gas_monad.Syntax in function - | Bytes (_, v) -> return (v, ctxt) + | Bytes (_, v) -> return v | expr -> tzfail @@ Invalid_kind (location expr, [Bytes_kind], kind expr) let parse_int ctxt = @@ -2222,7 +2222,7 @@ let rec parse_data : @@ (parse_unit ~legacy expr : (a, error trace) Gas_monad.t) | Bool_t, expr -> traced_from_gas_monad ctxt @@ parse_bool ~legacy expr | String_t, expr -> traced_from_gas_monad ctxt @@ parse_string expr - | Bytes_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bytes ctxt expr + | Bytes_t, expr -> traced_from_gas_monad ctxt @@ parse_bytes expr | Int_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_int ctxt expr | Nat_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_nat ctxt expr | Mutez_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_mutez ctxt expr -- GitLab From 02b57890962ce599d4b5fa22f1af3f9b2c2352d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:42:24 +0200 Subject: [PATCH 16/33] Proto/Michelson: move parse_int to the gas monad --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index fd81d93ca5f8..74fa2d8dd3f8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1492,10 +1492,10 @@ let parse_bytes = | Bytes (_, v) -> return v | expr -> tzfail @@ Invalid_kind (location expr, [Bytes_kind], kind expr) -let parse_int ctxt = - let open Result_syntax in +let parse_int = + let open Gas_monad.Syntax in function - | Int (_, v) -> return (Script_int.of_zint v, ctxt) + | Int (_, v) -> return (Script_int.of_zint v) | expr -> tzfail @@ Invalid_kind (location expr, [Int_kind], kind expr) let parse_nat ctxt : @@ -2223,7 +2223,7 @@ let rec parse_data : | Bool_t, expr -> traced_from_gas_monad ctxt @@ parse_bool ~legacy expr | String_t, expr -> traced_from_gas_monad ctxt @@ parse_string expr | Bytes_t, expr -> traced_from_gas_monad ctxt @@ parse_bytes expr - | Int_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_int ctxt expr + | Int_t, expr -> traced_from_gas_monad ctxt @@ parse_int expr | Nat_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_nat ctxt expr | Mutez_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_mutez ctxt expr | Timestamp_t, expr -> -- GitLab From 9396f2ea90604691a6428e62dede39ae4df2e970 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:42:49 +0200 Subject: [PATCH 17/33] Proto/Michelson: move parse_nat to the gas monad --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 74fa2d8dd3f8..383e28a9cd40 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1498,14 +1498,14 @@ let parse_int = | Int (_, v) -> return (Script_int.of_zint v) | expr -> tzfail @@ Invalid_kind (location expr, [Int_kind], kind expr) -let parse_nat ctxt : - Script.node -> (Script_int.n Script_int.num * context) tzresult = - let open Result_syntax in +let parse_nat : + Script.node -> (Script_int.n Script_int.num, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Int (loc, v) as expr -> ( let v = Script_int.of_zint v in match Script_int.is_nat v with - | Some nat -> return (nat, ctxt) + | Some nat -> return nat | None -> tzfail @@ Invalid_syntactic_constant @@ -2224,7 +2224,7 @@ let rec parse_data : | String_t, expr -> traced_from_gas_monad ctxt @@ parse_string expr | Bytes_t, expr -> traced_from_gas_monad ctxt @@ parse_bytes expr | Int_t, expr -> traced_from_gas_monad ctxt @@ parse_int expr - | Nat_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_nat ctxt expr + | Nat_t, expr -> traced_from_gas_monad ctxt @@ parse_nat expr | Mutez_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_mutez ctxt expr | Timestamp_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_timestamp ctxt expr -- GitLab From ef89abfe5bc4743a8eb77807bd2c2133ec8686a9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:43:15 +0200 Subject: [PATCH 18/33] Proto/Michelson: move parse_mutez to the gas monad --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 383e28a9cd40..3ad5432c6fb3 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1512,15 +1512,15 @@ let parse_nat : (loc, strip_locations expr, "a non-negative integer")) | expr -> tzfail @@ Invalid_kind (location expr, [Int_kind], kind expr) -let parse_mutez ctxt : Script.node -> (Tez.t * context) tzresult = - let open Result_syntax in +let parse_mutez : Script.node -> (Tez.t, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Int (loc, v) as expr -> ( match let open Option in bind (catch (fun () -> Z.to_int64 v)) Tez.of_mutez with - | Some tez -> Ok (tez, ctxt) + | Some tez -> return tez | None -> tzfail @@ Invalid_syntactic_constant @@ -2225,7 +2225,7 @@ let rec parse_data : | Bytes_t, expr -> traced_from_gas_monad ctxt @@ parse_bytes expr | Int_t, expr -> traced_from_gas_monad ctxt @@ parse_int expr | Nat_t, expr -> traced_from_gas_monad ctxt @@ parse_nat expr - | Mutez_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_mutez ctxt expr + | Mutez_t, expr -> traced_from_gas_monad ctxt @@ parse_mutez expr | Timestamp_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_timestamp ctxt expr | Key_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_key ctxt expr -- GitLab From 76659d01ace60c8eb27ae2f8a4cad3546d58b41e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:43:45 +0200 Subject: [PATCH 19/33] Proto/Michelson: move parse_timestamp to the gas monad --- .../lib_protocol/script_ir_translator.ml | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 3ad5432c6fb3..d96703428e7d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1527,17 +1527,17 @@ let parse_mutez : Script.node -> (Tez.t, error trace) Gas_monad.t = (loc, strip_locations expr, "a valid mutez amount")) | expr -> tzfail @@ Invalid_kind (location expr, [Int_kind], kind expr) -let parse_timestamp ctxt : - Script.node -> (Script_timestamp.t * context) tzresult = - let open Result_syntax in +let parse_timestamp : + Script.node -> (Script_timestamp.t, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Int (_, v) (* As unparsed with [Optimized] or out of bounds [Readable]. *) -> - return (Script_timestamp.of_zint v, ctxt) + return (Script_timestamp.of_zint v) | String (loc, s) as expr (* As unparsed with [Readable]. *) -> ( - let* ctxt = Gas.consume ctxt (Typecheck_costs.timestamp_readable s) in + let*$ () = Typecheck_costs.timestamp_readable s in match Script_timestamp.of_string s with - | Some v -> return (v, ctxt) + | Some v -> return v | None -> tzfail @@ Invalid_syntactic_constant @@ -2226,8 +2226,7 @@ let rec parse_data : | Int_t, expr -> traced_from_gas_monad ctxt @@ parse_int expr | Nat_t, expr -> traced_from_gas_monad ctxt @@ parse_nat expr | Mutez_t, expr -> traced_from_gas_monad ctxt @@ parse_mutez expr - | Timestamp_t, expr -> - Lwt.return @@ traced_no_lwt @@ parse_timestamp ctxt expr + | Timestamp_t, expr -> traced_from_gas_monad ctxt @@ parse_timestamp expr | Key_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_key ctxt expr | Key_hash_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_key_hash ctxt expr | Signature_t, expr -> -- GitLab From 944d998a0d49d747650873680861d75fc9a8d5cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:44:07 +0200 Subject: [PATCH 20/33] Proto/Michelson: move parse_key to the gas monad --- .../lib_protocol/script_ir_translator.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index d96703428e7d..bd7a3551558c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1545,25 +1545,25 @@ let parse_timestamp : | expr -> tzfail @@ Invalid_kind (location expr, [String_kind; Int_kind], kind expr) -let parse_key ctxt : Script.node -> (public_key * context) tzresult = - let open Result_syntax in +let parse_key : Script.node -> (public_key, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Bytes (loc, bytes) as expr -> ( (* As unparsed with [Optimized]. *) - let* ctxt = Gas.consume ctxt Typecheck_costs.public_key_optimized in + let*$ () = Typecheck_costs.public_key_optimized in match Data_encoding.Binary.of_bytes_opt Signature.Public_key.encoding bytes with - | Some k -> return (k, ctxt) + | Some k -> return k | None -> tzfail @@ Invalid_syntactic_constant (loc, strip_locations expr, "a valid public key")) | String (loc, s) as expr -> ( (* As unparsed with [Readable]. *) - let* ctxt = Gas.consume ctxt Typecheck_costs.public_key_readable in + let*$ () = Typecheck_costs.public_key_readable in match Signature.Public_key.of_b58check_opt s with - | Some k -> return (k, ctxt) + | Some k -> return k | None -> tzfail @@ Invalid_syntactic_constant @@ -2227,7 +2227,7 @@ let rec parse_data : | Nat_t, expr -> traced_from_gas_monad ctxt @@ parse_nat expr | Mutez_t, expr -> traced_from_gas_monad ctxt @@ parse_mutez expr | Timestamp_t, expr -> traced_from_gas_monad ctxt @@ parse_timestamp expr - | Key_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_key ctxt expr + | Key_t, expr -> traced_from_gas_monad ctxt @@ parse_key expr | Key_hash_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_key_hash ctxt expr | Signature_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_signature ctxt expr -- GitLab From ca884b5264809f2d7f23b5add7654c2ec44c724b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:44:22 +0200 Subject: [PATCH 21/33] Proto/Michelson: move parse_key_hash to the gas monad --- .../lib_protocol/script_ir_translator.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index bd7a3551558c..0f6eb47ef0f7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1572,26 +1572,26 @@ let parse_key : Script.node -> (public_key, error trace) Gas_monad.t = tzfail @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr) -let parse_key_hash ctxt : Script.node -> (public_key_hash * context) tzresult = - let open Result_syntax in +let parse_key_hash : Script.node -> (public_key_hash, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Bytes (loc, bytes) as expr -> ( (* As unparsed with [Optimized]. *) - let* ctxt = Gas.consume ctxt Typecheck_costs.key_hash_optimized in + let*$ () = Typecheck_costs.key_hash_optimized in match Data_encoding.Binary.of_bytes_opt Signature.Public_key_hash.encoding bytes with - | Some k -> return (k, ctxt) + | Some k -> return k | None -> tzfail @@ Invalid_syntactic_constant (loc, strip_locations expr, "a valid key hash")) | String (loc, s) as expr (* As unparsed with [Readable]. *) -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.key_hash_readable in + let*$ () = Typecheck_costs.key_hash_readable in match Signature.Public_key_hash.of_b58check_opt s with - | Some k -> return (k, ctxt) + | Some k -> return k | None -> tzfail @@ Invalid_syntactic_constant @@ -2228,7 +2228,7 @@ let rec parse_data : | Mutez_t, expr -> traced_from_gas_monad ctxt @@ parse_mutez expr | Timestamp_t, expr -> traced_from_gas_monad ctxt @@ parse_timestamp expr | Key_t, expr -> traced_from_gas_monad ctxt @@ parse_key expr - | Key_hash_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_key_hash ctxt expr + | Key_hash_t, expr -> traced_from_gas_monad ctxt @@ parse_key_hash expr | Signature_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_signature ctxt expr | Operation_t, _ -> -- GitLab From 9c8dc486167c54d3aa217a998b8aa4ee2c67db61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:44:57 +0200 Subject: [PATCH 22/33] Proto/Michelson: move parse_signature to the gas monad --- .../lib_protocol/script_ir_translator.ml | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 0f6eb47ef0f7..f7cead2ee1e0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1600,23 +1600,23 @@ let parse_key_hash : Script.node -> (public_key_hash, error trace) Gas_monad.t = tzfail @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr) -let parse_signature ctxt : Script.node -> (signature * context) tzresult = - let open Result_syntax in +let parse_signature : Script.node -> (signature, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Bytes (loc, bytes) as expr (* As unparsed with [Optimized]. *) -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.signature_optimized in + let*$ () = Typecheck_costs.signature_optimized in match Data_encoding.Binary.of_bytes_opt Script_signature.encoding bytes with - | Some k -> return (k, ctxt) + | Some k -> return k | None -> tzfail @@ Invalid_syntactic_constant (loc, strip_locations expr, "a valid signature")) | String (loc, s) as expr (* As unparsed with [Readable]. *) -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.signature_readable in + let*$ () = Typecheck_costs.signature_readable in match Script_signature.of_b58check_opt s with - | Some s -> return (s, ctxt) + | Some s -> return s | None -> tzfail @@ Invalid_syntactic_constant @@ -2229,8 +2229,7 @@ let rec parse_data : | Timestamp_t, expr -> traced_from_gas_monad ctxt @@ parse_timestamp expr | Key_t, expr -> traced_from_gas_monad ctxt @@ parse_key expr | Key_hash_t, expr -> traced_from_gas_monad ctxt @@ parse_key_hash expr - | Signature_t, expr -> - Lwt.return @@ traced_no_lwt @@ parse_signature ctxt expr + | Signature_t, expr -> traced_from_gas_monad ctxt @@ parse_signature expr | Operation_t, _ -> (* operations cannot appear in parameters or storage, the protocol should never parse the bytes of an operation *) -- GitLab From bbf7224d3d4ef04d47bddec0992821bd1980c35e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:45:14 +0200 Subject: [PATCH 23/33] Proto/Michelson: move parse_chain_id to the gas monad --- .../lib_protocol/script_ir_translator.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index f7cead2ee1e0..f4bae953b935 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1625,24 +1625,24 @@ let parse_signature : Script.node -> (signature, error trace) Gas_monad.t = tzfail @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr) -let parse_chain_id ctxt : Script.node -> (Script_chain_id.t * context) tzresult +let parse_chain_id : Script.node -> (Script_chain_id.t, error trace) Gas_monad.t = - let open Result_syntax in + let open Gas_monad.Syntax in function | Bytes (loc, bytes) as expr -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.chain_id_optimized in + let*$ () = Typecheck_costs.chain_id_optimized in match Data_encoding.Binary.of_bytes_opt Script_chain_id.encoding bytes with - | Some k -> return (k, ctxt) + | Some k -> return k | None -> tzfail @@ Invalid_syntactic_constant (loc, strip_locations expr, "a valid chain id")) | String (loc, s) as expr -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.chain_id_readable in + let*$ () = Typecheck_costs.chain_id_readable in match Script_chain_id.of_b58check_opt s with - | Some s -> return (s, ctxt) + | Some s -> return s | None -> tzfail @@ Invalid_syntactic_constant @@ -2234,7 +2234,7 @@ let rec parse_data : (* operations cannot appear in parameters or storage, the protocol should never parse the bytes of an operation *) assert false - | Chain_id_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_chain_id ctxt expr + | Chain_id_t, expr -> traced_from_gas_monad ctxt @@ parse_chain_id expr | Address_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_address ctxt expr | Contract_t (arg_ty, _), expr -> traced -- GitLab From 47ec587777aaf291a5c17fa04aec74cb74fb99e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:45:46 +0200 Subject: [PATCH 24/33] Proto/Michelson: move parse_never to the gas monad --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index f4bae953b935..9325062f05d2 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1692,8 +1692,8 @@ let parse_address ctxt : Script.node -> (address * context) tzresult = tzfail @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr) -let parse_never expr : (never * context) tzresult = - Result_syntax.tzfail @@ Invalid_never_expr (location expr) +let parse_never expr : (never, error trace) Gas_monad.t = + Gas_monad.Syntax.tzfail @@ Invalid_never_expr (location expr) let parse_bls12_381_g1 ctxt : Script.node -> (Script_bls.G1.t * context) tzresult = @@ -2439,7 +2439,7 @@ let rec parse_data : else traced_fail (Unexpected_forged_value loc) in (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt) - | Never_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_never expr + | Never_t, expr -> traced_from_gas_monad ctxt @@ parse_never expr (* Bls12_381 types *) | Bls12_381_g1_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bls12_381_g1 ctxt expr -- GitLab From 0019de1388330abd1f527b7bcacc03c106c892d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 22 Sep 2023 12:46:24 +0200 Subject: [PATCH 25/33] Proto/Michelson: move parse_address to the gas monad --- .../lib_protocol/script_ir_translator.ml | 41 ++++++++++++------- 1 file changed, 27 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 9325062f05d2..9719f2e330f6 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1651,43 +1651,44 @@ let parse_chain_id : Script.node -> (Script_chain_id.t, error trace) Gas_monad.t tzfail @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr) -let parse_address ctxt : Script.node -> (address * context) tzresult = - let open Result_syntax in - let destination_allowed loc {destination; entrypoint} ctxt = +let parse_address ~sc_rollup_enable ~zk_rollup_enable : + Script.node -> (address, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + let destination_allowed loc {destination; entrypoint} = match destination with - | Destination.Sc_rollup _ when not (Constants.sc_rollup_enable ctxt) -> + | Destination.Sc_rollup _ when not sc_rollup_enable -> tzfail @@ Sc_rollup_disabled loc - | Destination.Zk_rollup _ when not (Constants.zk_rollup_enable ctxt) -> + | Destination.Zk_rollup _ when not zk_rollup_enable -> tzfail @@ Zk_rollup_disabled loc - | _ -> Ok ({destination; entrypoint}, ctxt) + | _ -> return {destination; entrypoint} in function | Bytes (loc, bytes) as expr (* As unparsed with [Optimized]. *) -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.contract_optimized in + let*$ () = Typecheck_costs.contract_optimized in match Data_encoding.Binary.of_bytes_opt Data_encoding.(tup2 Destination.encoding Entrypoint.value_encoding) bytes with | Some (destination, entrypoint) -> - destination_allowed loc {destination; entrypoint} ctxt + destination_allowed loc {destination; entrypoint} | None -> tzfail @@ Invalid_syntactic_constant (loc, strip_locations expr, "a valid address")) | String (loc, s) (* As unparsed with [Readable]. *) -> - let* ctxt = Gas.consume ctxt Typecheck_costs.contract_readable in + let*$ () = Typecheck_costs.contract_readable in let* addr, entrypoint = match String.index_opt s '%' with | None -> return (s, Entrypoint.default) | Some pos -> let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in - let+ entrypoint = Entrypoint.of_string_strict ~loc name in + let+? entrypoint = Entrypoint.of_string_strict ~loc name in (String.sub s 0 pos, entrypoint) in - let* destination = Destination.of_b58check addr in - destination_allowed loc {destination; entrypoint} ctxt + let*? destination = Destination.of_b58check addr in + destination_allowed loc {destination; entrypoint} | expr -> tzfail @@ Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr) @@ -2235,10 +2236,22 @@ let rec parse_data : the protocol should never parse the bytes of an operation *) assert false | Chain_id_t, expr -> traced_from_gas_monad ctxt @@ parse_chain_id expr - | Address_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_address ctxt expr + | Address_t, expr -> + traced_from_gas_monad ctxt + @@ parse_address + ~sc_rollup_enable:(Constants.sc_rollup_enable ctxt) + ~zk_rollup_enable:(Constants.zk_rollup_enable ctxt) + expr | Contract_t (arg_ty, _), expr -> traced - (let*? address, ctxt = parse_address ctxt expr in + (let*? address, ctxt = + Gas_monad.run ctxt + @@ parse_address + ~sc_rollup_enable:(Constants.sc_rollup_enable ctxt) + ~zk_rollup_enable:(Constants.zk_rollup_enable ctxt) + expr + in + let*? address in let loc = location expr in let+ ctxt, typed_contract = parse_contract_data -- GitLab From 4a9b8de2bbc4058135ea82d970b6b57f5b8fc0cf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 15:00:19 +0200 Subject: [PATCH 26/33] Proto/Michelson: move parse_bls12_381_g1 to the gas monad --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 9719f2e330f6..d6906f5577c4 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1696,14 +1696,14 @@ let parse_address ~sc_rollup_enable ~zk_rollup_enable : let parse_never expr : (never, error trace) Gas_monad.t = Gas_monad.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 +let parse_bls12_381_g1 : + Script.node -> (Script_bls.G1.t, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Bytes (loc, bs) as expr -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g1 in + let*$ () = Typecheck_costs.bls12_381_g1 in match Script_bls.G1.of_bytes_opt bs with - | Some pt -> return (pt, ctxt) + | Some pt -> return pt | None -> tzfail (Invalid_syntactic_constant @@ -2455,7 +2455,7 @@ let rec parse_data : | Never_t, expr -> traced_from_gas_monad ctxt @@ parse_never expr (* Bls12_381 types *) | Bls12_381_g1_t, expr -> - Lwt.return @@ traced_no_lwt @@ parse_bls12_381_g1 ctxt expr + traced_from_gas_monad ctxt @@ parse_bls12_381_g1 expr | Bls12_381_g2_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bls12_381_g2 ctxt expr | Bls12_381_fr_t, expr -> -- GitLab From efccc4e712e15903a01957b51bf25659df1f7220 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 15:01:22 +0200 Subject: [PATCH 27/33] Proto/Michelson: move parse_bls12_381_g2 to the gas monad --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index d6906f5577c4..a8a23c48ca0b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1710,14 +1710,14 @@ let parse_bls12_381_g1 : (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 +let parse_bls12_381_g2 : + Script.node -> (Script_bls.G2.t, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Bytes (loc, bs) as expr -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_g2 in + let*$ () = Typecheck_costs.bls12_381_g2 in match Script_bls.G2.of_bytes_opt bs with - | Some pt -> return (pt, ctxt) + | Some pt -> return pt | None -> tzfail (Invalid_syntactic_constant @@ -2457,7 +2457,7 @@ let rec parse_data : | Bls12_381_g1_t, expr -> traced_from_gas_monad ctxt @@ parse_bls12_381_g1 expr | Bls12_381_g2_t, expr -> - Lwt.return @@ traced_no_lwt @@ parse_bls12_381_g2 ctxt expr + traced_from_gas_monad ctxt @@ parse_bls12_381_g2 expr | Bls12_381_fr_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bls12_381_fr ctxt expr (* -- GitLab From 8484177ab5e18e09f1a615096c3c3947b4a81485 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 15:02:28 +0200 Subject: [PATCH 28/33] Proto/Michelson: move parse_bls12_381_fr to the gas monad --- .../lib_protocol/script_ir_translator.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a8a23c48ca0b..b954bc6adc9b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1724,21 +1724,21 @@ let parse_bls12_381_g2 : (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 +let parse_bls12_381_fr : + Script.node -> (Script_bls.Fr.t, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Bytes (loc, bs) as expr -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.bls12_381_fr in + let*$ () = Typecheck_costs.bls12_381_fr in match Script_bls.Fr.of_bytes_opt bs with - | Some pt -> return (pt, ctxt) + | Some pt -> return pt | 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) + let*$ () = Typecheck_costs.bls12_381_fr in + return (Script_bls.Fr.of_z v) | expr -> tzfail (Invalid_kind (location expr, [Bytes_kind], kind expr)) let parse_sapling_transaction ctxt ~memo_size : @@ -2459,7 +2459,7 @@ let rec parse_data : | Bls12_381_g2_t, expr -> traced_from_gas_monad ctxt @@ parse_bls12_381_g2 expr | Bls12_381_fr_t, expr -> - Lwt.return @@ traced_no_lwt @@ parse_bls12_381_fr ctxt expr + traced_from_gas_monad ctxt @@ parse_bls12_381_fr expr (* /!\ When adding new lazy storage kinds, you may want to guard the parsing of identifiers with [allow_forged]. -- GitLab From d07395457b21fd48e099661bcc7896993ff6e7af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 15:03:59 +0200 Subject: [PATCH 29/33] Proto/Michelson: move parse_sapling_transaction to the gas monad --- .../lib_protocol/script_ir_translator.ml | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index b954bc6adc9b..86f894f8560b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1741,9 +1741,9 @@ let parse_bls12_381_fr : return (Script_bls.Fr.of_z v) | 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 +let parse_sapling_transaction ~memo_size : + Script.node -> (Sapling.transaction, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Bytes (loc, bytes) as expr -> ( match @@ -1751,15 +1751,15 @@ let parse_sapling_transaction ctxt ~memo_size : with | Some transaction -> ( match Sapling.transaction_get_memo_size transaction with - | None -> return (transaction, ctxt) + | None -> return transaction | Some transac_memo_size -> - let* () = + let*? () = memo_size_eq ~error_details:(Informative ()) memo_size transac_memo_size in - return (transaction, ctxt)) + return transaction) | None -> tzfail (Invalid_syntactic_constant @@ -2466,8 +2466,7 @@ let rec parse_data : *) (* Sapling *) | Sapling_transaction_t memo_size, expr -> - Lwt.return @@ traced_no_lwt - @@ parse_sapling_transaction ctxt ~memo_size expr + traced_from_gas_monad ctxt @@ parse_sapling_transaction ~memo_size expr | Sapling_transaction_deprecated_t memo_size, expr -> Lwt.return @@ traced_no_lwt @@ parse_sapling_transaction_deprecated ctxt ~memo_size expr -- GitLab From 905cda80428ee0b7f8c709a2df6478710e3e3ecd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 15:05:05 +0200 Subject: [PATCH 30/33] Proto/Michelson: move parse_sapling_transaction_deprecated to GM --- .../lib_protocol/script_ir_translator.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 86f894f8560b..5571b274f96d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1766,9 +1766,9 @@ let parse_sapling_transaction ~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 +let parse_sapling_transaction_deprecated ~memo_size : + Script.node -> (Sapling.Legacy.transaction, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Bytes (loc, bytes) as expr -> ( match @@ -1778,15 +1778,15 @@ let parse_sapling_transaction_deprecated ctxt ~memo_size : with | Some transaction -> ( match Sapling.Legacy.transaction_get_memo_size transaction with - | None -> return (transaction, ctxt) + | None -> return transaction | Some transac_memo_size -> - let* () = + let*? () = memo_size_eq ~error_details:(Informative ()) memo_size transac_memo_size in - return (transaction, ctxt)) + return transaction) | None -> tzfail (Invalid_syntactic_constant @@ -2468,8 +2468,8 @@ let rec parse_data : | Sapling_transaction_t memo_size, expr -> traced_from_gas_monad ctxt @@ parse_sapling_transaction ~memo_size expr | Sapling_transaction_deprecated_t memo_size, expr -> - Lwt.return @@ traced_no_lwt - @@ parse_sapling_transaction_deprecated ctxt ~memo_size expr + traced_from_gas_monad ctxt + @@ parse_sapling_transaction_deprecated ~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 7d5c4629032886b68f74a2c8bc05c767e10dda5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 15:05:53 +0200 Subject: [PATCH 31/33] Proto/Michelson: move parse_chest_key to the gas monad --- .../lib_protocol/script_ir_translator.ml | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 5571b274f96d..479c240bcd3a 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1795,18 +1795,18 @@ let parse_sapling_transaction_deprecated ~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 +let parse_chest_key : + Script.node -> (Script_timelock.chest_key, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Bytes (loc, bytes) as expr -> ( - let* ctxt = Gas.consume ctxt Typecheck_costs.chest_key in + let*$ () = 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) + | Some chest_key -> return chest_key | None -> tzfail (Invalid_syntactic_constant @@ -2491,8 +2491,7 @@ 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 @@ parse_chest_key ctxt expr + | Chest_key_t, expr -> traced_from_gas_monad ctxt @@ parse_chest_key expr | Chest_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_chest ctxt expr and parse_view : -- GitLab From 7c264852883b1a3824cc1be299bead2a1d8e4ea1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 15:06:54 +0200 Subject: [PATCH 32/33] Proto/Michelson: move parse_chest to the gas monad --- .../lib_protocol/script_ir_translator.ml | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 479c240bcd3a..2fcb84fe85c0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1813,18 +1813,16 @@ let parse_chest_key : (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 +let parse_chest : + Script.node -> (Script_timelock.chest, error trace) Gas_monad.t = + let open Gas_monad.Syntax in function | Bytes (loc, bytes) as expr -> ( - let* ctxt = - Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) - in + let*$ () = 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) + | Some chest -> return chest | None -> tzfail (Invalid_syntactic_constant @@ -2492,7 +2490,7 @@ let rec parse_data : (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) | Chest_key_t, expr -> traced_from_gas_monad ctxt @@ parse_chest_key expr - | Chest_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_chest ctxt expr + | Chest_t, expr -> traced_from_gas_monad ctxt @@ parse_chest expr and parse_view : type storage storagec. -- GitLab From 04367f3e74bdf8e475b0923d9dcc3fe91eb93ae5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 17:47:19 +0200 Subject: [PATCH 33/33] Changelog: mention !10211 --- docs/protocols/alpha.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/protocols/alpha.rst b/docs/protocols/alpha.rst index 88cf5e255e3e..d026951e852d 100644 --- a/docs/protocols/alpha.rst +++ b/docs/protocols/alpha.rst @@ -78,4 +78,4 @@ Internal previously not registered, making the error message a bit obscure. (MR :gl:`!9603`) - Move some Michelson elaboration and erasure functions to the gas - monad. (MR :gl:`!10071`) + monad. (MR :gl:`!10071`, :gl:`!10211`) -- GitLab